[求助]求从多段线偏移某个线条的lisp程序？

cj52000 · 发表于 2009-9-8 19:34:00

大家好，从某个封闭多段线偏移一个直线，一般我会把当前的封闭多段线炸开，然后选一直线偏移，能不能不用炸开就直接选一条直线偏移，这样就能节约很多时间，求这种功能的lisp，谢谢！

狂刀lxx · 发表于 2009-9-13 14:28:00

大家别笑，04年那时候还没空玩vl，vba
程序中command可以用相应另外写的函数替换

;| (plnff eplst) = 偏移多义线单段线段------------ok!!!------------------lxx.2004.7.29
说明: 1.支持polyline及lwpolyline. 2.仅可偏移单段.
参数: eplst = (entsel)返回的表.必须选中多义线!
返回: (list eplst p2 (distance p p2) el)
测试: (plnff (entsel))
|;
(defun plnff (eplst / e p1 p ent el el0 k seq plx plx2 p2 pt d)
(setq e (car eplst)
p1 (cadr eplst)
p (vlax-curve-getclosestpointto e p1);;确保取点.
ent(entget e))
(if (= "LWPOLYLINE" (cdr(assoc 0 ent))) ;;转为旧式pl格式.
(progn
(vl-cmdf "_.convertpoly" "h" e "")
(setq eL (entlast) el0 el ent (entget el) k T)
)
(setq el e el0 e)
)
(while (/= "SEQEND" (cdr(assoc 0 (setq seq (entget(setq el (entnext el))))))));;取seqend段.
(setq ent (subst (cons 70 0) (assoc 70 ent) ent) ;;改为不封闭.
plx (entget (car(nentselp p1)));;取点中段的实体表.
plx2 (entget(entnext (cdr(assoc -1 plx)))));;下一个.
(if (equal seq plx2)(setq plx2 (entget (entnext el0))));;如果是闭合段,下一个取pl线第一段.
(mapcar 'entmakex(mapcar '(lambda (y) (vl-remove-if '(lambda(x)(member (car x) '(-1 5 -2))) y))(list ent plx plx2 seq)));;生成新的pl段.
;(if k (entdel el0));;删除多余实体.
(setq pt (getpoint p "\n偏移方向及距离<输入数字or点取>:")
d (distance p pt)
el (entlast))
(vl-cmdf "_.offset" d (list el p) pt "")
;(while (/= 0 (getvar "cmdactive")) (vl-cmdf pause))
(entdel el)
(if (equal el (entlast)) nil (list eplst d (entlast)))
)

;| (plnff eplst) = 偏移多义线单段线段------------ok!!!------------------lxx.2004.7.29
说明: 1.支持polyline及lwpolyline. 2.仅可偏移单段.
参数: eplst = (entsel)返回的表.必须选中多义线!
返回: (list eplst p2 (distance p p2) el)
测试: (plnff (entsel))
|;
(defun plnff (eplst / e p1 p ent el el0  k seq plx plx2 p2 pt d)
  (setq e  (car eplst)
 p1 (cadr eplst)
 p  (vlax-curve-getclosestpointto e p1);;确保取点.
        ent(entget e))
  (if (= "LWPOLYLINE" (cdr(assoc 0 ent))) ;;转为旧式pl格式.
    (progn
      (vl-cmdf "_.convertpoly" "h" e "")
      (setq eL (entlast) el0 el ent (entget el) k T)
    )
    (setq el e el0 e)
  )
  (while (/= "SEQEND" (cdr(assoc 0 (setq seq (entget(setq el (entnext el))))))));;取seqend段.
  (setq ent (subst (cons 70 0) (assoc 70 ent) ent) ;;改为不封闭.
        plx (entget (car(nentselp p1)));;取点中段的实体表.
       plx2 (entget(entnext (cdr(assoc -1 plx)))));;下一个.
  (if (equal seq plx2)(setq plx2 (entget (entnext el0))));;如果是闭合段,下一个取pl线第一段.
  (mapcar 'entmakex(mapcar '(lambda (y) (vl-remove-if '(lambda(x)(member (car x) '(-1 5 -2))) y))(list ent plx plx2 seq)));;生成新的pl段.
  ;(if k (entdel el0));;删除多余实体.
  (setq pt (getpoint p "\n偏移方向及距离<输入数字or点取>:")
 d  (distance p pt)
 el (entlast))
  (vl-cmdf "_.offset" d (list el p) pt "")
  ;(while (/= 0 (getvar "cmdactive")) (vl-cmdf pause))
  (entdel el)
  (if (equal el (entlast)) nil (list eplst d (entlast)))
)

