一些随手写的小工具（慢慢更新）

dwg001

把子实体从块中移出而不是删除的功能，使用的频率也很高。

cxjzxf

太谢谢楼主了。

Free-Lancer

20 连续测距
[pcode=lisp,true];;; 通过点画虚线
;;测点长度
(defun c:Dist (/ pt ptl dist scl)
  (while (setq pt (getpoint "\n测点: "))
    (setq ptl (cons pt ptl))
    (if        (> (length ptl) 1)
      (progn
        (princ
          (strcat
            "\n当前段长度 = "
            (vl-princ-to-string (distance (car ptl) (cadr ptl)))
            " 米。"
          )
        )
        (grdraw (car ptl) (cadr ptl) 1 1)
      )
    )
  )
  (setq        dist (mapcar '(lambda (x y) (distance x y))
                     (cdr ptl)
                     (reverse (cdr (reverse ptl)))
             )
  )
  (princ
    (strcat "\n总长度 = "
            (vl-princ-to-string (apply '+ dist))
            " 米。"
    )
  )
  (grclear)
  (princ)
)[/pcode]

Free-Lancer

21 按比例在屏幕上显示图形[pcode=lisp,true](defun c:ZC ()
  (vl-catch-all-apply
    (function
      (lambda (/ lst pt scale h app)
        (setq scl (/ 194. 952))
        (if (and (setq pt (getpoint "\n中心点: "))
                 (setq scale (getreal "\n比例: "))
            )
          (progn
            (setq h (/ (* (cadr (getvar "screensize")) scl) scale))
            (setq app (vla-get-application (vlax-get-acad-object)))
            (vla-zoomcenter app (vlax-3d-point pt) h)
          )
        )
      )
    )
  )
  (princ)
)[/pcode]

xieyanghui123

十分感谢！程序很好！

adc

很棒，多谢分享

i3ku

:P留贴:lol

Free-Lancer

22 改块颜色，没有递归处理，因为使用了Activeselecitonset，关于这个的Bug请搜索相关解决方案
[pcode=lisp,true](defun c:tt (/ e el bn blocks doc)
  (setq        doc    (vla-get-activedocument (vlax-get-acad-object))
        blocks (vla-get-blocks doc)
  )
  (while (setq e (car (entsel)))
    (setq el (entget e))
    (if        (setq bn (cdr (assoc 2 el)))
      (progn
        (vlax-for obj (vla-item blocks bn)
          (vla-put-color obj 8)
        )
        (if (setq ss (ssget "x" (list (assoc 0 el) (assoc 2 el))))
          (vlax-for obj        (vla-get-activeselectionset doc)
            (vla-update obj)
          )
        )
      )
    )
  )
  (vlax-release-object doc)
  (vlax-release-object blocks)
  (princ)
)[/pcode]
另外一个写法，重复了
[pcode=lisp,true](defun c:chbc (/ blocks e el blk ss sl i)
  (setq        blocks (vla-get-blocks
                 (vla-get-activedocument (vlax-get-acad-object))
               )
  )
  (while (and (setq e (car (entsel "\nPick Insert: ")))
              (= (cdr (assoc 0 (setq el (entget e)))) "INSERT")
         )
    (setq blk (vla-item blocks (cdr (assoc 2 el))))
    (vlax-for obj blk
      (vla-put-color obj acbyblock)
    )
    (setq ss (ssget "_a" (list (assoc 0 el) (assoc 2 el)))
          sl (sslength ss)
          i  -1
    )
    (repeat sl
      (entupd (ssname ss (setq i (1+ i))))
    )
  )
  (princ)
)[/pcode]
第三个写法，随手写的，用的时候就写几句[pcode=lisp,true](defun c:tt (/ e el bn *acad*)
  (setq *acad* (vlax-get-acad-object))
  (while (setq e (ssget ":S" '((0 . "Insert"))))
    (setq el (entget (ssname e 0))
          bn (cdr (assoc 2 el))
    )
    (vla-eval *acad*
              (strcat "For each obj In thisdrawing.blocks.item("
                      "\""
                      bn
                      "\"):obj.color=acbyblock:next"
              )
    )
    (if        (ssget "X" (list (assoc 2 el)))
      (vla-eval
        *acad*
        "For Each obj In Thisdrawing.activeselectionset:Obj.Update:Next"
      )
    )
  )
  (princ)
)[/pcode]

Free-Lancer

23 统计线长[pcode=lisp,true](defun c:cLen (/)
  (vl-load-com)
  (vl-catch-all-apply
    (function
      (lambda (/ e el lay ss ssl i len)
        (while
          (and
            (progn
              (princ
                "\n点选特征曲线[回车退出] ...."
              )
              T
            )
            (setq e (ssget ":S" '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))
          )
           (setq el  (entget (ssname e 0))
                 lay (assoc 8 el)
           )
           (princ "\n统计范围.....")
           (if (setq
                 ss (ssget (list lay '(0 . "*LINE,ARC,CIRCLE,ELLIPSE")))
               )
             (progn
               (setq ssl (sslength ss)
                     i         -1
                     len 0.
               )
               (repeat ssl
                 (setq e   (ssname ss (setq i (1+ i)))
                       len (+ len
                              (vlax-curve-getdistatparam
                                e
                                (vlax-curve-getendparam e)
                              )
                           )
                 )
               )
               (princ (strcat "Totle Length = " (vl-princ-to-string len))
               )
             )
           )
        )
      )
    )
  )
  (princ)
)[/pcode]

Free-Lancer

24 修改Pline局部线宽[pcode=lisp,true](defun c:Plw (/ e e0 p w pam p1 p2)
  (while (and (setq e (entsel "\n选择多线: "))
              (setq e0 (car e)
                    p  (cadr e)
              )
              (if
                (setq
                  w (getreal
                      (strcat "\n输入宽度:< "
                              (vl-princ-to-string (getvar "plinewid"))
                              ">: "
                      )
                    )
                )
                 (setvar "plinewid" w)
                 (setq w (getvar "plinewid"))
              )
         )
    (setq pam (vlax-curve-getparamatpoint
                e0
                (vlax-curve-getclosestpointto e0 p)
              )
          p1  (fix pam)
          p2  (1+ pam)
    )
    (vla-setwidth (vlax-ename->vla-object e0) p1 w w)
  )
  (princ)
)[/pcode]

Free-Lancer

25 锁定图层[pcode=lisp,true](defun c:lyrlk (/ *acad* doc)
  (setq        *acad* (vlax-get-acad-object)
        doc    (vla-get-activedocument *acad*)
  )
  (vla-startundomark doc)
  (vl-catch-all-apply
    '(lambda (/ lyr e)
       (while (setq e (car (entsel "\nSelect Lock Layer: ")))
         (setq lyr (cdr (assoc 8 (entget e))))
         (vla-eval
           (vlax-get-acad-object)
           (strcat "Thisdrawing.layers.Item(\"" lyr "\").Lock = True")
         )
       )
     )
  )
  (vla-endundomark doc)
  (vlax-release-object doc)
  (vlax-release-object *acad*)
  (princ)
)[/pcode]

Free-Lancer

26 集合几个清理功能[pcode=lisp,true];;删除 zerop curve and null text
(defun c:purgedwg (/ doc blocks ss ssl i e delnulltext delzerop)
  (defun delnulltext (str)
    (if        (= (vl-string-trim " " (vla-get-textstring obj)) "")
      (vla-delete obj)
    )
  )
  (defun delzerop (obj mode)
    (if        (equal
          (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj))
          0.
          1e-8
        )
      (if mode
        (entdel obj)
        (vla-delete obj)
      )
    )
  )
  (setq        doc    (vla-get-activedocument (vlax-get-acad-object))
        blocks (vla-get-blocks doc)
  )
  (princ "\nDel Null String ....")
  (if (ssget "X" '((0 . "*text")))
    (vlax-for obj (vla-get-activeselectionset doc)
      (delnulltext obj)
    )
  )
  (princ "\nDel Zerop Line ....")
  (if (setq ss (ssget "X" '((0 . "*line,arc,circle,ellipse"))))
    (progn
      (setq ssl        (sslength ss)
            i        -1
      )
      (repeat ssl
        (setq e (ssname ss (setq i (1+ i))))
        (delzerop e t)
      )
    )
  )
  (princ "\nWaiting, Pross Blocks .....")
  (vlax-for blk        blocks
    (if        (not (wcmatch (vla-get-name blk) "*_Space*"))
      (vlax-for        obj blk
        (cond
          ((wcmatch (vla-get-objectname obj) "*Text")
           (delnulltext obj)
          )
          ((wcmatch (strcase (vla-get-objectname obj))
                    "*LINE,ARC,CIRCLE,ELLIPSE"
           )
           (delzerop obj nil)
          )
          (t)
        )
      )
    )
  )
  (princ "\nDel Layer Filter ....")
  (vla-eval
    (vlax-get-acad-object)
    "For Each ent in ThisDrawing.Layers.GetExtensionDictionary(\"ACAD_LAYERFILTERS\"): ent.Delete: Next ent"
  )
  (princ "\nDel Null Groups ....")
  (vlax-for grp        (vla-get-groups doc)
    (if        (zerop (vla-get-count grp))
      (vla-delete grp)
    )
  )
  (princ)
)[/pcode]

Free-Lancer

27 一个处理标注的，忘了什么功能，自行测试[pcode=lisp,true](defun c:tt (/ e ss)
  (if (and (progn
             (princ "\nSelect Source Dim...")
             (setq e (ssget ":S" '((0 . "dimension"))))
           )
           (progn
             (princ "\nSelect Target Dim...")
             (setq ss (ssget '((0 . "dimension"))))
           )
      )
    (vl-catch-all-apply
      '(lambda (/ obj str)
         (setq obj (vlax-ename->vla-object (ssname e 0)))
         (if (vl-position
               (setq str (vla-get-textoverride obj))
               '("" " " "<>")
             )
           (setq str (rtos (vla-get-measurement obj)
                           2
                           (vla-get-PrimaryUnitsPrecision
                             obj
                           )
                     )
           )
         )
         (vlax-for obj
                   (vla-get-activeselectionset
                     (vla-get-activedocument (vlax-get-acad-object))
                   )
           (vla-put-textoverride obj str)
         )
       )
    )
  )
  (princ)
)[/pcode]

Free-Lancer

28 好像是实体中心自身缩放，比例或放缩[pcode=lisp,true](defun c:tt (/ mp up midp scl  d0 d)
  (vla-eval (vlax-get-acad-object)
            "Thisdrawing.activeselectionset.delete"
  )
  (initget 128 "R")
  (setq scl (getdist "\nScalefactor[Reference]: "))
  (cond
    ((and (= scl "R")
          (setq d0 (getdist "\nOld Length: "))
          (setq d (getdist "\nNew Length: "))
     )
     (setq scl (/ d d0))
    )
    ((= (type scl) 'REAL) scl)
    (t (exit))
  )
  (if (ssget)
    (vlax-for obj (vla-get-activeselectionset
                    (vla-get-activedocument (vlax-get-acad-object))
                  )
      (vla-getboundingbox obj 'Mp 'up)
      (setq
        midp (mapcar
               '(lambda (x) (* 0.5 x))
               (mapcar '+ (safearray-value mp) (safearray-value up))
             )
      )
      (vla-scaleentity obj (vlax-3d-point midp) scl)
    )
  )
  (princ)
)[/pcode]

Free-Lancer

29 学习 CopyObjects ，也可能是别人的程序[pcode=lisp,true](defun c:test (/ all it j modle names one)
  (setq all (vla-get-documents (vlax-get-acad-object)))
  (vlax-for one        all
    (if        (not (equal *document* one))
      (setq names (cons (cons (vla-get-name one) one) names))
    )
  )
  (setq j 0)
  (foreach one names
    (princ "\n")
    (princ (setq j (1+ j)))
    (princ "    ")
    (princ (car one))
  )
  (textscr)
  (initget 6)
  (if (setq j (getint "\n选文件"))
    (progn
      (setq modle
             (vla-get-modelspace (setq _doc (cdr (nth (1- j) names))))
      )
      (vlax-for        it modle
        (vl-catch-all-apply
          'vla-copyobjects
          (list        _doc
                (vlax-safearray-fill
                  (vlax-make-safearray vlax-vbobject '(0 . 0))
                  (list it)
                )
                *ModelSpace*
          )
        )
      )
    )
  )
  (mapcar '(lambda (x) (vlax-release-object (eval x)))
          '(modle _doc)
  )
  (princ)
)[/pcode]