四边形多段线 批量标注求助~及多边形衍生

tianshilei98

不知道有没有四边形 批量标注的四条边及对角线的lisp，有的话请发个原帖链接，
没有的话请各位在线高手帮忙编个，实现批量标注多段线四边形的尺寸，并归类到不同层---见附图。
在下这样做是为了好统计尺寸到excel表格里，因为数量巨大 所以上来求教，有更好的思路或者程序的还请不吝赐教。
在此先谢谢各位了！！！！！

tianshilei98

附图

香田里浪人

便长批量标注论坛里已经有了。

仲文玉

看看z版的帖子吧：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=99400

如果发演示违规的话，烦请版主删除图片，或留言给我，我自己删除，这个程序看看z版的程序，自己再琢磨琢磨，应该不难吧
思路：框选四边形---循环---提取四边形组码10的角点---备份图层设置图层L1---标注上侧标注---设置图层L2--。。。。。。。，标注完毕，恢复系统变量

tianshilei98

仲文玉 发表于 2013-4-13 18:55
看看z版的帖子吧：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=99400

如果发演示违规的话，烦请版 ...

我看过这个帖子，没有你演示的的效果，你有没有这个lisp，有的话发我邮箱:692997475@qq.com。谢谢了！！

vlisp2012

如果你画多边形时很有规律的话，可以直接用我的附件把多边形的边长和对角线都导出来，用excel打开txt文件。选择断位功能，就可以了。
如果画多边形时没有规律，我说的是起始点都是左下角或右下角，或是其他固定的。用http://bbs.mjtd.com/thread-93555-2-1.html  。13楼的程序，预处理一下。就可以批量的完成多边形编号和尺寸导出了。
运行命令XU

vlisp2012

我不会用动画来演示。
这个比标注出来再导出的方法，快多了。

vlisp2012

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

(defun c:xu ()
  (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)
)

tianshilei98

没有其他了吗？

tianshilei98

仲文玉 发表于 2013-4-13 18:55
看看z版的帖子吧：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=99400

如果发演示违规的话，烦请版 ...

可以发份给我不，692997475@qq.com