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

Free-Lancer · 发表于 2013-5-26 19:42:58

47 导出 Pline 信息
不知道和前面是否有重复

(defun c:ptoxls (/ ss fl ename n i pts tpy epam v p)
(if (setq ss (ssget '((0 . "*polyline"))))
(progn
(setq fl (open "f:\dddd.txt" "a"))
(setq ssl (sslength ss))
(while (> ssl 0)
(setq ename (ssname ss (setq ssl (1- ssl))))
(setq typ (cdr (assoc 0 (entget ename))))
(setq n (1+ (/ (fix (setq epam (vlax-curve-getendparam ename))) 2))
i 0
)
(repeat n
(setq p (vlax-curve-getpointatparam ename i))
(if (wcmatch typ "LWPOLYLINE")
(progn
(setq v (cdr (assoc 39 el)))
(setq pts (cons (list (car p) (cadr p) v) pts))
)
(setq pts (cons p pts)
i (+ 2 i)
)
)
(if (> i epam)
(setq i epam)
)
)
)
(foreach x pts
(if (and (< (last x) 900)
(> (last x) 100)
)
(write-line
(strcat (rtos (car x) 2 3)
","
(rtos (cadr x) 2 3)
","
(rtos (last x) 2 3)
)
fl
)
)
)
(close fl)
)
)
(princ)
)

(defun c:ptoxls (/ ss fl ename n i pts tpy epam v p) 
  (if (setq ss (ssget '((0 . "*polyline")))) 
    (progn 
      (setq fl (open "f:\dddd.txt" "a")) 
      (setq ssl (sslength ss)) 
      (while (> ssl 0) 
 (setq ename (ssname ss (setq ssl (1- ssl)))) 
 (setq typ (cdr (assoc 0 (entget ename)))) 
 (setq n (1+ (/ (fix (setq epam (vlax-curve-getendparam ename))) 2)) 
       i 0 
 ) 
 (repeat n 
   (setq p (vlax-curve-getpointatparam ename i)) 
   (if (wcmatch typ "LWPOLYLINE") 
     (progn 
       (setq v (cdr (assoc 39 el))) 
       (setq pts (cons (list (car p) (cadr p) v) pts)) 
     ) 
     (setq pts (cons p pts) 
    i   (+ 2 i) 
     ) 
   ) 
   (if (> i epam) 
     (setq i epam) 
   ) 
 ) 
      ) 
      (foreach x pts 
 (if (and (< (last x) 900) 
   (> (last x) 100) 
     ) 
   (write-line 
     (strcat (rtos (car x) 2 3) 
      "," 
      (rtos (cadr x) 2 3) 
      "," 
      (rtos (last x) 2 3) 
     ) 
     fl 
   ) 
 ) 
      ) 
      (close fl) 
    ) 
  ) 
  (princ) 
)

Free-Lancer · 发表于 2013-5-26 19:46:14

48 一个重新插入属性块并修改属性（没有用修改属性的方法）

(defun c:rfl (/ ss sl i e el p xscl yscl an bn fl)
(setq fl (getstring "\nInput Floor: "))
(if (setq ss (ssget '((0 . "insert"))))
(progn
(setq sl (sslength ss)
i -1
)
(repeat sl
(setq e (ssname ss (setq i (1+ i)))
el (entget e)
p (cdr (assoc 10 el))
xscl (cdr (assoc 41 el))
yscl (cdr (assoc 42 el))
an (cdr (assoc 50 el))
bn (cdr (assoc 2 el))
)
(vl-cmdf ".insert" bn p xscl yscl an fl)
(entdel e)
)
)
)
(princ)
)
(princ "****** Start Command with RFL . ******")
(princ)

Free-Lancer · 发表于 2013-5-26 19:51:25

本帖最后由 Free-Lancer 于 2013-10-20 13:18 编辑

49 对Pline增加一个带字段的引线标注面积、周长

(defun C:FA (/ acsp adoc cpt elist en ent fld lead_obj lpt mtx oid osm)
(vl-load-com)
(or adoc
(setq adoc
(vla-get-activedocument
(vlax-get-acad-object)
)
)
)
(if (and
(= (getvar "tilemode") 0)
(= (getvar "cvport") 1)
)
(setq acsp (vla-get-paperspace adoc))
(setq acsp (vla-get-modelspace adoc))
)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(while
(setq ent (entsel "\nSelect pline or hit Enter to exit"))
(setq en (car ent))
(if (wcmatch (cdr (assoc 0 (setq elist (entget en)))) "*POLYLINE")
(progn
(setq cpt (trans (cadr ent)1 0)
lpt (trans (getpoint cpt "\nPick the ending point of leader:") 1 0)
)
(setq oID (vla-get-objectid (vlax-ename->vla-object en)))
(setq fld
(strcat
(strcat "Area = " "%<\\AcObjProp Object(%<\\_ObjId "
(itoa oID)
">%).Area \\f "%lu2%pr2">%"
"\\P")
(strcat "Perimeter = " "%<\\AcObjProp Object(%<\\_ObjId "
(itoa oID)
">%).Length \\f "%lu2%pr2">%"))
)
(setq mtx (vlax-invoke
acsp 'AddMText lpt 0.0 fld)
)
(vlax-put mtx
'AttachmentPoint
(cond ((> (car cpt) (car lpt))
6
)
((< (car cpt) (car lpt))
4
)
(T 4)
)
)
(vlax-put mtx 'Height (getvar "textsize"))
(setq lead_obj (vlax-invoke
acsp
'Addleader
(apply 'append (list cpt lpt))
mtx
acLineWithArrow
)
)
(vlax-put lead_obj 'VerticalTextPosition 0);1
)
)
)
(setvar "osmode" osm)
(princ)
)
(princ "\n Start command with FA ...")
(princ)

(defun C:FA  (/ acsp adoc cpt elist en ent fld lead_obj lpt mtx oid osm) 
  (vl-load-com) 
  (or adoc 
      (setq adoc 
      (vla-get-activedocument 
        (vlax-get-acad-object) 
        ) 
     ) 
      ) 
  (if (and 
 (= (getvar "tilemode") 0) 
 (= (getvar "cvport") 1) 
 ) 
    (setq acsp (vla-get-paperspace adoc)) 
    (setq acsp (vla-get-modelspace adoc)) 
    ) 
 (setq osm (getvar "osmode")) 
  (setvar "osmode" 0) 
  (while 
    (setq ent (entsel "\nSelect pline or hit Enter to exit")) 
     (setq en (car ent)) 
     (if (wcmatch (cdr (assoc 0 (setq elist (entget en)))) "*POLYLINE") 
       (progn 
  (setq cpt (trans (cadr ent)1 0) 
        lpt (trans (getpoint cpt "\nPick the ending point of leader:") 1 0) 
        ) 
  (setq oID (vla-get-objectid (vlax-ename->vla-object en))) 
  (setq fld 
  (strcat 
    (strcat "Area = " "%<\\AcObjProp Object(%<\\_ObjId " 
     (itoa oID) 
     ">%).Area \\f "%lu2%pr2">%" 
     "\\P") 
    (strcat "Perimeter = " "%<\\AcObjProp Object(%<\\_ObjId " 
     (itoa oID) 
     ">%).Length \\f "%lu2%pr2">%")) 
        ) 
  (setq mtx (vlax-invoke 
       acsp 'AddMText lpt 0.0 fld) 
        ) 
  (vlax-put mtx 
     'AttachmentPoint 
     (cond ((> (car cpt) (car lpt)) 
     6 
     ) 
    ((< (car cpt) (car lpt)) 
     4 
     ) 
    (T 4) 
    ) 
     ) 
  (vlax-put mtx 'Height (getvar "textsize")) 
  (setq lead_obj (vlax-invoke 
     acsp 
     'Addleader 
     (apply 'append (list cpt lpt)) 
     mtx 
     acLineWithArrow 
     ) 
        ) 
  (vlax-put lead_obj 'VerticalTextPosition 0);1 
  ) 
       ) 
     ) 
  (setvar "osmode" osm) 
  (princ) 
  ) 
(princ "\n Start command with FA ...") 
(princ)

Free-Lancer · 发表于 2013-5-26 19:53:37

给大家一个编程建议，如果需要什么样的结果，自己先用CAD命令画出来，然后把这个结果用Lisp写出来（比如Leader+字段）

拉契 · 发表于 2013-5-31 16:04:13

楼主太给力了，无私奉献这么多！{:soso_e183:}

kwok · 发表于 2013-6-6 10:06:28

Free-Lancer 发表于 2013-5-26 19:53
给大家一个编程建议，如果需要什么样的结果，自己先用CAD命令画出来，然后把这个结果用Lisp写出来（比如Lea ...

如果有个工具，把画的过程记下并转化成lisp就强大了，...呵呵

Free-Lancer · 发表于 2013-6-6 10:22:28

kwok 发表于 2013-6-6 10:06
如果有个工具，把画的过程记下并转化成lisp就强大了，...呵呵

这个功能早就有了,呵呵

renox · 发表于 2013-6-7 09:32:57

一直没有见过这个功能。

renox · 发表于 2013-6-7 09:33:33

要是能共享出来那真是太好了。

429014673 · 发表于 2013-6-7 22:02:56

楼主发了那么多程序，竟然没几个我用得上的，可能是有了

Free-Lancer · 发表于 2013-6-7 22:57:25

429014673 发表于 2013-6-7 22:02
楼主发了那么多程序，竟然没几个我用得上的，可能是有了

把你有的也发上来和大家共享啊

tianyi1230 · 发表于 2013-6-9 22:21:51

好东西，很多很实用啊，

pengfei2010 · 发表于 2013-6-11 11:09:31

哇这么多啊，楼主真厉害值得学习

cable2004 · 发表于 2013-6-13 12:04:47

非常实用的工具，谢谢版主!

xiaoyuzj503 · 发表于 2013-6-13 21:11:52

好东西就应该顶。谢谢分享

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

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

评分

点评

点评

点评