多段线自动标注所有边和所有内角的代码

marting · 发表于 2017-5-7 10:25:53

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

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

×

(defun c:dimpolygons (/ *error* mr_IsPointInside mid
adoc spc sel d i
lw enx pl lwn enxn
plni plno plnom plm clr
lastent ss en
)
(vl-load-com)
(defun *error* (m)
(vla-endundomark adoc)
(if m
(prompt m)
)
(princ)
)
(setq lastEnt (entlast))
(setq clr (getvar "CLAYER"))
(command "-layer" "Make" "0-Dims" "color" "3" "" "")
(defun mr_IsPointInside (pt ptlst / trianglst ptinsidetriangle-p trl)
(defun trianglst (ptlst / unique
LM:ListClockwise-p clockwise-p l
p1 p2 p3 trl
)
(defun unique (l)
(if l
(cons (car l)
(unique (vl-remove-if
(function (lambda (x) (equal x (car l) 1e-6)))
l
)
)
)
)
)
;; List Clockwise-p - Lee Mac
;; Returns T if the point list is clockwise oriented
(defun LM:ListClockwise-p (lst)
(minusp
(apply '+
(mapcar
(function
(lambda (a b)
(- (* (car b) (cadr a)) (* (car a) (cadr b)))
)
)
lst
(cons (last lst) lst)
)
)
)
)
(defun clockwise-p (p1 p2 p3)
(< (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
)
(setq l ptlst)
(while (> (length ptlst) 3)
(setq p1 (car ptlst)
p2 (cadr ptlst)
p3 (caddr ptlst)
)
(cond
((LM:ListClockwise-p ptlst)
(if
(and
(clockwise-p p1 p2 p3)
(= (length
(unique
(vl-remove
nil
(mapcar
(function (lambda (a b) (inters p1 p2 a b)))
l
(cdr (reverse (cons (car l) (reverse l))))
)
)
)
)
2
)
(= (length
(unique
(vl-remove
nil
(mapcar
(function (lambda (a b) (inters p2 p3 a b)))
l
(cdr (reverse (cons (car l) (reverse l))))
)
)
)
)
2
)
(= (length
(unique
(vl-remove
nil
(mapcar
(function (lambda (a b) (inters p3 p1 a b)))
l
(cdr (reverse (cons (car l) (reverse l))))
)
)
)
)
2
)
)
(progn
(setq trl (cons (list p1 p2 p3) trl))
(setq ptlst (vl-remove p2 ptlst))
(setq ptlst
(cdr (reverse (cons (car ptlst) (reverse ptlst)))
)
)
)
(setq ptlst
(cdr (reverse (cons (car ptlst) (reverse ptlst))))
)
)
)
((not (LM:ListClockwise-p ptlst))
(if
(and
(not (clockwise-p p1 p2 p3))
(= (length
(unique
(vl-remove
nil
(mapcar
(function (lambda (a b) (inters p1 p2 a b)))
l
(cdr (reverse (cons (car l) (reverse l))))
)
)
)
)
2
)
(= (length
(unique
(vl-remove
nil
(mapcar
(function (lambda (a b) (inters p2 p3 a b)))
l
(cdr (reverse (cons (car l) (reverse l))))
)
)
)
)
2
)
(= (length
(unique
(vl-remove
nil
(mapcar
(function (lambda (a b) (inters p3 p1 a b)))
l
(cdr (reverse (cons (car l) (reverse l))))
)
)
)
)
2
)
)
(progn
(setq trl (cons (list p1 p2 p3) trl))
(setq ptlst (vl-remove p2 ptlst))
(setq ptlst
(cdr (reverse (cons (car ptlst) (reverse ptlst)))
)
)
)
(setq ptlst
(cdr (reverse (cons (car ptlst) (reverse ptlst))))
)
)
)
)
)
(setq
trl (cons (list (car ptlst) (cadr ptlst) (caddr ptlst)) trl)
)
trl
)
(defun ptinsidetriangle-p (pt p1 p2 p3)
(and
(not
(or
(inters pt p1 p2 p3)
(inters pt p2 p1 p3)
(inters pt p3 p1 p2)
)
)
(not
(or
(> (+ (distance pt p1) (distance pt p2))
(+ (distance p3 p1) (distance p3 p2))
)
(> (+ (distance pt p2) (distance pt p3))
(+ (distance p1 p2) (distance p1 p3))
)
(> (+ (distance pt p3) (distance pt p1))
(+ (distance p2 p3) (distance p2 p1))
)
)
)
)
)
(setq trl (trianglst ptlst))
(vl-some (function
(lambda (x)
(ptinsidetriangle-p pt (car x) (cadr x) (caddr x))
)
)
trl
)
)
(defun mid (p1 p2)
(mapcar (function (lambda (a b) (/ (+ a b) 2.0))) p1 p2)
)
(vla-startundomark
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
)
(setq spc (vla-get-block (vla-get-activelayout adoc)))
(if (not (tblsearch "DIMSTYLE" "MVVA Standard Imperial"))
(Alert "MVVA Standard Imperial dimension style not loaded")
(Command "-dimstyle" "r" "MVVA Standard Imperial")
)
(prompt "\nSelect closed POLYGONS...")
(setq sel (ssget (list '(0 . "LWPOLYLINE") '(-4 . "&=")
'(70 . 1) '(-4 . "<not")
'(-4 . "<>") '(42 . 0.0)
'(-4 . "not>")
)
)
)
(initget 7)
(setq d (getdist
"\nPick or specify offset distance for dimensioning : "
)
)
(if sel
(progn
(repeat (setq i (sslength sel))
(setq lw (ssname sel (setq i (1- i))))
(setq enx (entget lw))
(setq
pl (mapcar
(function
(lambda (x)
(trans (list (car x) (cadr x) (cdr (assoc 38 enx)))
lw
1
)
)
)
(mapcar (function cdr)
(vl-remove-if
(function (lambda (x) (/= (car x) 10)))
enx
)
)
)
)
(vla-offset (vlax-ename->vla-object lw) d)
(setq lwn (entlast))
(setq enxn (entget lwn))
(setq plni
(mapcar
(function
(lambda (x)
(trans (list (car x) (cadr x) (cdr (assoc 38 enxn)))
lwn
1
)
)
)
(mapcar (function cdr)
(vl-remove-if
(function (lambda (x) (/= (car x) 10)))
enxn
)
)
)
)
(if (not (mr_IsPointInside (car plni) pl))
(progn
(entdel lwn)
(vla-offset (vlax-ename->vla-object lw) (- d))
(setq lwn (entlast))
(setq enxn (entget lwn))
(setq plni
(mapcar
(function
(lambda (x)
(trans
(list (car x) (cadr x) (cdr (assoc 38 enxn)))
lwn
1
)
)
)
(mapcar (function cdr)
(vl-remove-if
(function (lambda (x) (/= (car x) 10)))
enxn
)
)
)
)
)
)
(entdel lwn)
(setq
plno (mapcar
(function
(lambda (a b)
(mapcar (function +) a (mapcar (function -) a b))
)
)
pl
plni
)
)
(setq plnom
(mapcar (function (lambda (a b) (mid a b)))
plno
(cdr (reverse (cons (car plno) (reverse plno))))
)
)
(mapcar (function (lambda (a b c)
(vla-addDimAligned
spc
(vlax-3d-point a)
(vlax-3d-point b)
(vlax-3d-point c)
)
)
)
pl
(cdr (reverse (cons (car pl) (reverse pl))))
plnom
)
(setq pl (reverse (cons (car pl) (reverse pl))))
(setq
plm (mapcar (function (lambda (a b) (mid a b))) pl (cdr pl))
)
(mapcar (function (lambda (a b c d)
(vla-AddDim3PointAngular
spc
(vlax-3d-point a)
(vlax-3d-point b)
(vlax-3d-point c)
(vlax-3d-point d)
)
)
)
(cdr pl)
plm
(cdr (reverse (cons (car plm) (reverse plm))))
(cdr (reverse (cons (car plni) (reverse plni))))
)
)
)
(prompt
"\nEmpty sel. set... Retry routine with valid sel. set..."
)
)
(setq ss (ssadd))
(if (setq en (entnext LastEnt)) ;Check if there's a new entity created since the last one
(while en ;Step through all new entities
(ssadd en ss) ;Add it to the selection set
(setq en (entnext en)) ;Get the next entity
)
)
(command "_.-dimstyle" "Apply" ss "")
(*error* nil)
(setvar "CLAYER" clr)
)

(defun c:dimpolygons (/         *error*   mr_IsPointInside    mid 
                      adoc      spc       sel       d         i 
                      lw        enx       pl        lwn       enxn 
                      plni      plno      plnom     plm       clr 
                      lastent  ss        en 
                     ) 
 
  (vl-load-com) 
 
  (defun *error* (m) 
    (vla-endundomark adoc) 
    (if m 
      (prompt m) 
    ) 
    (princ) 
  ) 
   
  (setq lastEnt (entlast)) 
   
  (setq clr (getvar "CLAYER")) 
  (command "-layer" "Make" "0-Dims" "color" "3" "" "") 
 
  (defun mr_IsPointInside (pt ptlst / trianglst ptinsidetriangle-p trl) 
 
    (defun trianglst (ptlst       /           unique 
                      LM:ListClockwise-p      clockwise-p l 
                      p1          p2          p3          trl 
                     ) 
 
      (defun unique (l) 
        (if l 
          (cons (car l) 
                (unique (vl-remove-if 
                          (function (lambda (x) (equal x (car l) 1e-6))) 
                          l 
                        ) 
                ) 
          ) 
        ) 
      ) 
 
      ;; List Clockwise-p - Lee Mac 
      ;; Returns T if the point list is clockwise oriented 
 
      (defun LM:ListClockwise-p (lst) 
        (minusp 
          (apply '+ 
                 (mapcar 
                   (function 
                     (lambda (a b) 
                       (- (* (car b) (cadr a)) (* (car a) (cadr b))) 
                     ) 
                   ) 
                   lst 
                   (cons (last lst) lst) 
                 ) 
          ) 
        ) 
      ) 
 
      (defun clockwise-p (p1 p2 p3) 
        (< (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1))) 
           (* (- (cadr p2) (cadr p1)) (- (car p3) (car p1))) 
        ) 
      ) 
 
      (setq l ptlst) 
      (while (> (length ptlst) 3) 
        (setq p1 (car ptlst) 
              p2 (cadr ptlst) 
              p3 (caddr ptlst) 
        ) 
        (cond 
          ((LM:ListClockwise-p ptlst) 
           (if 
             (and 
               (clockwise-p p1 p2 p3) 
               (= (length 
                    (unique 
                      (vl-remove 
                        nil 
                        (mapcar 
                          (function (lambda (a b) (inters p1 p2 a b))) 
                          l 
                          (cdr (reverse (cons (car l) (reverse l)))) 
                        ) 
                      ) 
                    ) 
                  ) 
                  2 
               ) 
               (= (length 
                    (unique 
                      (vl-remove 
                        nil 
                        (mapcar 
                          (function (lambda (a b) (inters p2 p3 a b))) 
                          l 
                          (cdr (reverse (cons (car l) (reverse l)))) 
                        ) 
                      ) 
                    ) 
                  ) 
                  2 
               ) 
               (= (length 
                    (unique 
                      (vl-remove 
                        nil 
                        (mapcar 
                          (function (lambda (a b) (inters p3 p1 a b))) 
                          l 
                          (cdr (reverse (cons (car l) (reverse l)))) 
                        ) 
                      ) 
                    ) 
                  ) 
                  2 
               ) 
             ) 
              (progn 
                (setq trl (cons (list p1 p2 p3) trl)) 
                (setq ptlst (vl-remove p2 ptlst)) 
                (setq ptlst 
                       (cdr (reverse (cons (car ptlst) (reverse ptlst))) 
                       ) 
                ) 
              ) 
              (setq ptlst 
                     (cdr (reverse (cons (car ptlst) (reverse ptlst)))) 
              ) 
           ) 
          ) 
          ((not (LM:ListClockwise-p ptlst)) 
           (if 
             (and 
               (not (clockwise-p p1 p2 p3)) 
               (= (length 
                    (unique 
                      (vl-remove 
                        nil 
                        (mapcar 
                          (function (lambda (a b) (inters p1 p2 a b))) 
                          l 
                          (cdr (reverse (cons (car l) (reverse l)))) 
                        ) 
                      ) 
                    ) 
                  ) 
                  2 
               ) 
               (= (length 
                    (unique 
                      (vl-remove 
                        nil 
                        (mapcar 
                          (function (lambda (a b) (inters p2 p3 a b))) 
                          l 
                          (cdr (reverse (cons (car l) (reverse l)))) 
                        ) 
                      ) 
                    ) 
                  ) 
                  2 
               ) 
               (= (length 
                    (unique 
                      (vl-remove 
                        nil 
                        (mapcar 
                          (function (lambda (a b) (inters p3 p1 a b))) 
                          l 
                          (cdr (reverse (cons (car l) (reverse l)))) 
                        ) 
                      ) 
                    ) 
                  ) 
                  2 
               ) 
             ) 
              (progn 
                (setq trl (cons (list p1 p2 p3) trl)) 
                (setq ptlst (vl-remove p2 ptlst)) 
                (setq ptlst 
                       (cdr (reverse (cons (car ptlst) (reverse ptlst))) 
                       ) 
                ) 
              ) 
              (setq ptlst 
                     (cdr (reverse (cons (car ptlst) (reverse ptlst)))) 
              ) 
           ) 
          ) 
        ) 
      ) 
      (setq 
        trl (cons (list (car ptlst) (cadr ptlst) (caddr ptlst)) trl) 
      ) 
      trl 
    ) 
 
    (defun ptinsidetriangle-p (pt p1 p2 p3) 
      (and 
        (not 
          (or 
            (inters pt p1 p2 p3) 
            (inters pt p2 p1 p3) 
            (inters pt p3 p1 p2) 
          ) 
        ) 
        (not 
          (or 
            (> (+ (distance pt p1) (distance pt p2)) 
               (+ (distance p3 p1) (distance p3 p2)) 
            ) 
            (> (+ (distance pt p2) (distance pt p3)) 
               (+ (distance p1 p2) (distance p1 p3)) 
            ) 
            (> (+ (distance pt p3) (distance pt p1)) 
               (+ (distance p2 p3) (distance p2 p1)) 
            ) 
          ) 
        ) 
      ) 
    ) 
 
    (setq trl (trianglst ptlst)) 
    (vl-some (function 
               (lambda (x) 
                 (ptinsidetriangle-p pt (car x) (cadr x) (caddr x)) 
               ) 
             ) 
             trl 
    ) 
  ) 
 
  (defun mid (p1 p2) 
    (mapcar (function (lambda (a b) (/ (+ a b) 2.0))) p1 p2) 
  ) 
 
  (vla-startundomark 
    (setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
  ) 
  (setq spc (vla-get-block (vla-get-activelayout adoc))) 
  (if (not (tblsearch "DIMSTYLE" "MVVA Standard Imperial")) 
    (Alert "MVVA Standard Imperial dimension style not loaded") 
    (Command "-dimstyle" "r" "MVVA Standard Imperial") 
  ) 
  (prompt "\nSelect closed POLYGONS...") 
  (setq sel (ssget (list '(0 . "LWPOLYLINE") '(-4 . "&=") 
                         '(70 . 1)           '(-4 . "<not") 
                         '(-4 . "<>")        '(42 . 0.0) 
                         '(-4 . "not>") 
                        ) 
            ) 
  ) 
  (initget 7) 
  (setq d (getdist 
            "\nPick or specify offset distance for dimensioning : " 
          ) 
  ) 
  (if sel 
    (progn 
      (repeat (setq i (sslength sel)) 
        (setq lw (ssname sel (setq i (1- i)))) 
        (setq enx (entget lw)) 
        (setq 
          pl (mapcar 
               (function 
                 (lambda (x) 
                   (trans (list (car x) (cadr x) (cdr (assoc 38 enx))) 
                          lw 
                          1 
                   ) 
                 ) 
               ) 
               (mapcar (function cdr) 
                       (vl-remove-if 
                         (function (lambda (x) (/= (car x) 10))) 
                         enx 
                       ) 
               ) 
             ) 
        ) 
        (vla-offset (vlax-ename->vla-object lw) d) 
        (setq lwn (entlast)) 
        (setq enxn (entget lwn)) 
        (setq plni 
               (mapcar 
                 (function 
                   (lambda (x) 
                     (trans (list (car x) (cadr x) (cdr (assoc 38 enxn))) 
                            lwn 
                            1 
                     ) 
                   ) 
                 ) 
                 (mapcar (function cdr) 
                         (vl-remove-if 
                           (function (lambda (x) (/= (car x) 10))) 
                           enxn 
                         ) 
                 ) 
               ) 
        ) 
        (if (not (mr_IsPointInside (car plni) pl)) 
          (progn 
            (entdel lwn) 
            (vla-offset (vlax-ename->vla-object lw) (- d)) 
            (setq lwn (entlast)) 
            (setq enxn (entget lwn)) 
            (setq plni 
                   (mapcar 
                     (function 
                       (lambda (x) 
                         (trans 
                           (list (car x) (cadr x) (cdr (assoc 38 enxn))) 
                           lwn 
                           1 
                         ) 
                       ) 
                     ) 
                     (mapcar (function cdr) 
                             (vl-remove-if 
                               (function (lambda (x) (/= (car x) 10))) 
                               enxn 
                             ) 
                     ) 
                   ) 
            ) 
          ) 
        ) 
        (entdel lwn) 
        (setq 
          plno (mapcar 
                 (function 
                   (lambda (a b) 
                     (mapcar (function +) a (mapcar (function -) a b)) 
                   ) 
                 ) 
                 pl 
                 plni 
               ) 
        ) 
        (setq plnom 
               (mapcar (function (lambda (a b) (mid a b))) 
                       plno 
                       (cdr (reverse (cons (car plno) (reverse plno)))) 
               ) 
        ) 
        (mapcar (function (lambda (a b c) 
                            (vla-addDimAligned 
                              spc 
                              (vlax-3d-point a) 
                              (vlax-3d-point b) 
                              (vlax-3d-point c) 
                            ) 
                          ) 
                ) 
                pl 
                (cdr (reverse (cons (car pl) (reverse pl)))) 
                plnom 
        ) 
        (setq pl (reverse (cons (car pl) (reverse pl)))) 
        (setq 
          plm (mapcar (function (lambda (a b) (mid a b))) pl (cdr pl)) 
        ) 
        (mapcar (function (lambda (a b c d) 
                            (vla-AddDim3PointAngular 
                              spc 
                              (vlax-3d-point a) 
                              (vlax-3d-point b) 
                              (vlax-3d-point c) 
                              (vlax-3d-point d) 
                            ) 
                          ) 
                ) 
                (cdr pl) 
                plm 
                (cdr (reverse (cons (car plm) (reverse plm)))) 
                (cdr (reverse (cons (car plni) (reverse plni)))) 
        ) 
      ) 
    ) 
    (prompt 
      "\nEmpty sel. set... Retry routine with valid sel. set..." 
    ) 
  ) 
 
   
  (setq ss (ssadd)) 
  (if (setq en (entnext LastEnt))       ;Check if there's a new entity created since the last one 
    (while en                           ;Step through all new entities 
      (ssadd en ss)                     ;Add it to the selection set 
      (setq en (entnext en))            ;Get the next entity 
    ) 
  ) 
 
  (command "_.-dimstyle" "Apply" ss "") 
   
  (*error* nil) 
  (setvar "CLAYER" clr) 
)

yjch · 发表于 2017-5-7 10:46:12

太好了，好好学习天天向上，不断进步

sh_h · 发表于 2017-5-7 13:21:07

这个必须顶！！！！！！

HLCAD · 发表于 2017-5-7 16:29:40

大师的代码就是牛，代码看着就舒服。

lw5297590 · 发表于 2017-5-7 19:44:44

出现这个是怎么回事，错误: 输入的字符串太长

OOWYB · 发表于 2019-8-31 22:40:01

太好了，感谢分享，大师辛苦了

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

[每日一码] 多段线自动标注所有边和所有内角的代码

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