一个简单的多段线打断，补充凸度
本帖最后由 freedom_ice 于 2023-10-30 21:13 编辑;;2023.10.30修改
( defun bulge (startpt endpt targetpt initbulge / bulge1 bulge2 delth dis1 dis2 dis3 radius verticalline1 verticalline2 )
( setq dis1 ( distance startpt endpt ) )
( setq dis2 ( distance startpt targetpt ) )
( setq dis3 ( distance targetpt endpt ) )
( cond ( ( and ( /= initbulge 0 )
( /= dis1 0 )
( /= dis2 0 )
( /= dis3 0 )
)
( progn
( setq sign ( / initbulge ( abs initbulge ) ) )
( setq deltH (* ( abs initbulge ) 0.5 dis1 ) )
( setq radius ( / ( + ( expt deltH 2 ) ( expt ( * 0.5 dis1 ) 2 ) ) ( * 2 deltH ) ) )
( setq verticalline1 ( sqrt ( - ( expt radius 2 ) ( expt ( * 0.5 dis2 ) 2 ) ) ) )
( setq bulge1 ( / ( * 2 ( - radius verticalline1 ) ) dis2 ) )
( setq verticalline2 ( sqrt ( - ( expt radius 2 ) ( expt ( * 0.5 dis3 ) 2 ) ) ) )
( setq bulge2 ( / ( * 2 ( - radius verticalline2 ) ) dis3 ) )
( list ( * sign bulge1 ) ( * sign bulge2 ) )
)
)
( ( and ( /= initbulge 0 )
( /= dis1 0 )
( = dis2 0 )
( /= dis3 0 )
)
( list 0 initbulge )
)
( ( and ( /= initbulge 0 )
( /= dis1 0 )
( /= dis2 0 )
( = dis3 0 )
)
( list initbulge 0 )
)
( t
( list 0 0 )
)
)
)
( defun c:plb ( )
( princ "\n选择多段线:" )
( setq entname ( ssname ( ssget ) 0 ) )
( princ "\n选择打断点:" )
( setq pt ( getpoint ) )
( setq targetpt ( vlax-curve-getClosestPointTo entname pt ) )
( if ( and ( equal ( car pt ) ( car targetpt ) 0.000001 )
( equal ( cadr pt ) ( cadr targetpt ) 0.00001 )
)
( lwplbreak ( vlax-ename->vla-object entname ) pt)
( princ "指定点不在多段线上！" )
)
)
( defun lwplbreak(plineobj pt / bulge_j bulge_k bulge_node bulges emppt i j node_i node_j noden nodes_obj2 obj2 pline1 pline2 plnode1 plnode2 ptlist1 ptlist2 targetn targetparam)
( setq targetparam ( vlax-curve-getParamAtPoint plineobj pt ) )
( setq targetN ( fix targetparam ) )
( setq nodeN ( fix ( vlax-curve-getEndParam plineobj ) ) )
( setq ptlist1 nil )
( setq ptlist2 nil )
( if ( and ( > targetparam 0 )
( < targetparam nodeN )
)
( progn
( setq i 0 )
( while ( <= i targetN )
( setq emppt ( vlax-curve-getPointAtParam plineobj i ) )
( setq ptlist1 ( cons ( reverse ( cdr ( reverse emppt ) ) ) ptlist1 ) )
( setq i ( 1+ i ) )
)
( if ( equal ( distance pt ( vlax-curve-getPointAtParam plineobj targetN ) ) 0.000001 )
( setq plnode1 ( + ( * 2 targetN ) 1 ) )
( progn
( setq ptlist1 ( cons ( reverse ( cdr ( reverse pt ) ) ) ptlist1 ) )
( setq plnode1 ( + ( * 2 ( + 1 targetN ) ) 1 ) )
)
)
( setq ptlist1 ( reverse ptlist1 ) )
( setq ptlist1 ( apply 'append ptlist1 ) )
( setq pline1 (vlax-make-safearray vlax-vbDouble ( cons 0 plnode1 ) ) )
( vlax-safearray-fill pline1 ptlist1 )
( setq j nodeN )
( while ( > j targetN )
( setq emppt ( vlax-curve-getPointAtParam plineobj j ) )
( setq ptlist2 ( cons ( reverse ( cdr ( reverse emppt ) ) ) ptlist2 ) )
( setq j ( 1- j ) )
)
( if ( equal ( distance pt ( vlax-curve-getPointAtParam plineobj ( + 1 targetN ) ) ) 0.000001 )
( setq plnode2 ( + ( * 2 ( - nodeN targetN 1 ) ) 1 ) )
( progn
( setq ptlist2 ( cons ( reverse ( cdr ( reverse pt ) ) ) ptlist2 ) )
( setq plnode2 ( + ( * 2 ( - nodeN targetN ) ) 1 ) )
)
)
( setq ptlist2 ( apply 'append ptlist2 ) )
( setq pline2 (vlax-make-safearray vlax-vbDouble ( cons 0 plnode2 ) ) )
( vlax-safearray-fill pline2 ptlist2 )
;凸度获取
( setq bulges nil )
( setq bulge_k nodeN )
( while ( >= bulge_k 0 )
( setq bulges ( cons ( vla-getbulge plineobj bulge_k ) bulges ) )
( setq bulge_k ( 1- bulge_k ) )
)
( setq bulge_node ( bulge ( vlax-curve-getPointAtParam plineobj targetN ) ( vlax-curve-getPointAtParam plineobj ( 1+ targetN ) ) pt ( nth targetN bulges ) ) )
( setq obj2 ( vla-Copy plineobj ) )
( setq pline1 ( vlax-make-variant pline1 ) )
( vla-put-Coordinates plineobj pline1 )
( setq pline2 ( vlax-make-variant pline2 ) )
( vla-put-Coordinates obj2 pline2 )
;凸度赋值
( setq node_i 0 )
( repeat ( + ( fix ( vlax-curve-getEndParam plineobj ) ) 1 )
( vla-SetBulge plineobj node_i ( nth node_i bulges ) )
( setq node_i ( 1+ node_i ) )
)
( vla-SetBulge plineobj ( - ( fix ( vlax-curve-getEndParam plineobj ) ) 1 ) ( car bulge_node ) )
( vla-SetBulge plineobj ( fix ( vlax-curve-getEndParam plineobj ) ) 0 )
( setq nodes_obj2 ( fix ( vlax-curve-getEndParam obj2 ) ) )
( setq bulge_j ( - ( length bulges ) 1 ) )
( repeat ( + ( fix ( vlax-curve-getEndParam obj2 ) ) 1 )
( vla-SetBulge obj2 nodes_obj2 ( nth bulge_j bulges ) )
( setq nodes_obj2 ( 1- nodes_obj2 ) )
( setq bulge_j ( 1- bulge_j ) )
)
( vla-SetBulge obj2 0 ( cadr bulge_node ) )
( vla-Update plineobj )
( vla-Update obj2 )
)
)
( princ )
)
试了一下，写了个逻辑比较混乱的，好多bug:lol欢迎扔砖
;;;打断LWPLINE逻辑混乱版
(defun c:tt(/ xty-L-cdrn xty-L-carn
xty-L-retainget-vtxl xty-tanmake-plbu
bue busen en1 en2 enl
enn entfuzz ince incs mode
ne nsocs pme pms pt
pta ptbptl tmp vtx1 vtx2
vtxe vtxlvtxs vtxt we wee
wes wswse wss x)
(defun xty-L-cdrn(n lst /)
(if (= 0 n)
lst
(repeat n (setq lst (cdr lst)))
)
)
(defun xty-L-carn(n lst / lsta)
(if (= 0 n)
(setq lsta lst)
(progn (setq lsta nil)
(repeat n
(setq lsta (append lsta (list (car lst)))
lst(cdr lst)
)
)
)
)
lsta
)
(defun xty-L-retain (m n lst /)
(setq lst (xty-L-carn n lst))
(setq lst (if (= 1 m)
lst
(xty-L-cdrn (1- m) lst)
)
)
)
(defun xty-tan(ang)
((lambda (x)
(if (equal 0. x 1e-14)
nil
(/ (sin ang) x)
)
)
(cos ang)
)
)
(defun xty-L-delsames(lst fuzz / start new)
(while (setq start (car lst))
(if(vl-some '(lambda (x) (equal start x fuzz)) new)
nil
(setq new (cons start new))
)
(setq lst (cdr lst))
)
(setq new (reverse new))
new
)
(defun get-vtxl(ent / vtxl)
(while (setq ent (member (assoc 10 ent) ent))
(setq vtxl (cons (list (assoc 10 ent)
(assoc 40 ent)
(assoc 41 ent)
(assoc 42 ent))
vtxl)
ent(cdr ent)))
(reverse vtxl))
(defun make-pl(tmp ent ocs)
(entmakex
(append (subst (cons 90 (length tmp)) (assoc 90 ent) ent)
(apply 'append tmp)
(list (cons 210 ocs)))))
(setq fuzz 1e-6
en (car (entsel))
ent(entget en)
ocs(cdr (assoc 210 ent))
vtxl (get-vtxl ent)
mode (if (= 1 (cdr (assoc 70 ent)))
t
nil)
vtxl (if (equal (caar vtxl) (car (last vtxl)) fuzz)
(reverse (cdr (reverse vtxl)))
vtxl)
ptlnil)
(while (setq pt (getpoint)) (setq ptl (cons pt ptl)))
(setq ptl (mapcar '(lambda (x) (trans x 1 0)) ptl)
pta (vlax-curve-getstartpoint en)
ptb (vlax-curve-getendpoint en)
ptl (cons pta ptl)
ptl (cons ptb ptl)
ptl (xty-l-delsames ptl fuzz)
ptl (vl-sort
ptl
(function (lambda (x y)
(< (vlax-curve-getparamatpoint en x)
(vlax-curve-getparamatpoint en y)))))
ptl (if (equal pta ptb fuzz)
(append ptl (list ptb))
ptl)
)
(setq ent (reverse (member (assoc 39 ent) (reverse ent))))
(setq ent
(vl-remove-if
'(lambda (x)
(member (car x) '(-1 5 6 8 39 43 48 62 102 330 370)))
ent))
(setq ent (subst (cons 70 0) (assoc 70 ent) ent))
(setq enl (mapcar
(function
(lambda (pts pte)
(setqpms(vlax-curve-getparamatpoint
en
pts)
ns (fix pms)
incs (- pms ns)
vtxs (nth ns vtxl)
pme(vlax-curve-getparamatpoint
en
pte)
pme(if (< pme pms)
(vlax-curve-getendparam en)
pme)
pme(if (> pme (length vtxl))
(- pme 1)
pme)
pme(if (= pme (length vtxl))
(1- pme)
pme)
ne (fix pme)
ince (- pme ne)
vtxe (nth ne vtxl)
wss(cdr (assoc 40 vtxs))
wse(cdr (assoc 41 vtxs))
bus(atan (cdr (assoc 42 vtxs)))
wes(cdr (assoc 40 vtxe))
wee(cdr (assoc 41 vtxe))
bue(atan (cdr (assoc 42 vtxe))))
(if (= ns ne)
(setq ws (+ wss (* incs (- wse wss)))
we (+ wss (* ince (- wse wss)))
bu (xty-tan (* (- pme pms) bus))
vtxs (list
(cons 10
(trans pts 0 ocs))
(cons 40 ws)
(cons 41 we)
(cons 42 bu))
vtxe (list
(cons 10
(trans pte 0 ocs))
(cons 40 we)
(cons 41 we)
(cons 42 bu))
enn (make-pl (list vtxs vtxe)
ent
ocs))
(setq ws (+ wss (* incs (- wse wss)))
bu (- (xty-tan (* (1- incs) bus)))
vtxs (list
(cons 10
(trans pts 0 ocs))
(cons 40 ws)
(cons 41 wse)
(cons 42 bu))
ws (+ wes (* ince (- wee wes)))
bu (xty-tan (* (- pme ne) bue))
tmp (xty-L-retain (+ ns 2)
(1+ ne)
vtxl)
vtxt (last tmp)
tmp (reverse (cdr (reverse tmp)))
vtxt (subst(cons 41 ws)
(assoc 41 vtxt)
vtxt)
vtxt (subst(cons 42 bu)
(assoc 42 vtxt)
vtxt)
vtxe (list
(cons 10
(trans pte 0 ocs))
(cons 40 wee)
(cons 41 wee)
(cons 42 bu))
tmp (cons vtxs tmp)
enn (make-pl
(append tmp
(list vtxt vtxe))
ent
ocs)))))
ptl
(cdr ptl)))
(ifmode
(progn (setq en1(car enl)
vtx1 (get-vtxl (entget en1))
en2(last enl)
vtx2 (get-vtxl (entget en2))
enl(vl-remove en1 enl)
enl(vl-remove en2 enl)
enl(cons(make-pl (append vtx2 (cdr vtx1)) ent ocs)
enl))
(entdel en1)
(entdel en2)))) 多段线打断，补充凸度，暂不考虑打断点处的全局宽度
( defun c:tt()
( setq entname ( ssname ( ssget ) 0 ) )
( setq plineobj ( vlax-ename->vla-object entname ) )
( setq nodeN ( fix ( vlax-curve-getEndParam plineobj ) ) )
( setq i 0 )
( while ( <= i nodeN )
;( princ ( vla-getBulge plineobj i ) )
( vla-GetWidth plineobj i 'startwidth 'endwidth )
( princ "\n" )
( princ startwidth )
( princ "\n" )
( princ endwidth )
( setq i ( 1+ i ) )
)
( princ )
)
( defun bulge (startpt endpt targetpt initbulge / bulge1 bulge2 delth dis1 dis2 dis3 radius verticalline1 verticalline2 )
( setq dis1 ( distance startpt endpt ) )
( setq dis2 ( distance startpt targetpt ) )
( setq dis3 ( distance targetpt endpt ) )
( cond ( ( and ( /= initbulge 0 )
( /= dis1 0 )
( /= dis2 0 )
( /= dis3 0 )
)
( progn
( setq deltH (* initbulge 0.5 dis1 ) )
( setq radius ( / ( + ( expt deltH 2 ) ( expt ( * 0.5 dis1 ) 2 ) ) ( * 2 deltH ) ) )
( setq verticalline1 ( sqrt ( - ( expt radius 2 ) ( expt ( * 0.5 dis2 ) 2 ) ) ) )
( setq bulge1 ( / ( * 2 ( - radius verticalline1 ) ) dis2 ) )
( setq verticalline2 ( sqrt ( - ( expt radius 2 ) ( expt ( * 0.5 dis3 ) 2 ) ) ) )
( setq bulge2 ( / ( * 2 ( - radius verticalline2 ) ) dis3 ) )
( list bulge1 bulge2 )
)
)
( ( and ( /= initbulge 0 )
( /= dis1 0 )
( = dis2 0 )
( /= dis3 0 )
)
( list 0 initbulge )
)
( ( and ( /= initbulge 0 )
( /= dis1 0 )
( /= dis2 0 )
( = dis3 0 )
)
( list initbulge 0 )
)
( t
( list 0 0 )
)
)
)
( defun c:plb ( )
( princ "\n选择多段线:" )
( setq entname ( ssname ( ssget ) 0 ) )
( princ "\n选择打断点:" )
( setq pt ( getpoint ) )
( setq targetpt ( vlax-curve-getClosestPointTo entname pt ) )
( if ( and ( equal ( car pt ) ( car targetpt ) 0.000001 )
( equal ( cadr pt ) ( cadr targetpt ) 0.00001 )
)
( lwplbreak ( vlax-ename->vla-object entname ) pt)
( princ "指定点不在多段线上！" )
)
)
( defun lwplbreak(plineobj pt / bulge_j bulge_k bulge_node bulges emppt i j node_i node_j noden nodes_obj2 obj2 pline1 pline2 plnode1 plnode2 ptlist1 ptlist2 targetn targetparam)
( setq targetparam ( vlax-curve-getParamAtPoint plineobj pt ) )
( setq targetN ( fix targetparam ) )
( setq nodeN ( fix ( vlax-curve-getEndParam plineobj ) ) )
( setq ptlist1 nil )
( setq ptlist2 nil )
( if ( and ( > targetparam 0 )
( < targetparam nodeN )
)
( progn
( setq i 0 )
( while ( <= i targetN )
( setq emppt ( vlax-curve-getPointAtParam plineobj i ) )
( setq ptlist1 ( cons ( reverse ( cdr ( reverse emppt ) ) ) ptlist1 ) )
( setq i ( 1+ i ) )
)
( if ( equal ( distance pt ( vlax-curve-getPointAtParam plineobj targetN ) ) 0.000001 )
( setq plnode1 ( + ( * 2 targetN ) 1 ) )
( progn
( setq ptlist1 ( cons ( reverse ( cdr ( reverse pt ) ) ) ptlist1 ) )
( setq plnode1 ( + ( * 2 ( + 1 targetN ) ) 1 ) )
)
)
( setq ptlist1 ( reverse ptlist1 ) )
( setq ptlist1 ( apply 'append ptlist1 ) )
( setq pline1 (vlax-make-safearray vlax-vbDouble ( cons 0 plnode1 ) ) )
( vlax-safearray-fill pline1 ptlist1 )
( setq j nodeN )
( while ( > j targetN )
( setq emppt ( vlax-curve-getPointAtParam plineobj j ) )
( setq ptlist2 ( cons ( reverse ( cdr ( reverse emppt ) ) ) ptlist2 ) )
( setq j ( 1- j ) )
)
( if ( equal ( distance pt ( vlax-curve-getPointAtParam plineobj ( + 1 targetN ) ) ) 0.000001 )
( setq plnode2 ( + ( * 2 ( - nodeN targetN 1 ) ) 1 ) )
( progn
( setq ptlist2 ( cons ( reverse ( cdr ( reverse pt ) ) ) ptlist2 ) )
( setq plnode2 ( + ( * 2 ( - nodeN targetN ) ) 1 ) )
)
)
( setq ptlist2 ( apply 'append ptlist2 ) )
( setq pline2 (vlax-make-safearray vlax-vbDouble ( cons 0 plnode2 ) ) )
( vlax-safearray-fill pline2 ptlist2 )
;凸度获取
( setq bulges nil )
( setq bulge_k nodeN )
( while ( >= bulge_k 0 )
( setq bulges ( cons ( vla-getbulge plineobj bulge_k ) bulges ) )
( setq bulge_k ( 1- bulge_k ) )
)
( setq bulge_node ( bulge ( vlax-curve-getPointAtParam plineobj targetN ) ( vlax-curve-getPointAtParam plineobj ( 1+ targetN ) ) pt ( nth targetN bulges ) ) )
( setq obj2 ( vla-Copy plineobj ) )
( setq pline1 ( vlax-make-variant pline1 ) )
( vla-put-Coordinates plineobj pline1 )
( setq pline2 ( vlax-make-variant pline2 ) )
( vla-put-Coordinates obj2 pline2 )
;凸度赋值
( setq node_i 0 )
( repeat ( + ( fix ( vlax-curve-getEndParam plineobj ) ) 1 )
( vla-SetBulge plineobj node_i ( nth node_i bulges ) )
( setq node_i ( 1+ node_i ) )
)
( vla-SetBulge plineobj ( - ( fix ( vlax-curve-getEndParam plineobj ) ) 1 ) ( car bulge_node ) )
( vla-SetBulge plineobj ( fix ( vlax-curve-getEndParam plineobj ) ) 0 )
( setq nodes_obj2 ( fix ( vlax-curve-getEndParam obj2 ) ) )
( setq bulge_j ( - ( length bulges ) 1 ) )
( repeat ( + ( fix ( vlax-curve-getEndParam obj2 ) ) 1 )
( vla-SetBulge obj2 nodes_obj2 ( nth bulge_j bulges ) )
( setq nodes_obj2 ( 1- nodes_obj2 ) )
( setq bulge_j ( 1- bulge_j ) )
)
( vla-SetBulge obj2 0 ( cadr bulge_node ) )
( vla-Update plineobj )
( vla-Update obj2 )
)
)
( princ )
)
( princ )
(defun c:BreakAtPoint(/ OK ENT PT)
;单点打断
(setq OK T)
(while OK
(setq ENT (entsel "\n选择打断对象"))
(if ENT
(progn
(setq PT (getpoint "\n拾取打断点"))
(if PT
(command "break" ENT "F" PT PT)
(setq OK nil)
)
)
(setq OK nil)
)
)
)
用系统的break命令更方便 谢谢分享，收藏 guohq 发表于 2023-6-14 09:54
用系统的break命令更方便
(defun c:tt ()
"单点打断"
(while (setq ent (entsel "\n选择打断对象<退出>: "))
(if (setq pt (getpoint "\n拾取打断点<退出>: "))
(command "break" ent "f" pt pt)
)
)
(princ)
)
谢谢分享，收藏 按 X 不是更快捷吗？ 思路很清晰，程序值得学习，关于程序不能单从实现的功能来评价值不值得，的确系统自带有打断命令，但是该命令有较多局限性，比如打断之后没办法直接返回打断后的图元，但是楼主这个稍微修改一下就可以，对于二次开发来说很有价值 xyp1964 发表于 2023-6-14 12:17
(defun c:tt ()
"单点打断"
(while (setq ent (entsel "\n选择打断对象: "))
:handshake 走火入魔了……
页:
[1]
2