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

Free-Lancer · 发表于 2013-4-25 15:36:46

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有帐号？立即注册

x

1 删除子实体，用在临时删除图块中的某一实体，比Refedit便捷
[pcode=lisp,true](defun c:delsubent (/ e)
  (while (setq e (nentsel))
(vla-delete (vlax-ename->vla-object (car e)))
(if (= (length e) 4)
   (mapcar 'entupd (last e))
)
  )
  (princ)
)[/pcode]

上一篇：检查曲线是否全部围合为闭合区域
下一篇：另类Purge

haoryh · 发表于 2013-5-20 09:07:15

就是根本没删除，没反应，见演示！

Free-Lancer · 发表于 2013-5-2 08:57:34

6 Line编号
根据Line起点由下向上编号
[pcode=lisp,true](defun c:tt (/ ss sl i e el ms n)
 (setq ms (vla-get-modelspace
 (vla-get-activedocument (vlax-get-acad-object))
 )
n 1
 )
 (if (setq ss (ssget '((0 . "line"))))
(progn
 (setq sl (sslength ss)
 i -1
 )
 (repeat sl
(setq e (ssname ss (setq i (1+ i)))
 el (cons (vlax-curve-getstartpoint e) el)
)
 )
 (setq el (vl-sort el '(lambda (e1 e2) (< (cadr e1) (cadr e2)))))
 (foreach x el
(vla-addtext ms (itoa n) (vlax-3d-point x) 2.5)
(setq n (1+ n))
 )
)
 )
 (princ)
)[/pcode]

Free-Lancer · 发表于 2013-5-2 17:02:41

本帖最后由 Free-Lancer 于 2013-5-2 17:06 编辑

13 循环修改文字示例，可以是块中的文字、属性、多行文字[pcode=lisp,true] ;|
循环修改文字示例，可以是块中的文字、属性、多行文字
|;
(defun c:ChgTxt ()
 (vl-catch-all-apply
(function
 (lambda (/ e vla-object)
 (while (and (setq e (nentsel "\n选择文字<退出>: "))
 (setq vla-object
 (vlax-ename->vla-object (car e))
 )
 (member (vla-get-objectname vla-object)
 '("AcDbText" "AcDbAttribute" "AcDbMtext")
 )
 )
 (princ (strcat "\n原文字: "
 (vla-get-textstring vla-object)
 )
 )
 (vla-put-textstring
 vla-object
 (getstring "\n新文字: ")
 )
 (if (> (length e) 2)
 (vla-update
 (vlax-ename->vla-object (last (last e)))
 )
 )
 )
 )
)
 )
 (princ)
)[/pcode]

Free-Lancer · 发表于 2013-5-5 15:37:22

本帖最后由 Free-Lancer 于 2013-5-5 15:38 编辑

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 · 发表于 2013-5-2 08:53:55

5 实体中心缩放
因为使用了VBA，2010以上要单独安装，不过对Lisper爱好者，最好安装，写程序会更便捷
[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 · 发表于 2013-4-25 15:45:38

2 Pline"复制"某一段

(vl-load-com)
(defun c:tt (/ doc ms)
(setq doc (vla-get-activedocument (vlax-get-acad-object))
ms (vla-get-modelspace doc)
)
(vla-startundomark doc)
(vl-catch-all-apply
(function
(lambda (/ e el p ent pt i p1 p2 pl)
(while (and
(setq e (entsel "\nSelect Polyline: "))
(setq el (entget (car e)))
(= (cdr (assoc 0 el)) "LWPOLYLINE")
)
(setq p (cadr e)
ent (vlax-ename->vla-object (car e))
)
(setq pt (vlax-curve-getclosestpointto ent p)
i (fix (vlax-curve-getparamatpoint ent pt))
p1 (vlax-curve-getpointatparam ent i)
p2 (vlax-curve-getpointatparam ent (1+ i))
)
(vla-setbulge
(setq pl (vlax-invoke
ms
'addlightweightpolyline
(list (car p1) (cadr p1) (car p2) (cadr p2))
)
)
0
(vla-getbulge ent i)
)
(vla-put-color pl acGreen)
(vla-put-ConstantWidth pl 0.1)
)
)
)
nil
)
(vla-endundomark doc)
(princ)
)

(vl-load-com) 
(defun c:tt (/ doc ms) 
  (setq        doc (vla-get-activedocument (vlax-get-acad-object)) 
        ms  (vla-get-modelspace doc) 
  ) 
  (vla-startundomark doc) 
  (vl-catch-all-apply 
    (function 
      (lambda (/ e el p ent pt i p1 p2 pl) 
        (while (and 
                 (setq e (entsel "\nSelect Polyline: ")) 
                 (setq el (entget (car e))) 
                 (= (cdr (assoc 0 el)) "LWPOLYLINE") 
               ) 
          (setq        p   (cadr e) 
                ent (vlax-ename->vla-object (car e)) 
          ) 
          (setq        pt (vlax-curve-getclosestpointto ent p) 
                i  (fix (vlax-curve-getparamatpoint ent pt)) 
                p1 (vlax-curve-getpointatparam ent i) 
                p2 (vlax-curve-getpointatparam ent (1+ i)) 
          ) 
          (vla-setbulge 
            (setq pl (vlax-invoke 
                       ms 
                       'addlightweightpolyline 
                       (list (car p1) (cadr p1) (car p2) (cadr p2)) 
                     ) 
            ) 
            0 
            (vla-getbulge ent i) 
          ) 
          (vla-put-color pl acGreen) 
          (vla-put-ConstantWidth pl 0.1) 
        ) 
      ) 
    ) 
    nil 
  ) 
  (vla-endundomark doc) 
  (princ) 
)

kwok · 发表于 2013-4-25 15:53:08

分享，就是要支持，说声谢谢!

Free-Lancer · 发表于 2013-4-25 16:48:23

3 两条线分别等分并连线加标注
[pcode=lisp,true](defun c:tt (/ e1 e2 n pts1 pts2 p1 p2 p divdby getstart adim tf tf1 p0 an d)
 (defun divdby (e n / l d pts $d)
(setq l (vlax-curve-getdistatparam e (vlax-curve-getendparam e))
 $d (/ l n)
 d (- $d)
)
(repeat (1+ n)
 (setq pts (cons (vlax-curve-getpointatdist e (setq d (+ $d d)))
 pts
)
 )
)
(reverse pts)
 )
 (defun getstart (p e)
(if (< (distance p (vlax-curve-getstartpoint e))
 (distance p (vlax-curve-getendpoint e))
)
 t
 nil
)
 )
 (defun adim (pts p)
(mapcar '(lambda (x y)
 (vla-AddDimAligned
 ms
 (vlax-3d-point x)
 (vlax-3d-point y)
 (vlax-3d-point p)
 )
 )
 pts
 (cdr pts)
)
 )
 (while (and (setq e1 (entsel "\nPick First Line: "))
 (setq e2 (entsel "\nPick Second Line: "))
 (setq n (getint "\nDivide: "))
 (setq p (getpoint (cadr e2) "\nDimension Location: "))
 )
(setq p1 (cadr e1)
 p2 (cadr e2)
 e1 (car e1)
 e2 (car e2)
 tf (getstart p1 e1)
 tf1 (getstart p2 e2)
 pts1 (divdby e1 n)
 pts2 (divdby e2 n)
 ms (vla-get-modelspace
 (vla-get-activedocument (vlax-get-acad-object))
 )
 p0 (vlax-curve-getclosestpointto e2 p)
 an (angle p0 p)
)
(if (not tf)
 (setq pts1 (reverse pts1))
)
(if (not tf1)
 (setq pts2 (reverse pts2))
)
(mapcar '(lambda (x y)
 (vla-put-color (vla-addline ms (vlax-3d-point x) (vlax-3d-point y)) acred)
 )
 pts1
 pts2
)
(adim pts1 (polar p1 (+ an pi) (distance p p0)) )
(adim pts2 p)
 )
 (princ)
)
[/pcode]

仲文玉 · 发表于 2013-4-25 18:14:52

:)支持楼主下

adolfken · 发表于 2013-4-25 18:21:59

谢谢楼主的分享,跟楼主学习了

cable2004 · 发表于 2013-4-26 09:37:09

回复看帖！！！

gufengyin · 发表于 2013-4-26 11:37:25

等待继续添加！

Free-Lancer · 发表于 2013-4-26 11:46:20

4 多重打断
[pcode=lisp,true](defun c:Mbrk (/ thisdrawing)
 (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark thisdrawing)
 (vl-catch-all-apply
(function
 (lambda (/ ss p1 p2 ssl e)
(while
 (and
 (progn
 (prompt "\n请选取要截断的实体<退出>:")
 (setq ss (ssget '((0 . "*line,arc,circle,ellipse"))))
 )
 (setq p1 (getpoint "\n起始点<退出>:"))
 (setq p2 (getpoint "\n结束点<退出>:"))
 )
 (if ss
 (progn
 (setq ssl (sslength ss))
 (while (> ssl 0)
 (setq e (ssname ss (setq ssl (1- ssl))))
 (vl-cmdf ".break"
 (list e p1)
 "F"
 p1
 p2
 )
 )
 )
 )
)
 )
)
 )
 (vla-endundomark thisdrawing)
 (princ)
)[/pcode]

zyhandw · 发表于 2013-4-26 14:10:52

感谢楼主的分享，下载下来试试

richine001 · 发表于 2013-4-26 19:09:30

感谢楼主，太感谢了，

cuyongping · 发表于 2013-4-27 09:09:04

支持楼主下

Free-Lancer · 发表于 2013-5-2 09:05:22

7 找Pline内部一个点
利用了一个辅助线，辅助线和Pline的两个交点之中点肯定在Pline内部[pcode=lisp,true](defun pt-inm (obj ms / bp ep ln)
  (vla-getboundingbox obj 'bp 'ep)
  (setq ln (vla-addline
      ms
      (vlax-make-variant bp)
      (vlax-make-variant ep)
   )
  )
  (vl-catch-all-apply
'(lambda (/ pts ptl)
   (setq pts (vlax-invoke obj 'intersectwith ln acextendnone))
   (while pts
   (setq ptl (cons (list (car pts) (cadr pts) (caddr pts)) ptl)
         pts (cdddr pts)
   )
   )
   (if (equal (vlax-curve-getclosestpointto obj (car ptl))
   (car ptl)
   1e-8
   )
   (setq p (mapcar '(lambda (x y) (* (+ x y) 0.5))
   (car ptl)
   (cadr ptl)
   )
   )
   (setq p (mapcar '(lambda (x y) (* (+ x y) 0.5))
   (cadr ptl)
   (caddr ptl)
   )
   )
   )
   )
  )
  (vla-delete ln)
  p
)
(defun c:tt (/ e ms p)
  (setq ms (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
e (car (entsel))
)
  (setq p (pt-inm (vlax-ename->vla-object e) ms))
  (vla-addpoint ms (vlax-3d-point p))
  (princ)
)[/pcode]

帐号		自动登录	找回密码
密码			立即注册

[他山之石] 一些随手写的小工具（慢慢更新）

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

本帖被以下淘专辑推荐:

相关帖子