拉伸多基点po
大家好，这是否可以将具有多个基点的多段线拉伸到不同距离但方向相同？
M4rdy公司
快速回答是，使用lisp等
询问移动哪一点，您的示例将是vertice 2
使用“intersectwith”红色和绿色的新pt交点
重做调整x、y的样条线顶点
代码对不起没有任何东西。需要一些时间，其他人可能会加入。 我仍在努力，花了很多时间寻找解决方案。
但还是没有运气。
(defun c:Test1 (/ ent lst)
(if
(and (setq toLine (vlax-ename->vla-object (car (entsel "\nSelect Line: "))))
(setq p1 (getpoint "\nSpecify First Point: "))
(setq p2 (getpoint "\nSpecify Second Point: " p1))
(setq ss (apply 'ssget
(append (list "_C")
(mapcar '(lambda (foo) (apply 'mapcar (cons foo (list p1 p2))))
'(min max)
)
(list '((0 . "*LINE")))
)
)
)
(setq lst0 ((lambda (l / i)
(setq i (lm:getobjintersectionsinss l ss))
(vla-delete l)
i
)
(vlax-ename->vla-object
(entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)))
)
)
)
)
(progn
(setq lst1 (mapcar 'cons (mapcar 'cadr (ssnamex ss)) lst0))
(setq i 0)
(repeat (sslength ss)
(setq e (ssname ss i))
(setq lst (cadr (at:segment int_f)))
(setq Pintobj (LM:GetIntersections
toLine
(vlax-ename->vla-object e)
)
)
(vl-cmdf "_.stretch"
ss
""
"_non"
(trans lst 0 1)
(trans (car Pintobj) 0 1)
)
(setq i (1+ i))
)
)
)
(princ)
)
(defun lm:getobjintersectionsinss (obj ss)
;; © Lee Mac 2010
((lambda (i / j a b ilst)
(while (setq e (ssname ss (setq i (1+ i))))
(setq ilst (append ilst
(lm:groupbynum (vlax-invoke obj
'intersectwith
(vlax-ename->vla-object e)
acextendnone
)
3
)
)
)
)
)
-1
)
)
(defun AT:Segment (entPnt)
;; Retreive segment number and Start & End points
;; entPnt - List with entity (ENAME or VLA-OBJECT) & point
;; Alan J. Thompson, 11.10.09 / 08.19.10 / 11.15.11
(if (vl-consp entPnt)
((lambda (e p / n)
(if (setq n (vlax-curve-getPointAtParam e (1+ p)))
(list p (list (vlax-curve-getPointAtParam e p) n))
(list p (list (vlax-curve-getPointAtParam e (1- p)) (vlax-curve-getPointAtParam e p)))
)
)
(car entPnt)
(fix (vlax-curve-getParamAtPoint
(car entPnt)
(vlax-curve-getClosestPointToProjection
(car entPnt)
(trans (cadr entPnt) 1 (car entPnt))
'(0. 0. 1.)
)
)
)
)
)
)
最终它成功了，尽管还远远不够完美。
(defun c:Test2 (/ toLine p1 p2 ss lst0 lst1 Pintobj vtx_pline list_vtx_pline)
(if
(and (setq toLine
(vlax-ename->vla-object (car (entsel "\nSelect Line: ")))
)
(setq p1 (getpoint "\nSpecify First Point: "))
(setq p2 (getpoint "\nSpecify Second Point: " p1))
(setq ss
(apply
'ssget
(append
(list "_C")
(mapcar
'(lambda (foo) (apply 'mapcar (cons foo (list p1 p2))))
'(min max)
)
(list '((0 . "*LINE")))
)
)
)
(setq
lst0 ((lambda (l / i)
(setq i (lm:getobjintersectionsinss l ss))
(vla-delete l)
i
)
(vlax-ename->vla-object
(entmakex
(list (cons 0 "LINE") (cons 10 p1) (cons 11 p2))
)
)
)
)
) ;_and
(progn
;; Find intersection between line and selection
(setq Pintobj (lm:getobjintersectionsinss toLine ss))
;;(princ Pintobj) ;_for testing
(setq cadrm (mapcar 'cadr (ssnamex ss)))
;; Make list (ename point_intersection)
(setq lst1 (mapcar 'list cadrm lst0))
(foreach n lst1
(setq p (fix
(vlax-curve-getparamatpoint
(car n)
(vlax-curve-getclosestpointtoprojection
(car n)
(trans (cadr n) 1 0)
'(0.0 0.0 1.0)
)
)
)
) ;_setq p
(setq vtx_pline
(list
(trans (vlax-curve-getpointatparam (car n) p) 0 1)
)
)
;;(princ vtx_pline) ;_for testing
(setq list_vtx_pline (append list_vtx_pline vtx_pline)) ;_This is Start point of Selected Segment PLINES as base point of STRETCH:
) ;_foreach
;;(princ list_vtx_pline) ;_for testing
(setq data (mapcar 'list cadrm list_vtx_pline pintobj))
(foreach m data
(vl-cmdf "_.stretch"
(car m)
""
"_non"
(cadr m)
(caddr m)
)
)
) ;_progn
) ;_if
(princ)
) ;_defun
(defun lm:getobjintersectionsinss (obj ss)
;; © Lee Mac 2010
((lambda (i / j a b ilst)
(while (setq e (ssname ss (setq i (1+ i))))
(setq ilst (append ilst
(lm:groupbynum
(vlax-invoke
obj
'intersectwith
(vlax-ename->vla-object e)
acextendnone
)
3
)
)
)
)
)
-1
)
)
;;Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
(defun LM:GroupByNum (l n / r)
(if l
(cons
(reverse (repeat n
(setq r (cons (car l) r)
l (cdr l)
)
r
)
)
(LM:GroupByNum l n)
)
)
)
仔细想想，我几乎把它缩短了很多，但它有两个缺陷，要求垂直位置，第二个更重要的是，一旦柱脚旋转，需要完全不同的方法。现在考虑使用UCS可以解决这个问题。还需要选择要移动的末端是向左还是向右？这可以很容易地通过反转pline垂直顺序来实现，它是否超过了新的int点。
这里有一个更好的方法来做选线部分，我猜这是一条临时线，如果它已经存在，那么只需选线并使用围栏。再加上一种不同的开始方式。
(setq pt1 (getpoint "Pick 1st crossing point"))
(setq pt2 (getpoint Pt1 "Pick 2nd crossing point"))
(setq vert (getint "Enter vertice position 2+ etc ")) ; do a left or right here pick end instead.
(setq ss (ssget "F" (list pt1 pt2))) ; selection set of plines
(command "Line" pt1 pt2 "") ; do after select or else line is added
(setq objL (vlax-Ename->Vla-Object (entlast))) ; saves line object for intersect erase at end.
; pline co-ords example
; By Alan H
(defun getcoords (ent)
(vlax-safearray->list
(vlax-variant-value
(vlax-get-property
(vlax-ename->vla-object ent)
"Coordinates"
)
)
)
)
; work in progress
(repeat (setq K (sslength ss)) ; loop through
(setq co-ords (getcoords (ssname ss (setq k (- k 1))))) ; pline co-ords ; uses getcoords defun
(setq objpl (vlax-Ename->Vla-Object (ssname ss k)))
(setq intpt1 (vlax-invoke objpl 'intersectWith objL acExtendThisEntity))
(setq x (car intpt1))
(setq y (cadr intpt1))
; do the ucs bit here erase line UCS OB then oops does it work
(setq newlst '())
(setq len2 (length co-ords))
(repeat vert
(setq newlst (cons (list x (nth (setq len2 (- len2 1)) co-ords)) newlst))
) ; repeat vert
; add remaining pts
(repeat (- len2 vert)
(setq newlst (cons (list x (nth (setq len2 (- len2 1)) co-ords)) newlst))
) ; repeat remainder
; erase pline and draw new pline
(setq J 0)
(command "pline"
(repeat (length newlst)
(list (nth J newlst)(nth (+ J 1) newlst))
(setq J (+ J2))
)
) ;repeat ss
一个更普遍的方法会更好，所以我们不会得到下一个帖子，“它可以被改变为在角度上”。
嗨，比格尔，
谢谢你的帮助。
我不知道我是否遗漏了什么，但如果我运行您的代码，“命令”Pline“”上有错误。
(defun c:Test2 (/ pt1 pt2 vert ss objL K co-ords objpl intpt1 x y newlst len2)
;; http://www.cadtutor.net/forum/showthread.php?97882-Stretch-multiple-base-point-polylines-to-different-distance
;; BIGAL
(setq pt1 (getpoint "Pick 1st crossing point"))
(setq pt2 (getpoint Pt1 "Pick 2nd crossing point"))
(setq vert (getint "Enter vertice position 2+ etc ")) ;_ do a left or right here pick end instead.
(setq ss (ssget "F" (list pt1 pt2))) ;_ selection set of plines
(command "Line" pt1 pt2 "") ;_ do after select or else line is added
(setq objL (vlax-Ename->Vla-Object (entlast))) ;_ saves line object for intersect erase at end.
;; pline co-ords example
;; By Alan H
(defun getcoords (ent)
(vlax-safearray->list
(vlax-variant-value
(vlax-get-property
(vlax-ename->vla-object ent)
"Coordinates"
) ;_end of vlax-get-property
) ;_end of vlax-variant-value
) ;_end of vlax-safearray->list
) ;_end of defun
;; work in progress
(repeat (setq K (sslength ss)) ;_ loop through
(setq co-ords (getcoords (ssname ss (setq k (- k 1))))) ;_ pline co-ords ; uses getcoords defun
(setq objpl (vlax-Ename->Vla-Object (ssname ss k)))
(setq intpt1 (vlax-invoke objpl 'intersectWith objL acExtendThisEntity))
(setq x (car intpt1))
(setq y (cadr intpt1))
;; do the ucs bit here erase line UCS OB then oops does it work
(setq newlst '())
(setq len2 (length co-ords))
(repeat vert
(setq newlst (cons (list x (nth (setq len2 (- len2 1)) co-ords))
newlst
) ;_end of cons
) ;_end of setq
) ;_ repeat vert
;; add remaining pts
(repeat (- len2 vert)
(setq newlst (cons (list x (nth (setq len2 (- len2 1)) co-ords))
newlst
) ;_end of cons
) ;_end of setq
) ;_ repeat remainder
;; erase pline and draw new pline
(setq J 0)
(command "pline"
(repeat (length newlst)
(list (nth J newlst) (nth (+ J 1) newlst))
(setq J (+ J 2))
) ;_end of repeat
) ;_end of command
) ;_repeat ss
(princ)
) ;_defun
下一个“使命召唤”。。 就像上面说的“一项正在进行的工作”一样，我知道我有一项工作没有完成，但必须做一些真正的工作。周末会有时间，因为他们预计下雨，看看我能做什么。
两个规则/问题pline是否总是基本相同的形状，都有4分v的1分和3分等
页:
[1]