[LISP程序]：请问有没有直线加粗程序

ld80721

不知哪位仁兄有直线加粗程序,谢谢!

doswin

论坛有，自己找

afeng0712

(DEFUN C:CW (/ W2 SS S1 ENT LT I P1 P2 R)
  (SETVAR "CMDECHO" 0)
  (SETVAR "BLIPMODE" 0)
  (VL-LOAD-COM)
  (IF (NOT W1)
    (SETQ W1 (GETVAR "PLINEWID"))
  )
  (PRINC "\n 请选择需要修改线宽的线段:")
  (SETQ SS (SSGET '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))
  (IF (> (SSLENGTH SS) 0)
    (PROGN
      (SETQ W2 W1)
      (PRINC
        "\n 请输入新的统一线宽<"
      )
      (PRINC W1)
      (PRINC ">:")
      (SETQ W1 (GETREAL))
      (IF (= W1 NIL)
        (SETQ W1 W2)
      )
      (SETQ I 0)
      (REPEAT (SSLENGTH SS)
        (SETQ S1 (SSNAME SS I))
        (SETQ ENT (ENTGET S1))
        (SETQ LT (CDR (ASSOC 0 ENT)))
        (COND
          ((OR (= LT "ELLIPSE") (= LT "SPLINE"))
           (VLA-PUT-LINEWEIGHT
             (VLAX-ENAME->VLA-OBJECT S1)
             (EVAL (READ (STRCAT "acLnWt" (GETSW W1))))
           )
          )
          ((= LT "CIRCLE")
           (SETQ P1 (CDR (ASSOC 10 ENT)))
           (SETQ R (CDR (ASSOC 40 ENT)))
           (SETQ P2 (POLAR P1 0.000001 R))
           (SETQ P2 (OSNAP P2 "_NEA"))
           (SETQ P1 (POLAR P1 0.0 R))
           (SETQ P1 (OSNAP P1 "_NEA"))
           (COMMAND "_BREAK" S1 P1 P2)
           (COMMAND "_PEDIT" S1 "" "W" W1 "")
          )
          ((= LT "LWPOLYLINE")
           (COMMAND "_PEDIT" S1 "W" W1 "")
          )
          ((COMMAND "_PEDIT" S1 "" "W" W1 "")
          )
        )
        (SETQ I (1+ I))
      )
    )
  )
  (SETVAR "CMDECHO" 1)
  (PRINC)
)
(PRINC "\n 修改线宽程序已加载，运行命令:CW")
(DEFUN GETSW (W / I LST1 LST2 E1)
  (SETQ        LST1 '("000"        "005"         "009"          "013"           "015"    "018"
               "020"        "025"         "030"          "035"           "040"    "050"
               "053"        "060"         "070"          "080"           "090"    "100"
               "106"        "120"         "140"          "158"           "200"    "211"
              )
  )
  (SETQ        LST2 (MAPCAR '(LAMBDA (X)
                        (ABS (- (/ (ATOF X) 100.0) W))
                      )
                     LST1
             )
  )
  (SETQ E1 (APPLY 'MIN LST2))
  (SETQ I 0)
  (WHILE (/= E1 (NTH I LST2))
    (SETQ I (1+ I))
  )
  (SETQ W2 (NTH I LST1))
)

jeson0113

谢谢了，这个很好用的哦！