标注多段线各边长度及夹角

vlisp2012

正好需要，多谢分享了

vlisp2012

不能使用啊，括号不匹配？谁有修好的代码？麻烦上传一下呗

zhixinshengjie

能不能用啊

Daihongy

回覆学习，谢谢分享！！！

czb203

好东西就得支持一下，谢谢分享

vlisp2012

我拷贝程序后，括号不匹配啊，没有遇到这个问题的吗？谁有完整的代码？

vlisp2012

(defun c:dimpolygons ( / *error* mr_IsPointInside mid adoc spc sel d i lw enx pl lwn enxn plni plno plnom plm clr)

  (vl-load-com)

  (defun *error* ( m )
    (vla-endundomark adoc)
    (if m
      (prompt m)
    )
    (princ)
  )

(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" "SCAPE Standard"))
    (Alert "SCAPE Standard dimension style not loaded")
    (Command "-dimstyle" "r" "SCAPE Standard")
  )
  (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...")
  )
  (*error* nil)
(setvar "CLAYER" clr)
)

pengxinming

想学习学习

wysclc

好东西啊，工作正好用上

ketxu

Thanks for sharing ^^

ketxu

Thanks for sharing

sammy_crysis

学习学习，看下

maple_197

感谢楼主分享！！！

maple_197

感谢楼主分享！！！

qwy7120_P3Z0E

学习一下，谢谢楼主分享