xyp1964 · 发表于 2009-9-13 09:04:00

;; 多段线逐段双向偏移
(defun c:test823 ()
(CMDLA0)
(xyp-MkLaCo "TEST" 1)
(SETQ DIST (UDIST 1 "" "距离<输入或鼠标直接量取>" DIST nil))
(while (setq e (entsel "\n多段线: "))
(if (member (xyp-get-dxf 0 (car e)) '("POLYLINE" "LWPOLYLINE"))
(progn
(setq a (xyp-get-Pts&Pte e)
p1 (car a)
p2 (cadr a)
S2 (XYP-ADD-LINE P1 P2)
)
(xyp-Offset (entlast) dist t t t)
)
)
)
(CMDLA1)
)

cj52000 · 发表于 2009-9-11 22:12:00

刚才我在2004下又试了一遍，还是提示上面的错误啊，请楼上的兄弟再看看啊

sailorcwx · 发表于 2009-9-9 08:33:00

将顶点找出来，创建直线

TANER · 发表于 2009-9-9 09:24:00

本帖最后由作者于 2009-9-9 9:49:35 编辑

(defun c:test (/ curve pt pt0
dt copy-polyseg t2-explode th-pt-oncurve-if
th2o th2e is-ename is-vla-object
is-string seg
)
(defun thado ()
(cond
(%$*thado*$%)
(setq %$*thado*$% (vlax-get-acad-object))
)
)
(defun thactdoc ()
(cond
(%$*thactdoc*$%)
(setq %$*thactdoc*$% (vla-get-activedocument (thado)))
)
)
(defun copy-polyseg (poly pt / olst seg)
(setq olst (t2-explode (th2o poly) nil))
(foreach each olst
(if (not (th-pt-oncurve-if (th2e each) (osnap pt "_nea")))
(vla-delete each)
(setq seg each)
)
)
seg
)
(defun t2-explode (obj del / expmde olst)
(setq expmde (getvar "EXPLMODE"))
(setq obj (th2o obj))
(setvar "EXPLMODE" 1)
(setq olst (vlax-invoke obj 'explode))
(if del
(vla-delete obj)
)
(setvar "EXPLMODE" expmde)
olst
)
(defun th-pt-oncurve-if (curve pt)
(and
curve
pt
(equal (distance pt (vlax-curve-getclosestpointto curve pt))
0
1e-6
)
)
)
(defun th2o (object)
(cond
((is-ename object)
(vlax-ename->vla-object object)
)
((is-vla-object object)
object
)
((is-string object)
(vl-catch-all-apply
'(lambda ()
(vla-handletoobject (thactdoc) object)
)
)
)
(t
nil
)
)
)
(defun th2e (object)
(cond
((is-ename object)
object
)
((is-vla-object object)
(vlax-vla-object->ename object)
)
((is-string object)
(vl-catch-all-apply
'(lambda ()
(vlax-vla-object->ename
(vla-handletoobject
(thactdoc)
object
)
)
)
)
)
(t
nil
)
)
)
(defun is-ename (arg)
(equal (type arg) 'ename)
)
(defun is-vla-object (obj)
(equal (type obj) 'vla-object)
)
(defun is-string (arg)
(equal (type arg) 'str)
)
(if (and
(setq p (entsel "\n点取多义线:"))
(setq pt0 (getpoint "\n偏移方向:"))
(setq dt (getdist "\n偏移距离:"))
)
(progn
(setq curve (car p)
pt (cadr p)
)
(setq seg (copy-polyseg curve pt))
(vl-cmdf "offset" dt (th2e seg) "_non" pt0 "")
(vla-delete seg)
)
)
(princ)
)

(defun c:test (/     curve  pt       pt0
        dt     copy-polyseg t2-explode   th-pt-oncurve-if
        th2o     th2e  is-ename     is-vla-object
        is-string    seg
       )
(defun thado ()
  (cond
    (%$*thado*$%)
    (setq %$*thado*$% (vlax-get-acad-object))
  )
)
(defun thactdoc ()
  (cond
    (%$*thactdoc*$%)
    (setq %$*thactdoc*$% (vla-get-activedocument (thado)))
  )
)
  (defun copy-polyseg (poly pt / olst seg)
    (setq olst (t2-explode (th2o poly) nil))
    (foreach each olst
      (if (not (th-pt-oncurve-if (th2e each) (osnap pt "_nea")))
 (vla-delete each)
 (setq seg each)
      )
    )
    seg
  )
  (defun t2-explode (obj del / expmde olst)
    (setq expmde (getvar "EXPLMODE"))
    (setq obj (th2o obj))
    (setvar "EXPLMODE" 1)
    (setq olst (vlax-invoke obj 'explode))
    (if del
      (vla-delete obj)
    )
    (setvar "EXPLMODE" expmde)
    olst
  )
  (defun th-pt-oncurve-if (curve pt)
    (and
      curve
      pt
      (equal (distance pt (vlax-curve-getclosestpointto curve pt))
      0
      1e-6
      )
    )
  )
  (defun th2o (object)
    (cond
      ((is-ename object)
       (vlax-ename->vla-object object)
      )
      ((is-vla-object object)
       object
      )
      ((is-string object)
       (vl-catch-all-apply
  '(lambda ()
     (vla-handletoobject (thactdoc) object)
   )
       )
      )
      (t
       nil
      )
    )
  )
  (defun th2e (object)
    (cond
      ((is-ename object)
       object
      )
      ((is-vla-object object)
       (vlax-vla-object->ename object)
      )
      ((is-string object)
       (vl-catch-all-apply
  '(lambda ()
     (vlax-vla-object->ename
       (vla-handletoobject
  (thactdoc)
  object
       )
     )
   )
       )
      )
      (t
       nil
      )
    )
  )
  (defun is-ename (arg)
    (equal (type arg) 'ename)
  )
  (defun is-vla-object (obj)
    (equal (type obj) 'vla-object)
  )
  (defun is-string (arg)
    (equal (type arg) 'str)
  )
  (if (and
 (setq p (entsel "\n点取多义线:"))
 (setq pt0 (getpoint "\n偏移方向:"))
 (setq dt (getdist "\n偏移距离:"))
      )
    (progn
      (setq curve (car p)
     pt   (cadr p)
      )
      (setq seg (copy-polyseg curve pt))
      (vl-cmdf "offset" dt (th2e seg) "_non" pt0 "")
      (vla-delete seg)
    )
  )
  (princ)
)

TANER · 发表于 2009-9-9 09:52:00

(defun c:test1 (/ ent bul dt p
pt pt0 laste th-pl-getsegat
txt-mkline th2o txt-3rd txt-4th
txt-5th
)
(defun thado ()
(cond
(%$*thado*$%)
(setq %$*thado*$% (vlax-get-acad-object))
)
)
(defun thactdoc ()
(cond
(%$*thactdoc*$%)
(setq %$*thactdoc*$% (vla-get-activedocument (thado)))
)
)
(defun th-pl-getsegat (obj p / blg p1 p2 pa pcen pn v)
(setq pn (vlax-curve-getclosestpointto obj (trans p 1 0))
pa (fix (vlax-curve-getparamatpoint obj pn))
p1 (vlax-curve-getpointatparam obj pa)
p2 (vlax-curve-getpointatparam obj (1+ pa))
)
(setq obj (th2o obj))
(setq blg (vla-getbulge obj pa))
(if (zerop blg)
(list "kLine" (list pa (1+ pa)) p1 p2)
(progn
(setq v (vlax-curve-getsecondderiv obj pa)
pcen (mapcar
'+
p1
v
)
)
(if (> blg 0)
(list "kArc" (list pa (1+ pa)) pcen p1 p2)
(list "kArc"
(list pa (1+ pa))
(mapcar
'-
p1
v
)
p2
p1
)
)
)
)
)
(defun txt-mkline (p1 p2 / ent)
(if (setq ent (entmakex (list '(0 . "LINE")
'(100 . "AcDbEntity")
'
(100 . "AcDbLine")
(cons 10 p1)
(cons 11 p2)
'(210 0. 0. 1.)
)
)
)
ent
)
)
(defun th2o (object)
(cond
((is-ename object)
(vlax-ename->vla-object object)
)
((is-vla-object object)
object
)
((is-string object)
(vl-catch-all-apply
'(lambda ()
(vla-handletoobject (thactdoc) object)
)
)
)
(t
nil
)
)
)
(defun txt-3rd (lst)
(caddr lst)
)
(defun txt-4th (lst)
(cadddr lst)
)
(defun txt-5th (lst)
(car (cddddr lst))
)
(if (and
(setq p (entsel "\n点取多义线:"))
(setq pt0 (getpoint "\n偏移方向:"))
(setq dt (getdist "\n偏移距离:"))
)
(progn
(setq ent (car p)
pt (cadr p)
)
(setq bul (th-pl-getsegat (th2o ent) (osnap pt "_nea")))
(cond
((= (car bul) "kLine")
(setq laste (txt-mkline (txt-3rd bul) (txt-4th bul)))
(vl-cmdf "_.OFFSET" dt laste "_non" pt0 "")
(entdel laste)
)
((= (car bul) "kArc")
(vl-cmdf "_.ARC"
"C"
(txt-3rd bul)
(txt-4th bul)
(txt-5th bul)
)
(setq laste (entlast))
(vl-cmdf "_.OFFSET" dt laste "_non" pt0 "")
(entdel laste)
)
)
)
)
(princ)
)

(defun c:test1 (/   ent     bul       dt p
  pt   pt0     laste     th-pl-getsegat
  txt-mkline     th2o      txt-3rd txt-4th
  txt-5th
        )
  (defun thado ()
    (cond
      (%$*thado*$%)
      (setq %$*thado*$% (vlax-get-acad-object))
    )
  )
  (defun thactdoc ()
    (cond
      (%$*thactdoc*$%)
      (setq %$*thactdoc*$% (vla-get-activedocument (thado)))
    )
  )
  (defun th-pl-getsegat (obj p / blg p1 p2 pa pcen pn v)
    (setq pn (vlax-curve-getclosestpointto obj (trans p 1 0))
   pa (fix (vlax-curve-getparamatpoint obj pn))
   p1 (vlax-curve-getpointatparam obj pa)
   p2 (vlax-curve-getpointatparam obj (1+ pa))
    )
    (setq obj (th2o obj))
    (setq blg (vla-getbulge obj pa))
    (if (zerop blg)
      (list "kLine" (list pa (1+ pa)) p1 p2)
      (progn
 (setq v    (vlax-curve-getsecondderiv obj pa)
       pcen (mapcar
       '+
       p1
       v
     )
 )
 (if (> blg 0)
   (list "kArc" (list pa (1+ pa)) pcen p1 p2)
   (list "kArc"
  (list pa (1+ pa))
  (mapcar
    '-
    p1
    v
  )
  p2
  p1
   )
 )
      )
    )
  )
  (defun txt-mkline (p1 p2 / ent)
    (if (setq ent (entmakex (list '(0 . "LINE")
      '(100 . "AcDbEntity")
      '
       (100 . "AcDbLine")
      (cons 10 p1)
      (cons 11 p2)
      '(210 0. 0. 1.)
       )
    )
 )
      ent
    )
  )
  (defun th2o (object)
    (cond
      ((is-ename object)
       (vlax-ename->vla-object object)
      )
      ((is-vla-object object)
       object
      )
      ((is-string object)
       (vl-catch-all-apply
  '(lambda ()
     (vla-handletoobject (thactdoc) object)
   )
       )
      )
      (t
       nil
      )
    )
  )
  (defun txt-3rd (lst)
    (caddr lst)
  )
  (defun txt-4th (lst)
    (cadddr lst)
  )
  (defun txt-5th (lst)
    (car (cddddr lst))
  )
  (if (and
 (setq p (entsel "\n点取多义线:"))
 (setq pt0 (getpoint "\n偏移方向:"))
 (setq dt (getdist "\n偏移距离:"))
      )
    (progn
      (setq ent (car p)
     pt (cadr p)
      )
      (setq bul (th-pl-getsegat (th2o ent) (osnap pt "_nea")))
      (cond
 ((= (car bul) "kLine")
  (setq laste (txt-mkline (txt-3rd bul) (txt-4th bul)))
  (vl-cmdf "_.OFFSET" dt laste "_non" pt0 "")
  (entdel laste)
 )
 ((= (car bul) "kArc")
  (vl-cmdf "_.ARC"
    "C"
    (txt-3rd bul)
    (txt-4th bul)
    (txt-5th bul)
  )
  (setq laste (entlast))
  (vl-cmdf "_.OFFSET" dt laste "_non" pt0 "")
  (entdel laste)
 )
      )
    )
  )
  (princ)
)

cj52000 · 发表于 2009-9-9 19:44:00

谢谢楼上兄弟的热心，但是我用了后提示错误

错误: no function definition: IS-ENAME

还有就是能不能像CAD里的偏移命令O一样，不提示偏移距离，点到哪偏到哪，如果要精确的话，输入数值就好了，其实就是CAD偏移O命令，不同的是对象现在是多段线了，点取其中一个图元，进行偏移，能改善一下就更加完美了，谢谢了！

xyp1964 · 发表于 2009-9-9 21:08:00

多段线逐段双向偏移：

cj52000 · 发表于 2009-9-9 22:07:00

各位来帮帮啊，谢谢！

cj52000 · 发表于 2009-9-11 20:36:00

我顶上去，各位来看看啊

TANER · 发表于 2009-9-11 21:23:00

3/4楼肯定可以

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

[求助]求从多段线偏移某个线条的lisp程序？

本帖子中包含更多资源

本帖子中包含更多资源