求助批量标注矩形
求助批量标注矩形论坛中的感觉有的太复杂
如有现成的最好
如没有的话我学着用这个也是论坛中找的来改改
谢谢
;;;这个程序不是我编辑的，是我单位的同事编的。
;;;也是他早期的作品吧，不是很成熟。后来都写入扩展数据里了，对下面材，如玻璃，铝板等有很大的帮助。
(defun c:AA ()
(setq xtblm '("cmdecho" "osmode")
xtblz (mapcar 'getvar xtblm)
)
(mapcar 'setvar xtblm '(0 0))
(command "ucs" "w")
(setq lay (tblsearch "layer" "多边形编号"))
(if (= lay nil)
(command "layer" "n" "多边形编号" "c" "4" "多边形编号" "")
)
(princ "\n 选择多边形：")
(setq no (getint "起始编号<01>："))
(if (null no)
(setq no 1)
)
(setq ssg (ssget '((0 . "LWPOLYLINE"))))
;;;保存到表
(setq ffn (getfiled "选取尺寸" "" "txt" 1))
(setq ff (open ffn "w"))
(close ff)
(setq i 0)
(repeat (setq en (sslength ssg))
(progn (setq ssn (ssname ssg i))
(setq ent (entget ssn))
(command "copy" ssn "" '(0 0 0) '(0 0 0) )
(setq aa (entlast))
(setq lay (tblsearch "layer" "jun"))
(if (= lay nil)
(command "layer" "n" "jun" "c" "4" "jun" "")
)
(command "chprop" aa "" "la" "jun" "")
(vl-cmdf "EXPLODE" aa "")
(setq en (ssget "X" (list (cons 8 "jun"))))
(setq bb (sslength en))
(command "erase" en "")
(command "copy" ssn "" '(0 0 0) '(0 0 0) )
(setq ent0 (entlast))
(command "EXPLODE" ent0 "")
(if (= bb 3)
(progn
(setq g1 (entnext ent0))
(setq g2 (entnext g1))
(setq g3 (entnext g2))
(setq pt1 (cdr (assoc 10 (entget g1))))
(setq pt2 (cdr (assoc 11 (entget g1))))
(setq pt3 (cdr (assoc 11 (entget g2))))
(setq xxx pt1)
(setq yyy (zd pt2 pt3))
(setq zzz (zd xxx yyy))
(setq l1 (distance pt1 pt2)
l2 (distance pt2 pt3)
l3 (distance pt3 pt1)
)
(setq xian_biao (list l1 l2 l3))
(command "erase" g1 g2 g3 "")
)
)
(if (= bb 4)
(progn
(setq g1 (entnext ent0))
(setq g2 (entnext g1))
(setq g3 (entnext g2))
(setq g4 (entnext g3))
(setq pt1 (cdr (assoc 10 (entget g1))))
(setq pt2 (cdr (assoc 11 (entget g1))))
(setq pt3 (cdr (assoc 10 (entget g3))))
(setq pt4 (cdr (assoc 11 (entget g3))))
(setq xxx (zd pt1 pt3))
(setq yyy (zd pt2 pt4))
(setq zzz (zd xxx yyy))
(setq l1 (distance pt1 pt2)
l2 (distance pt2 pt3)
l3 (distance pt3 pt4)
l4 (distance pt4 pt1)
l5 (distance pt1 pt3)
l6 (distance pt2 pt4)
)
(setq xian_biao (list l1 l2 l3 l4 l5 l6))
(command "erase" g1 g2 g3 g4 "")
)
)
(if (= bb 5)
(progn
(setq g1 (entnext ent0))
(setq g2 (entnext g1))
(setq g3 (entnext g2))
(setq g4 (entnext g3))
(setq g5 (entnext g4))
(setq pt1 (cdr (assoc 10 (entget g1))))
(setq pt2 (cdr (assoc 11 (entget g1))))
(setq pt3 (cdr (assoc 10 (entget g3))))
(setq pt4 (cdr (assoc 11 (entget g3))))
(setq pt5 (cdr (assoc 11 (entget g4))))
(setq xxx pt1)
(setq yyy (zd pt3 pt4))
(setq zzz (zd xxx yyy))
(setq l1 (distance pt1 pt2)
l2 (distance pt2 pt3)
l3 (distance pt3 pt4)
l4 (distance pt4 pt5)
l5 (distance pt5 pt1)
l6 (distance pt1 pt3)
l7 (distance pt1 pt4)
)
(setq xian_biao (list l1 l2 l3 l4 l5 l6 l7))
(command "erase" g1 g2 g3 g4 g5 "")
)
)
;编号
(command "ucs" "e" ssn )
(command "ucs" "z" "")
(setq ptm (trans zzz 0 1))
(command "text"
"j"
"m"
ptm
100
0.0
(strcat "BH-" (itoa no))
)
(setq bianh (entlast))
(command "chprop" bianh "" "la" "多边形编号" "")
(setq las (entget bianh))
(setq entype (cdr (assoc 1 las)))
(setq no (1+ no))
;写入数据
(if las
(progn
(setq new_ext_list
(list -3
(list entype
xian_biao
)
)
)
(if (setq old_ext_list (assoc -3 las))
(setq las (subst new_ext_list old_ext_list las))
(setq las (append las (list new_ext_list)))
)
)
)
(setq ext_list (cadr (assoc -3 las)))
(setq ff (open ffn "a"))
(princ ext_list ff)
(princ "\n" ff)
(close ff)
)
(setq i (1+ i))
)
(command "ucs" "")
(mapcar 'setvar xtblm xtblz)
(princ)
)
(defun zd (p1 p2)
(setq mx (/ (+ (car p1) (car p2)) 2))
(setq my (/ (+ (cadr p1) (cadr p2)) 2))
(setq mz (/ (+ (caddr p1) (caddr p2)) 2))
(list mx my mz)
)
;;;一键标注
;(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun _StartUndo (doc)(_EndUndo doc)(vla-StartUndoMark doc))
(defun _EndUndo (doc)(if (= 8 (logand 8 (getvar 'UNDOCTL)))(vla-EndUndoMark doc)))
(defun 3d->2d (pt) (list (car pt) (cadr pt)))
(defun d->r (ag) (/ (* pi ag) 180))
(defun r->d (ag) (/ (* pi 180) ag))
(defun dimli (pt1 pt2 pt3) (command "DIMLINEAR" pt1 pt2 pt3))
(defun Idimaligned (pt1 pt2 pt3) (command "dimaligned" pt1 pt2 pt3))
(defun vlex-extents (plist /)
(list (apply 'mapcar (cons 'min plist))
(apply 'mapcar (cons 'max plist))
)
)
(defun massoc (code xlist / x nlist)
(setq nlist nil)
(foreach x xlist
(if (eq code (car x))
(setq nlist (cons (cdr x) nlist))
)
)
(reverse nlist)
)
(defun S2L:ENT (ss / i l objs)
(setq i -1 l (sslength ss) objs nil)
(repeat l
(setq objs (cons(ssname ss (setq i (1+ i))) objs))
)
)
(defun vlex-mid (pts / p0 p1)
(setq p0 (nth 0 pts)
p1 (nth 1 pts)
)
(mapcar
'(lambda (ord1 ord2)
(/ (+ ord1 ord2) 2.0)
)
p0
p1
)
)
;由图元名生成与组码相关的点位图元表(ent code)
(defun xz-entcode (ent code)
(if (setq pt (dxf code ent))
(cons ent (cons pt l-st))
)
)
;线性标注--子程序
;(Idimaligned (getpoint)(getpoint)(getpoint) 100)
(defun Idimaligned (pt1 pt2 ptc dis / pt3 pt4)
(setq pt3 (vlex-mid (list pt2 pt1)))
(setq pt4 (polar ptc (angle ptc pt3) (+(distance pt3 ptc)dis)))
(command "dimaligned" pt1 pt2 pt4)
)
;角度标注--子程序
;(Idimaligned-a (getpoint)(getpoint)(getpoint)(getpoint) 200)
(defun Idimaligned-a (pt0 pt1 pt2 ptc dis / e1 e1pt e2 e2pt pt3 pt4)
(command "line" pt0pt1 "")
(setq e1 (entlast))
(setq e1pt (xz-entcode e1 10))
(command "line" pt2 pt1"")
(setq e2 (entlast))
(setq e2pt (xz-entcode e2 10))
(setq pt4 (polar ptc (angle ptc pt1) (-(distance pt1 ptc) dis)))
(command "dimangular" e1pt e2pt pt4)
(entdele1) (entdele2)
)
;( setq ent_pl (car (entsel)))
;(dim_ent_pl (car (entsel)))
;标注多段线边长--子程序
(defun dim_ent_pl (ent_pl / dxf_10 dxf_c n pt_0 pt_2 scle)
(setq dxf_10 (massoc 10 (entget ent_pl)))
(setq scle (* 10 (getvar "dimscale")))
(setq dxf_c (vlex-mid (vlex-extents dxf_10)))
(setq n 0)
(repeat (1-(length dxf_10))
(setq pt_0 (nth n dxf_10)
pt_1 (nth (setq n (1+ n)) dxf_10)
)
(Idimaligned pt_0 pt_1 dxf_c scle)
)
(Idimaligned pt_1 (nth 0 dxf_10) dxf_c scle)
)
;(dim_ent_pl_d (car (entsel)))
;标注多段线边长--主程序
(defun c:yjbz (/ OSM ss_pl ent_pl_ls acdoc)
(PRINC "\n【阳羡刚刚好CAD外挂<一键标注功能YJBZ>】---一键标注多边形每条边长")(PRINC)
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq OSM (Getvar "OSMODE" ))
;选择多段线
(princ "\n多边形边长标注程序,选择多段线..." )
(setq ss_pl (ssget '((0 . "LWPOLYLINE"))))
(setq ent_pl_ls (S2L:ENT ss_pl))
(setvar "OSMODE" 0 )
(_StartUndo acdoc)
(if (tblsearch "layer" "DIM")
(if (/= (getvar "clayer") "DIM") (setvar "clayer" "DIM"))
(command "-layer" "m" "DIM" "")
)
(foreach n ent_pl_ls (dim_ent_pl n))
(_EndUndo acdoc)
(setvar "OSMODE" OSM)
(princ)
) 还可以延展到块的长宽。 注册 发表于 2022-12-22 10:07
;;;一键标注
;(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun _StartUndo (doc ...
NB 注册 发表于 2022-12-22 10:07
;;;一键标注
;(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun _StartUndo (doc ...
大师的程序果然很牛叉
值得慢慢学习
不知如只针对矩形
仅标注 左侧 和上部时 ，能不能再修改一下
谢谢您了 注册 发表于 2022-12-22 10:07
;;;一键标注
;(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun _StartUndo (doc ...
用的别个的程序，也不说明下 骑着蜗牛旅行666 发表于 2022-12-23 17:55
用的别个的程序，也不说明下
我也没说是自己原创哇:$ 源码提示：输入的字符串有缺陷，求解？？
页:
[1]