给ACAD增加个MAP才有的MPolygon命令（生成多重拓扑多边形）

Lispboy · 发表于 2017-2-25 21:11:11

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

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

×

(defun c:xdtb_mpolygon (/ e gpline i j k mp msg myerr pattern pline pt pts ss tf tf1
)
(defun _selectobj ()
(if (setq ss (ssget '((0 . "*POLYLINE,SPLINE,ELLIPSE,CIRCLE"))))
(progn
(vla-startundomark **xd::doc**)
(if (= i 0)
(setq mp (xdrx-mpolygon-make ss t t))
(xdrx_setpropertyvalue mp "appendLoopFromBoundary" (list ss t t))
)
(if (/= pattern "")
(xdrx_setpropertyvalue mp "pattern" (list 1 pattern))
)
(setq i (1+ i))
(vla-endundomark **xd::doc**)
)
)
)
(defun _hatch ()
(if mp
(if (= pattern "")
(progn
(setq pattern "solid")
(xdrx_setpropertyvalue mp "pattern" (list 1 pattern))
)
(progn
(xdrx-mpolygon-remake mp)
(setq pattern "")
)
)
)
(princ)
)
(defun _undo ()
(setq i (1- i))
(vl-cmdf ".undo" 1)
(princ)
)
(defun _undo1 ()
(setq j (1- j))
(vl-cmdf ".undo" 1)
(setq pts (cdr pts))
(princ)
)
(defun _append ()
(if (setq e (car (xdrx_entsel "\n拾取添加的MPOLYGON<退出>:" '(
(0 . "MPOLYGON")
)
)
)
)
(setq mp e
k 1
)
)
(princ)
)
(defun _draw ()
(setq j 0
tf1 t
)
(setq gpline (xdge::constructor "kCompositeCrv3d"))
(while (and
tf1
(xdrx_initget (strcat "U" (if (> j 1)
"C"
""
)
)
)
(progn
(setq pt (getpoint pt (strcat "\n指定下一点或 [" (if
(> j 1)
"闭合(C)/"
""
) "放弃(U)]"
(if (> j 1)
"<闭合>:"
":"
)
)
)
)
t
)
)
(if (not pt)
(setq pt "C")
)
(cond
((= (type pt) 'list)
(setq pts (cons pt pts))
(setq j (1+ j))
(xdrx_entity_delete pline)
(setq pline (xdrx_polyline_make (reverse pts)))
)
((= pt "U")
(_undo1)
(setq pt (car pts))
(xdrx_entity_delete pline)
(xdrx_polyline_make (reverse pts))
(if (< j 0)
(setq tf1 nil
i 1
)
)
)
((= pt "C")
(setq tf1 nil
i 1
)
(if mp
(progn
(xdrx_setpropertyvalue mp "appendLoopFromBoundary"
(list pline t t)
)
)
(progn
(vla-startundomark **xd::doc**)
(setq mp (xdrx-mpolygon-make pline t t))
(if (/= pattern "")
(xdrx_setpropertyvalue mp "pattern" (list 1 pattern))
)
)
)
)
)
)
(princ)
)
(defun myerr (msg)
(princ "\n")
(princ msg)
(xdrx_entity_delete mp pline)
(xdrx_end)
)
(xdrx_begin)
(setq *error* myerr)
(setq i 0
k 0
tf t
pattern "solid"
)
(while (and
tf
(xdrx_initget (strcat (if mp
"F"
""
) "X O" (if (= k 0)
"A"
""
) (if (> i 0)
"U"
""
)
)
)
(progn
(setq pt (getpoint (strcat "\nMPOLYGON指定起点或[" (if
(and
(not mp)
(= k 0)
)
"添加(A)/"
""
)
(if mp
"填充(F)/"
""
) "选择对象(O)" (if (> i 0)
"/回退(U)"
""
) "/退出(X)]"
(if (= i 0)
"<选择对象>:"
"<退出>:"
)
)
)
)
t
)
)
(if (not pt)
(if (> i 0)
(setq pt "X")
(setq pt "O")
)
)
(cond
((= pt "A")
(_append)
)
((= pt "U")
(_undo)
)
((= pt "X")
(setq tf nil)
)
((= pt "O")
(_selectobj)
)
((= pt "F")
(_hatch)
)
((= (type pt) 'list)
(setq pts nil)
(setq pts (cons pt pts))
(_draw)
)
)
)
(setq *error* nil)
(xdrx_end)
(princ)
)

(defun c:xdtb_mpolygon (/ e gpline i j k mp msg myerr pattern pline pt pts                          ss tf tf1 
                       ) 
  (defun _selectobj () 
    (if (setq ss (ssget '((0 . "*POLYLINE,SPLINE,ELLIPSE,CIRCLE")))) 
      (progn 
        (vla-startundomark **xd::doc**) 
        (if (= i 0) 
          (setq mp (xdrx-mpolygon-make ss t t)) 
          (xdrx_setpropertyvalue mp "appendLoopFromBoundary" (list ss t t)) 
        ) 
        (if (/= pattern "") 
          (xdrx_setpropertyvalue mp "pattern" (list 1 pattern)) 
        ) 
        (setq i (1+ i)) 
        (vla-endundomark **xd::doc**) 
      ) 
    ) 
  ) 
  (defun _hatch () 
    (if mp 
      (if (= pattern "") 
        (progn 
          (setq pattern "solid") 
          (xdrx_setpropertyvalue mp "pattern" (list 1 pattern)) 
        ) 
        (progn 
          (xdrx-mpolygon-remake mp) 
          (setq pattern "") 
        ) 
      ) 
    ) 
    (princ) 
  ) 
  (defun _undo () 
    (setq i (1- i)) 
    (vl-cmdf ".undo" 1) 
    (princ) 
  ) 
  (defun _undo1 () 
    (setq j (1- j)) 
    (vl-cmdf ".undo" 1) 
    (setq pts (cdr pts)) 
    (princ) 
  ) 
  (defun _append () 
    (if (setq e (car (xdrx_entsel "\n拾取添加的MPOLYGON<退出>:" '( 
                                   (0 . "MPOLYGON") 
                                  ) 
                     ) 
                ) 
        ) 
      (setq mp e 
            k 1 
      ) 
    ) 
    (princ) 
  ) 
  (defun _draw () 
    (setq j 0 
          tf1 t 
    ) 
    (setq gpline (xdge::constructor "kCompositeCrv3d")) 
    (while (and 
             tf1 
             (xdrx_initget (strcat "U" (if (> j 1) 
                                         "C" 
                                         "" 
                                       ) 
                           ) 
             ) 
             (progn 
               (setq pt (getpoint pt (strcat "\n指定下一点或 [" (if 
                                                                  (> j 1) 
                                                                  "闭合(C)/" 
                                                                  "" 
                                                                ) "放弃(U)]" 
                                             (if (> j 1) 
                                               "<闭合>:" 
                                               ":" 
                                             ) 
                                     ) 
                        ) 
               ) 
               t 
             ) 
           ) 
      (if (not pt) 
        (setq pt "C") 
      ) 
      (cond 
        ((= (type pt) 'list) 
          (setq pts (cons pt pts)) 
          (setq j (1+ j)) 
          (xdrx_entity_delete pline) 
          (setq pline (xdrx_polyline_make (reverse pts))) 
        ) 
        ((= pt "U") 
          (_undo1) 
          (setq pt (car pts)) 
          (xdrx_entity_delete pline) 
          (xdrx_polyline_make (reverse pts)) 
          (if (< j 0) 
            (setq tf1 nil 
                  i 1 
            ) 
          ) 
        ) 
        ((= pt "C") 
          (setq tf1 nil 
                i 1 
          ) 
          (if mp 
            (progn 
              (xdrx_setpropertyvalue mp "appendLoopFromBoundary" 
                                     (list pline t t) 
              ) 
            ) 
            (progn 
              (vla-startundomark **xd::doc**) 
              (setq mp (xdrx-mpolygon-make pline t t)) 
              (if (/= pattern "") 
                (xdrx_setpropertyvalue mp "pattern" (list 1 pattern)) 
              ) 
            ) 
          ) 
        ) 
      ) 
    ) 
    (princ) 
  ) 
  (defun myerr (msg) 
    (princ "\n") 
    (princ msg) 
    (xdrx_entity_delete mp pline) 
    (xdrx_end) 
  ) 
  (xdrx_begin) 
  (setq *error* myerr) 
  (setq i 0 
        k 0 
        tf t 
        pattern "solid" 
  ) 
  (while (and 
           tf 
           (xdrx_initget (strcat (if mp 
                                   "F" 
                                   "" 
                                 ) "X O" (if (= k 0) 
                                           "A" 
                                           "" 
                                         ) (if (> i 0) 
                                             "U" 
                                             "" 
                                           ) 
                         ) 
           ) 
           (progn 
             (setq pt (getpoint (strcat "\nMPOLYGON指定起点或[" (if 
                                                                  (and 
                                                                    (not mp) 
                                                                    (= k 0) 
                                                                  ) 
                                                                  "添加(A)/" 
                                                                  "" 
                                                                ) 
                                        (if mp 
                                          "填充(F)/" 
                                          "" 
                                        ) "选择对象(O)" (if (> i 0) 
                                                          "/回退(U)" 
                                                          "" 
                                                        ) "/退出(X)]" 
                                        (if (= i 0) 
                                          "<选择对象>:" 
                                          "<退出>:" 
                                        ) 
                                ) 
                      ) 
             ) 
             t 
           ) 
         ) 
    (if (not pt) 
      (if (> i 0) 
        (setq pt "X") 
        (setq pt "O") 
      ) 
    ) 
    (cond 
      ((= pt "A") 
        (_append) 
      ) 
      ((= pt "U") 
        (_undo) 
      ) 
      ((= pt "X") 
        (setq tf nil) 
      ) 
      ((= pt "O") 
        (_selectobj) 
      ) 
      ((= pt "F") 
        (_hatch) 
      ) 
      ((= (type pt) 'list) 
        (setq pts nil) 
        (setq pts (cons pt pts)) 
        (_draw) 
      ) 
    ) 
  ) 
  (setq *error* nil) 
  (xdrx_end) 
  (princ) 
)

ming1789 · 发表于 2017-2-26 00:11:55

正需要，支持楼主大人了！

qqqincccken · 发表于 2017-2-26 00:36:44

谢谢提供，学习试用一下

sicky111 · 发表于 2017-2-26 00:37:47

啥也不说了，感谢楼主分享哇！

lcw9908 · 发表于 2017-2-26 11:17:50

啥也不说了，感谢楼主分享哇！

330774521lhq · 发表于 2017-2-26 19:35:41

正需要，支持楼主大人了！

longer1000 · 发表于 2017-2-27 12:47:57

啥也不说了，感谢楼主分享哇！

land100 · 发表于 2017-11-4 12:17:01

正需要，支持楼主大人了！多少度vsddsvcs

xinxirong · 发表于 2017-11-4 12:37:55

应该有更具体的应用吧，只是画mpolygon，lisp

kqqt6236 · 发表于 2017-11-5 12:07:02

谢谢分享。

wangwen2 · 发表于 2017-12-6 15:13:08

确实非常强悍

moto1786 · 发表于 2017-12-12 22:45:24

谢谢提供，学习试用一下

pur2 · 发表于 2018-7-31 12:58:20

非常不错的东西，学习了。

pur2 · 发表于 2018-7-31 14:59:22

好像用不了，是不是程序格式错了？

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

[拓扑] 给ACAD增加个MAP才有的MPolygon命令（生成多重拓扑多边形）

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