多段线变多边形

wanhongron · 发表于 2022-2-11 09:50:55

自己写了个直线变多边形，通用性非常有限。工作中经常碰到多段线生成多边形的情况，如果能实现，画道路就很方便，恳请各位高手出出力

cxhhyy · 发表于 2022-2-15 12:39:35

本帖最后由 cxhhyy 于 2022-2-15 14:26 编辑

wanhongron 发表于 2022-2-15 08:26
非常完美，做工效率高了很多，万分感谢热心cxhhyy大侠

过奖过奖我不会写代码的 我也是在明经找的代码
上面代码遇到编组开始的时候会对操作对象不编组不能一步撤回我修改了一下

;;线变矩形
(defun c:jx (/ ss l en sz i lp h a la);定义命令
 (if (not $$)
(setq $$ 1) ;设置默认数值
 )
 (if (setq l (getdist (strcat "\n执行心心命令\n线变矩形\n请量取或输入矩形宽度:当前宽度:<" (rtos $$) ">\n")))
(setq $$ l)(setq l $$))
 (princ "\n请选择对象:\n")
 (if (setq ss (ssget '((0 . "LWPOLYLINE,LINE,ARC"))))
(progn (setvar "cmdecho" 0)
 (if (= 8 (logand (getvar "undoctl") 8))
 (progn (command-s "_.UNDO" "e") (command-s "_.UNDO" "be"))
 (command-s "_.UNDO" "be"))
 (setq i 0)
 (repeat (sslength ss)
 (setq en (ssname ss i)
 sz (ssadd)
 i (1+ i))
 (setq lp (mapcar
 '(lambda (y)
 (list (vlax-curve-getStartPoint y)
 (vlax-curve-getEndPoint y)))
 (mapcar 'car
 (mapcar
 '(lambda (x)
 (setq o (vlax-invoke (vlax-ename->vla-object en) 'Offset x))
 (ssadd (entlast) sz) o)
 (list (setq h (* 0.5 l)) (- h))))))
 (mapcar
 '(lambda (k l)
 (entmakex (list (cons 0 "LINE") (cons 10 k) (cons 11 l)))
 (ssadd (entlast) sz))
 (car lp)
 (cadr lp))(setvar 'PEDITACCEPT 1)
 (command-s "_.pedit" "m" sz "" "j" 0.0 "")(setq la (getvar "clayer"))
 (command-s "_.chprop" (entlast) "" "la" la ""))
 (if (= 8 (logand (getvar "undoctl") 8)) (command-s "_.UNDO" "e"))
 (setvar "cmdecho" 1)
 (if (not (setq p (getpoint "\n单击不删除源对象 <空格删除>\n")))
 (command-s "_.ERASE" ss ""))
 (princ "\n心心命令执行完毕\n!"))
(progn (princ "\n未选择对象!\n")))
 (princ (menucmd "M=$(edtime,$(getvar,date),YYYY.MO.DD HH:MM DDDD )"))
 (princ))
;;

cxhhyy · 发表于 2022-2-14 19:33:53

本帖最后由 cxhhyy 于 2022-2-14 19:37 编辑

;;线变矩形
(defun c:jx (/ ss l en sz i lp h a la);定义命令
 (if (not $$)
(setq $$ 1) ;设置默认数值
 )
 (if (setq l (getdist (strcat "\n执行心心命令\n线变矩形\n请量取或输入矩形宽度:当前宽度:<" (rtos $$) ">\n")))
(setq $$ l)(setq l $$))
 (princ "\n请选择对象:\n")
 (if (setq ss (ssget '((0 . "LWPOLYLINE,LINE,ARC"))))
(progn (setvar "cmdecho" 0)
 (if (= 8 (logand (getvar "undoctl") 8))
 (command-s "_.UNDO" "e")
 (command-s "_.UNDO" "be"))
 (setq i 0)
 (repeat (sslength ss)
 (setq en (ssname ss i)
 sz (ssadd)
 i (1+ i))
 (setq lp (mapcar
 '(lambda (y)
 (list (vlax-curve-getStartPoint y)
 (vlax-curve-getEndPoint y)))
 (mapcar 'car
 (mapcar
 '(lambda (x)
 (setq o (vlax-invoke (vlax-ename->vla-object en) 'Offset x))
 (ssadd (entlast) sz) o)
 (list (setq h (* 0.5 l)) (- h))))))
 (mapcar
 '(lambda (k l)
 (entmakex (list (cons 0 "LINE") (cons 10 k) (cons 11 l)))
 (ssadd (entlast) sz))
 (car lp)
 (cadr lp))(setvar 'PEDITACCEPT 1)
 (command-s "_.pedit" "m" sz "" "j" 0.0 "")(setq la (getvar "clayer"))
 (command-s "_.chprop" (entlast) "" "la" la ""))
 (if (not (setq p (getpoint "\n单击不删除源对象 <空格删除>\n")))
 (command-s "_.ERASE" ss ""))
 (if (= 8 (logand (getvar "undoctl") 8)) (command-s "_.UNDO" "e"))
 (setvar "cmdecho" 1)
 (princ "\n心心命令执行完毕\n!"))
(progn (princ "\n未选择对象!\n")))
 (princ (menucmd "M=$(edtime,$(getvar,date),YYYY.MO.DD HH:MM DDDD )"))
 (princ))
;;

cxhhyy · 发表于 2022-2-13 20:38:51

本帖最后由 cxhhyy 于 2022-2-14 05:30 编辑

;;线变矩形
(defun c:jx (/ ss l en sz i lp h a);定义命令
 (if (not $$)
(setq $$ 1) ;设置默认数值
 )
 (if (setq l (getdist (strcat "\n执行心心命令\n线变矩形\n请量取或输入矩形宽度:当前宽度:<" (rtos $$) ">\n")))
(setq $$ l)(setq l $$))
 (princ "\n请选择对象:\n")
 (if (setq ss (ssget '((0 . "LWPOLYLINE,LINE,ARC"))))
(progn (setvar "cmdecho" 0)
 (if (= 8 (logand (getvar "undoctl") 8))
 (command-s "_.UNDO" "e")
 (command-s "_.UNDO" "be"))
 (setq i 0)
 (repeat (sslength ss)
 (setq en (ssname ss i)
 sz (ssadd)
 i (1+ i))
 (setq lp (mapcar
 '(lambda (y)
 (list (vlax-curve-getStartPoint y)
 (vlax-curve-getEndPoint y)))
 (mapcar 'car
 (mapcar
 '(lambda (x)
 (setq o (vlax-invoke (vlax-ename->vla-object en) 'Offset x))
 (ssadd (entlast) sz) o)
 (list (setq h (* 0.5 l)) (- h))))))
 (mapcar
 '(lambda (k l)
 (entmakex (list (cons 0 "LINE") (cons 10 k) (cons 11 l)))
 (ssadd (entlast) sz))
 (car lp)
 (cadr lp))(setvar 'PEDITACCEPT 1)
 (command-s "_.pedit" "m" sz "" "j" 0.0 ""))
 (if (not (setq p (getpoint "\n单击不删除源对象 <空格删除>\n")))
 (command-s "_.ERASE" ss ""))
 (if (= 8 (logand (getvar "undoctl") 8)) (command-s "_.UNDO" "e"))
 (setvar "cmdecho" 1)
 (princ "\n心心命令执行完毕\n!"))
(progn (princ "\n未选择对象!\n")))
 (princ (menucmd "M=$(edtime,$(getvar,date),YYYY.MO.DD HH:MM DDDD )"))
 (princ))
;;

672505821 · 发表于 2022-2-11 10:02:20

不明白你说的什么意思

xj6019 · 发表于 2022-2-11 10:25:58

http://bbs.mjtd.com/forum.php?mo ... E%CF%DF%C6%AB%D2%C6

wanhongron · 发表于 2022-2-11 10:27:09

可能我说的不太明白，就是选择任意多段线能按自己设定的宽度生成多边形

夏生生 · 发表于 2022-2-11 10:27:50

wanhongron 发表于 2022-2-11 10:27
可能我说的不太明白，就是选择任意多段线能按自己设定的宽度生成多边形

(defun c:tt (/ dis en en1 lay lst p ss)
(setq en (vlax-ename->vla-object (car (entsel "\n选:")))
dis (getreal "\n偏:")
lay (vla-get-layer en)
en1 (vlax-safearray->list
(vlax-variant-value (vla-offset en dis))
)
en1 (if (= 1 (length en1))
(car en1)
)
en (vlax-safearray->list
(vlax-variant-value (vla-offset en (- dis)))
)
en (if (= 1 (length en))
(car en)
)
lst (list (vlax-vla-object->ename en1)
(vlax-vla-object->ename en)
)
lst (cons
(entmakex (list '(0 . "line")
(cons 8 lay)
(cons 10 (vlax-curve-getstartpoint en1))
(cons 11 (vlax-curve-getstartpoint en))
)
)
lst
)
lst (cons
(entmakex (list '(0 . "line")
(cons 8 lay)
(cons 10 (vlax-curve-getendpoint en1))
(cons 11 (vlax-curve-getendpoint en))
)
)
lst
)
ss (ssadd)
p (getvar 'PEDITACCEPT)
)
(setvar 'PEDITACCEPT 1)
(foreach n lst (setq ss (ssadd n ss)))
(command "_.pedit" "m" ss "" "j" "" "")
(setvar 'PEDITACCEPT p)
)

(defun c:tt (/ dis en en1 lay lst p ss) 
  (setq        en  (vlax-ename->vla-object (car (entsel "\n选:"))) 
        dis (getreal "\n偏:") 
        lay (vla-get-layer en) 
        en1 (vlax-safearray->list 
              (vlax-variant-value (vla-offset en dis)) 
              ) 
        en1 (if        (= 1 (length en1)) 
              (car en1) 
              ) 
        en  (vlax-safearray->list 
              (vlax-variant-value (vla-offset en (- dis))) 
              ) 
        en  (if        (= 1 (length en)) 
              (car en) 
              ) 
        lst (list (vlax-vla-object->ename en1) 
                  (vlax-vla-object->ename en) 
                  ) 
        lst (cons 
              (entmakex        (list '(0 . "line") 
                              (cons 8 lay) 
                              (cons 10 (vlax-curve-getstartpoint en1)) 
                              (cons 11 (vlax-curve-getstartpoint en)) 
                              ) 
                        ) 
              lst 
              ) 
        lst (cons 
              (entmakex        (list '(0 . "line") 
                              (cons 8 lay) 
                              (cons 10 (vlax-curve-getendpoint en1)) 
                              (cons 11 (vlax-curve-getendpoint en)) 
                              ) 
                        ) 
              lst 
              ) 
        ss  (ssadd) 
        p   (getvar 'PEDITACCEPT) 
        ) 
  (setvar 'PEDITACCEPT 1) 
  (foreach n lst (setq ss (ssadd n ss))) 
  (command "_.pedit" "m" ss "" "j" "" "") 
  (setvar 'PEDITACCEPT p) 
  )

wanhongron · 发表于 2022-2-11 10:48:56

非常感谢大神的答复，加载程序后显示错误: 参数类型错误: numberp: nil，望夏大侠继续指点指点

wanhongron · 发表于 2022-2-11 11:59:04

麻烦夏大侠发个完整的lsp源文件

wanhongron · 发表于 2022-2-11 15:08:27

真的可以了，非常感谢热心肠的夏大侠

菜卷鱼 · 发表于 2022-2-12 08:58:39

本帖最后由菜卷鱼于 2022-2-12 09:03 编辑

用偏置，然后连接偏置线的头尾端，一边各偏置一下就出来了
(defun C:OO (/ ent *error* ps1 pe1 ps2 pe2 dist vllent lent ass8 vlent key) ;;;;
;; (setq *error* cmderr)
 (princ "\n偏移对象并连接首尾点")
 (if (= odist nil)
(setq odist 100)
 )
 (mapcar 'princ (list "\n指定偏移距离[删除(E)] <" odist ">:"))
 (initget "Erase")
 (setq dist (getdist ""))
 (if (= dist "Erase")
 (progn
 (setq key t )
 (mapcar 'princ (list "\n指定偏移距离 <" odist ">:"))
 (setq dist (getdist ""))
 )
 )
 (if (= dist nil)
(setq dist odist)
(setq odist dist)
 )
 (cmd0)
 (setq ent (car (entsel "\n选择要偏移的对象:")))
 (while ent
(setq vlent (vlax-ename->vla-object ent))
(setq ps1 (vlax-curve-getStartPoint vlent))
(setq pe1 (vlax-curve-getEndPoint vlent))
(setq pt (getpoint "\n指定要偏移的那一侧上的点:"))
(command "_.offset" dist ent pt "")
(setq ass8 (assoc 8 (entget ent)))
(setq lent (entlast))
(setq vllent (vlax-ename->vla-object lent))
(setq ps2 (vlax-curve-getStartPoint vllent))
(setq pe2 (vlax-curve-getEndPoint vllent))
(or
 (ssget "x" (list '(0 . "LINE") (cons 10 ps1) (cons 11 ps2)))
 (ssget "x" (list '(0 . "LINE") (cons 10 ps2) (cons 11 ps1)))
 (entmake
 (list '(0 . "LINE") (cons 10 ps1) (cons 11 ps2) ass8)
 )
)
(or
 (ssget "x" (list '(0 . "LINE") (cons 10 pe1) (cons 11 pe2)))
 (ssget "x" (list '(0 . "LINE") (cons 10 pe2) (cons 11 pe1)))
 (entmake
 (list '(0 . "line") (cons 10 pe1) (cons 11 pe2) ass8)
 )
)
;;;(wipe vlent vllent)
(if key (vldel ent))
(setq ent (car (entsel "\n选择要偏移的对象:")))
 )
 (cmd1)
 (prin1)
)

自贡黄明儒 · 发表于 2022-2-12 09:55:03

有没有试过用Mline?

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

[提问] 多段线变多边形

本帖子中包含更多资源

点评