设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 求助批量标注矩形
返回列表 发新帖
查看: 2375|回复: 8

[提问] 求助批量标注矩形

[复制链接]
ynhh
发表于 2022-12-21 22:32:52 | 显示全部楼层 |阅读模式
求助批量标注矩形

论坛中的感觉有的太复杂

如有现成的最好
如没有的话我学着用这个也是论坛中找的来改改
谢谢






  2. ;;;这个程序不是我编辑的，是我单位的同事编的。
  3. ;;;也是他早期的作品吧，不是很成熟。后来都写入扩展数据里了，对下面材，如玻璃，铝板等有很大的帮助。

  5. (defun c:AA ()
  6.   (setq        xtblm '("cmdecho" "osmode")
  7.         xtblz (mapcar 'getvar xtblm)
  8.   )
  9.   (mapcar 'setvar xtblm '(0 0))
  10.   (command "ucs" "w")
  11.   (setq lay (tblsearch "layer" "多边形编号"))
  12.   (if (= lay nil)
  13.     (command "layer" "n" "多边形编号" "c" "4" "多边形编号" "")
  14.   )
  15.   (princ "\n 选择多边形：")
  16.   (setq no (getint "起始编号<01>："))
  17.   (if (null no)
  18.     (setq no 1)
  19.   )
  20.   (setq ssg (ssget '((0 . "LWPOLYLINE"))))
  21. ;;;保存到表
  22.   (setq ffn (getfiled "选取尺寸" "" "txt" 1))
  23.   (setq ff (open ffn "w"))
  24.   (close ff)

  26.   (setq i 0)
  27.   (repeat (setq en (sslength ssg))
  28.     (progn (setq ssn (ssname ssg i))
  29.            (setq ent (entget ssn))
  30.            (command "copy" ssn "" '(0 0 0) '(0 0 0) )
  31.            (setq aa (entlast))
  32.            (setq lay (tblsearch "layer" "jun"))
  33.            (if (= lay nil)
  34.              (command "layer" "n" "jun" "c" "4" "jun" "")
  35.            )
  36.            (command "chprop" aa "" "la" "jun" "")
  37.            (vl-cmdf "EXPLODE" aa "")
  38.            (setq en (ssget "X" (list (cons 8 "jun"))))
  39.            (setq bb (sslength en))
  40.            (command "erase" en "")



  44.            (command "copy" ssn "" '(0 0 0) '(0 0 0) )
  45.            (setq ent0 (entlast))
  46.            (command "EXPLODE" ent0 "")



  50.            (if (= bb 3)
  51.              (progn
  52.                (setq g1 (entnext ent0))
  53.                (setq g2 (entnext g1))
  54.                (setq g3 (entnext g2))


  57.                (setq pt1 (cdr (assoc 10 (entget g1))))
  58.                (setq pt2 (cdr (assoc 11 (entget g1))))
  59.                (setq pt3 (cdr (assoc 11 (entget g2))))
  60.                (setq xxx pt1)
  61.                (setq yyy (zd pt2 pt3))
  62.                (setq zzz (zd xxx yyy))


  65.                (setq l1        (distance pt1 pt2)
  66.                      l2        (distance pt2 pt3)
  67.                      l3        (distance pt3 pt1)
  68.                )
  69.                (setq xian_biao (list l1 l2 l3))
  70.                (command "erase" g1 g2 g3 "")
  71.              )
  72.            )




  77.            (if (= bb 4)
  78.              (progn
  79.                (setq g1 (entnext ent0))
  80.                (setq g2 (entnext g1))
  81.                (setq g3 (entnext g2))
  82.                (setq g4 (entnext g3))

  84.                (setq pt1 (cdr (assoc 10 (entget g1))))
  85.                (setq pt2 (cdr (assoc 11 (entget g1))))
  86.                (setq pt3 (cdr (assoc 10 (entget g3))))
  87.                (setq pt4 (cdr (assoc 11 (entget g3))))
  88.                (setq xxx (zd pt1 pt3))
  89.                (setq yyy (zd pt2 pt4))
  90.                (setq zzz (zd xxx yyy))

  92.                (setq l1        (distance pt1 pt2)
  93.                      l2        (distance pt2 pt3)
  94.                      l3        (distance pt3 pt4)
  95.                      l4        (distance pt4 pt1)
  96.                      l5        (distance pt1 pt3)
  97.                      l6        (distance pt2 pt4)
  98.                )
  99.                (setq xian_biao (list l1 l2 l3 l4 l5 l6))
  100.                (command "erase" g1 g2 g3 g4 "")
  101.              )
  102.            )




  107.            (if (= bb 5)
  108.              (progn
  109.                (setq g1 (entnext ent0))
  110.                (setq g2 (entnext g1))
  111.                (setq g3 (entnext g2))
  112.                (setq g4 (entnext g3))
  113.                (setq g5 (entnext g4))

  115.                (setq pt1 (cdr (assoc 10 (entget g1))))
  116.                (setq pt2 (cdr (assoc 11 (entget g1))))
  117.                (setq pt3 (cdr (assoc 10 (entget g3))))
  118.                (setq pt4 (cdr (assoc 11 (entget g3))))
  119.                (setq pt5 (cdr (assoc 11 (entget g4))))
  120.                (setq xxx pt1)
  121.                (setq yyy (zd pt3 pt4))
  122.                (setq zzz (zd xxx yyy))

  124.                (setq l1        (distance pt1 pt2)
  125.                      l2        (distance pt2 pt3)
  126.                      l3        (distance pt3 pt4)
  127.                      l4        (distance pt4 pt5)
  128.                      l5        (distance pt5 pt1)
  129.                      l6        (distance pt1 pt3)
  130.                      l7        (distance pt1 pt4)
  131.                )
  132.                (setq xian_biao (list l1 l2 l3 l4 l5 l6 l7))
  133.                (command "erase" g1 g2 g3 g4 g5 "")
  134.              )
  135.            )

  137.                                         ;编号
  138.            (command "ucs" "e" ssn )
  139.            (command "ucs" "z" "")
  140.            (setq ptm (trans zzz 0 1))
  141.            (command "text"
  142.                     "j"
  143.                     "m"
  144.                     ptm
  145.                     100
  146.                     0.0
  147.                     (strcat "BH-" (itoa no))
  148.            )

  150.            (setq bianh (entlast))
  151.            (command "chprop" bianh "" "la" "多边形编号" "")
  152.            (setq las (entget bianh))
  153.            (setq entype (cdr (assoc 1 las)))
  154.            (setq no (1+ no))

  156.                                         ;写入数据
  157.            (if las
  158.              (progn

  160.                (setq new_ext_list
  161.                       (list -3
  162.                             (list entype
  163.                                   xian_biao
  164.                             )
  165.                       )
  166.                )
  167.                (if (setq old_ext_list (assoc -3 las))

  169.                  (setq las (subst new_ext_list old_ext_list las))
  170.                  (setq las (append las (list new_ext_list)))

  172.                )
  173.              )
  174.            )

  176.            (setq ext_list (cadr (assoc -3 las)))


  179.            (setq ff (open ffn "a"))
  180.            (princ ext_list ff)
  181.            (princ "\n" ff)
  182.            (close ff)

  184.     )





  190.     (setq i (1+ i))

  192.   )
  193.   (command "ucs" "")
  194.   (mapcar 'setvar xtblm xtblz)
  195.   (princ)
  196. )


  199. (defun zd (p1 p2)
  200.   (setq mx (/ (+ (car p1) (car p2)) 2))
  201.   (setq my (/ (+ (cadr p1) (cadr p2)) 2))
  202.   (setq mz (/ (+ (caddr p1) (caddr p2)) 2))
  203.   (list mx my mz)
  204. )





本帖子中包含更多资源

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

x
"觉得好，就打赏"
打赏
还没有人打赏，支持一下
回复

使用道具 举报

注册
发表于 2022-12-22 10:07:08 | 显示全部楼层
;;;  一键标注
;(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" pt0  pt1 "")
  (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)
  (entdel  e1) (entdel  e2)
)
;( 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)
)

点评

kucha007
赞一个  发表于 2022-12-22 15:15
回复 支持 2 反对 1

使用道具 举报

xiangganglv
发表于 2022-12-22 09:05:13 | 显示全部楼层
还可以延展到块的长宽。
回复 支持 反对

使用道具 举报

longer1000
发表于 2022-12-22 10:47:03 | 显示全部楼层
注册 发表于 2022-12-22 10:07
;;;  一键标注
;(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun _StartUndo (doc ...

NB
回复 支持 反对

使用道具 举报

ynhh
 楼主| 发表于 2022-12-22 17:02:31 | 显示全部楼层
注册 发表于 2022-12-22 10:07
;;;  一键标注
;(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun _StartUndo (doc ...

大师的程序果然很牛叉
值得慢慢学习
不知如只针对矩形
仅标注 左侧 和上部时 ，能不能再修改一下
谢谢您了
回复 支持 反对

使用道具 举报

骑着蜗牛旅行666
发表于 2022-12-23 17:55:49 | 显示全部楼层
注册 发表于 2022-12-22 10:07
;;;  一键标注
;(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun _StartUndo (doc ...

用的别个的程序，也不说明下
回复 支持 反对

使用道具 举报

注册
发表于 2022-12-23 19:38:08 | 显示全部楼层
骑着蜗牛旅行666 发表于 2022-12-23 17:55
用的别个的程序，也不说明下

我也没说是自己原创哇
回复 支持 反对

使用道具 举报

sky-x-x
发表于 2023-6-18 21:15:07 | 显示全部楼层
源码提示：输入的字符串有缺陷，求解？？
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-11-16 20:43 , Processed in 0.180285 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表