[LISP程序]：请大家看看,里面的问题

lsjjm

各位的都太繁琐了! 我曾经编过一个,不过几行. 照来贴上

偏移（更改命令就可以拷贝）多义线pline子段（线段或弧）的小程序
(defun c:test (/ plist pp)
(setq aa (entsel "\nSelect pline:"))
(setq bb (cadr aa))
(setq oo (getdist "\nValue of offset:"))
(vl-cmdf "explode" aa "")
(setq ss (ssget "c" (polar bb (/ pi 4) 0.01)(polar bb (* 1.25 pi) 0.01)))
(vl-cmdf "offset" oo bb (getpoint "\nInput offset point:") "")
(setq dd (entget (entlast)))
(vl-cmdf "undo" 2 "")
(entmake (cdr dd))
);defun

aeo

最初由 zhynt 发布
[B]我看了上面的图片，觉得直线段还行，但是弧线段更象是平移而不是偏移。如图：平移和偏移的区别 [/B]

要offset也简单:
(command "move"..)那一行换成offset,再(entdel f)

今天加了几行字,支持旧pline线,和spline.
现在重贴

2. 
   
3. (defun c:copypl (/ e ee from to copypl dxf)
   
4. (defun dxf(a b)(cdr(assoc a b)))
   
5. (prompt "\nBY AEO ,一定要选"*POLYLINE" ")
   
6.   (defun copypl (e from to / a b en f is j len li)
   
7.     (defun make-pl (ptn / li)
   
8.       (setq li (append
   
9.                  (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '
   
10.                        (100 . "AcDbPolyline") (cons 90 2)
    
11.                 )ptn))
    
12.       (entmake li)(entlast)
    
13.     )
    
14.     (setq en (entget e)is (dxf 70 en) li '() )
    
15.     (if(= (dxf 0 en)"POLYLINE")
    
16.       (progn
    
17.        (while (/= "SEQEND"(dxf 0(setq en(entget(setq e(entnext e))))))
    
18.         (setq li (cons(list(assoc 10 en)(assoc 40 en)(assoc 41 en)(assoc 42 en)) li))
    
19.        )
    
20.        ;(setq li(reverse li))
    
21.       )
    
22.       (progn  
    
23.        (setq en(member (assoc 10 en) en) li '())
    
24.        (while (>= (length en) 4)
    
25.         (setq a (list (car en) (cadr en) (caddr en) (cadddr en))
    
26.               en (cddddr en)li (cons a li)
    
27.         )
    
28.        )
    
29.     ) )
    
30.     (if (= is 1)
    
31.       (setq li (reverse (cons (last li) li)))
    
32.       (setq li (reverse li))
    
33.     )
    
34.     (setq a(car li)li(cdr li)j 0 len(length li))
    
35.     (while (< j len)
    
36.       (setq b (nth j li)
    
37.             f (make-pl (append a b))
    
38.       )
    
39.       (if (vlax-curve-getParamAtPoint (vlax-ename->vla-object f) from)
    
40.         (progn(setq j len)(command "move" f "" from to))
    
41.         (entdel f)
    
42.       )
    
43.       (setq j (1+ j) a b)
    
44.     )
    
45.   )
    
46.   (if (and
    
47.         (setq ee (entsel"\n选多义线:"))
    
48.         (setq e (car ee) from (cadr ee))
    
49.         (wcmatch  (dxf 0 (entget e))"*POLYLINE")
    
50.         (setq from (vlax-curve-getClosestPointTo
    
51.                         (vlax-ename->vla-object e)from
    
52.                    )
    
53.         )
    
54.         (setq to (getpoint from "\nCopy To:"))
    
55.       )
    
56.     (copypl e from to)
    
57.   )
    
58.   (princ)
    
59. )
    

<br /> (defun c:copypl (/ e ee from to copypl dxf)<br /> (defun dxf(a b)(cdr(assoc a b)))<br /> (prompt "\nBY AEO ,一定要选"*POLYLINE" ")<br />   (defun copypl (e from to / a b en f is j len li)<br />     (defun make-pl (ptn / li)<br />       (setq li (append<br />                  (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '<br />                        (100 . "AcDbPolyline") (cons 90 2)<br />                 )ptn))<br />       (entmake li)(entlast)<br />     )<br />     (setq en (entget e)is (dxf 70 en) li '() )<br />     (if(= (dxf 0 en)"POLYLINE")<br />       (progn<br />        (while (/= "SEQEND"(dxf 0(setq en(entget(setq e(entnext e))))))<br />         (setq li (cons(list(assoc 10 en)(assoc 40 en)(assoc 41 en)(assoc 42 en)) li))<br />        )<br />        ;(setq li(reverse li))<br />       ) <br />       (progn  <br />        (setq en(member (assoc 10 en) en) li '())<br />        (while (>= (length en) 4)<br />         (setq a (list (car en) (cadr en) (caddr en) (cadddr en))<br />               en (cddddr en)li (cons a li)<br />         )<br />        )<br />     ) )<br />     (if (= is 1)<br />       (setq li (reverse (cons (last li) li)))<br />       (setq li (reverse li))<br />     )<br />     (setq a(car li)li(cdr li)j 0 len(length li))<br />     (while (< j len)<br />       (setq b (nth j li)<br />             f (make-pl (append a b))<br />       )<br />       (if (vlax-curve-getParamAtPoint (vlax-ename->vla-object f) from)<br />         (progn(setq j len)(command "move" f "" from to))<br />         (entdel f)<br />       )<br />       (setq j (1+ j) a b)<br />     )<br />   )<br />   (if (and<br />         (setq ee (entsel"\n选多义线:"))<br />         (setq e (car ee) from (cadr ee))<br />         (wcmatch  (dxf 0 (entget e))"*POLYLINE")<br />         (setq from (vlax-curve-getClosestPointTo<br />                         (vlax-ename->vla-object e)from<br />                    )<br />         )<br />         (setq to (getpoint from "\nCopy To:"))<br />       )<br />     (copypl e from to)<br />   )<br />   (princ)<br /> )<br />

XDSoft

最初由 lsjjm 发布
[B]各位的都太繁琐了! 我曾经编过一个,不过几行. 照来贴上

偏移（更改命令就可以拷贝）多义线pline子段（线段或弧）的小程序
(defun c:test (/ plist pp)
(setq aa (entsel "\nSelect pline:"))
(setq bb (cadr a... [/B]

构造选择集的时候

2. 
   
3. (setq ss (ssget "c" (polar bb (/ pi 4) 0.01)(polar bb (* 1.25 pi) 0.01)))
   

<br /> (setq ss (ssget "c" (polar bb (/ pi 4) 0.01)(polar bb (* 1.25 pi) 0.01)))<br />

建议不要用具体的数字0.01,这样有可能选不到，因为屏幕有可能画的很大，很小。

建议用当然拾取框的高度代替，通过系统变量 viewsize,screensize,pickbox等等得到拾取框的高度值，这样就可以适合任何屏幕大小了。

另： 你的

2. 
   
3. (vl-cmdf "offset" oo bb (getpoint "\nInput offset point:") "")

<br /> (vl-cmdf "offset" oo bb (getpoint "\nInput offset point:") "")

这行是不是有BUG

LUCAS

最初由 aeo 发布
[B]

要offset也简单:
(command "move"..)那一行换成offset,再(entd... [/B]

2. 
   
3. ...........
   
4. (progn
   
5.        (while (/= "SEQEND"(dxf 0(setq en(entget(setq e(entnext e))))))
   
6.         (setq li (cons(list(assoc 10 en)(assoc 40 en)(assoc 41 en)(assoc 42 en)) li))
   
7.        )
   
8.       ;;; (setq li(reverse li));;;;;;應取消
   
9.       )
   
10. ...........
    

<br /> ...........<br /> (progn<br />        (while (/= "SEQEND"(dxf 0(setq en(entget(setq e(entnext e))))))<br />         (setq li (cons(list(assoc 10 en)(assoc 40 en)(assoc 41 en)(assoc 42 en)) li))<br />        )<br />       ;;; (setq li(reverse li));;;;;;應取消<br />       ) <br /> ...........<br />

aeo

LUCAS :
是的,
我改掉了
对直线不去掉也对的,以为就对了.
弧就不行了,两个时间写就是不好.

PFD8667

4楼的真好用,但输入这一行命令有点麻烦.

梦断江南

翻个旧贴测试一下:
lsjjm的:拷贝的段位不对?可惜没保留宽度信息.
lucas的,无宽度信息,对pl,lwpl有效
mmmm的:测试时候出错.
xd的:对pl,lwpl有效,保留宽度信息,但是宽度好像有错.我测试的是前后宽度不等的弧段
aeo的:对pl,lwpl有效,操作直观,没有发现其它bug,是测试的程序里面效果最好的.要是改进一下,拷贝出来的时候动态显示.就更完美了.
结论:
推荐使用aeo的程序.

ll_j

江南斑竹最近怎么想起翻旧帖子看了？
我这里也有一个类似的，与本主题同期的（pi.lsp，http://xdcad.net/forum/showthrea ... d=285584#post285584），是支持R14的（没有精力学习VL了），如果有必要以后可以增加对Polyline的支持）。

梦断江南

测了你程序,集成了几个功能,不错:)
拷贝和偏移的时候,步骤多了一些,应该点击线段后,再点一下就可以拷贝或偏移.不用去问输入距离或在哪一边偏移什么的.
还可再改进哦;)

taner

; =============================================================================
; Filename    :   CopyPlineSeg.lsp
; Datum       :   23.08.04
; Author      :   jme
; Copyright   :   MENZI ENGINEERING GmbH, Switzerland
; Revision  1 :   19.01.05 jme - Basepoint for copy imroved
;                              - Checking for A2k+ added
; Revision  2 :   __.__.__ ___ -
; -----------------------------------------------------------------------------
; Known bugs:
; - None
; -----------------------------------------------------------------------------
; Description:
; Copies a segment of a Polyline.
; -----------------------------------------------------------------------------
; Global variables:
;
; -----------------------------------------------------------------------------
; Internal LISP-functions:
; MeGetObjLength  MeSelPline
; -----------------------------------------------------------------------------
; External LISP-functions:
;
; -----------------------------------------------------------------------------
; Version notes:
; AutoCAD:        Version:        Language:        AddIns:
; 15+                1.01                English                ...
; -----------------------------------------------------------------------------
;
; == Message on loading =======================================================
;
(princ "\nCopyPlineSeg v1.01")
;
; == Main =====================================================================
;
(defun C:CopyPlineSeg ( / BasPnt CpyEnt CpyObj CpySet CurObj CurEnt ObjLen
                          ObjLst OldCmd PicPnt PntDst *Error*)
(if (< (atof (getvar "ACADVER")) 15.0)
  (progn
   (alert "CopyPlineSeg requires AutoCAD 2000 or higher. ")
   (princ)
  )
  (progn
   (vl-load-com)
   (setq OldCmd (getvar "CMDECHO")
         CurEnt (MeSelPline "\nSelect Polyline segment: " T nil)
   )
   (defun *Error* (Msg)
    (setvar "CMDECHO" OldCmd)
    (if Msg (princ Msg))
    (princ)
   )
   (if CurEnt
    (progn
     (setq CurObj (vlax-ename->vla-object (car CurEnt))
           PicPnt (vlax-curve-getClosestPointTo CurObj (cadr CurEnt))
           ObjLst (vlax-invoke CurObj 'Explode)
     )
     (vla-put-Visible CurObj :vlax-false)
     (mapcar 'vla-Update ObjLst)
     (if (setq CpyEnt (nentselp PicPnt))
      (progn
       (vla-put-Visible CurObj :vlax-true)
       (setq CpyObj (vlax-ename->vla-object (car CpyEnt))
             ObjLen (MeGetObjLength CpyObj)
             PntDst (vlax-curve-getDistAtPoint CpyObj PicPnt)
             BasPnt (cond
                     ((<= PntDst (/ ObjLen 3.0))
                      (vlax-curve-getStartPoint CpyObj)
                     )
                     ((>= PntDst (/ ObjLen 1.5))
                      (vlax-curve-getEndPoint CpyObj)
                     )
                     ((vlax-curve-getPointAtDist CpyObj (/ ObjLen 2.0)))
                    )
       )
       (foreach Obj ObjLst
        (if (not (equal Obj CpyObj)) (vla-delete Obj))
       )
       (setvar "CMDECHO" 0)
       (vl-cmdf "_.MOVE" (car CpyEnt) "")
       (setvar "CMDECHO" 1)
       (vl-cmdf BasPnt pause)
      )
      (vla-put-Visible CurObj :vlax-true)
     )
    )
   )
   (*Error* nil)
  )
)
)
;
; == Subs =====================================================================
;
; -- Function MeGetObjLength
; Returns the length of all kind of objects.
; Arguments [Type]:
;   Obj = Object [VLA-OBJECT]
; Return [Type]:
;   > Length of the object [REAL]
; Notes:
;   - Proceedes *Polylines, Splines, Lines, Arcs, Circles and Ellipses
;
(defun MeGetObjLength (Obj)
(vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj))
)
;
; -- Function MeSelPline
; Extended Polyline selection function.
; Arguments [Type]:
;   Pmt = User prompt [STR]
;   3Dp = 3Dpolyline flag (3Dpolyline allowed) [SYM]
;   Cls = Close flag (pline must be closed) [SYM]
; Return [Type]:
;   > List with entity name and pickpoint '((Ename (x y z)) [LIST]
; Notes:
;   - Returns nil when user press 'Return' or 'Space'
;
(defun MeSelPline (Pmt 3Dp Cls / CurEnt EntFlg EntLst EntNme ExLoop)
(while (not ExLoop)
  (initget " ")
  (setq CurEnt (entsel Pmt))
  (cond
   ((= CurEnt "") (setq ExLoop T CurEnt nil))
   (CurEnt
    (setq EntLst (entget (car CurEnt))
          EntNme (cdr (assoc  0 EntLst))
          EntFlg (cdr (assoc 70 EntLst))
    )
    (cond
     ((or
       (not (member EntNme '("LWPOLYLINE" "POLYLINE")))
       (and (not 3Dp) (= (logand EntFlg  8)  8))
       (= (logand EntFlg 16) 16)
       (= (logand EntFlg 64) 64)
      )
      (princ "selected entity is not a Polyline. ")
     )
     ((and Cls (/= (logand EntFlg 1) 1))
      (princ "selected Polyline is not closed. ")
     )
     ((setq ExLoop T))
    )
   )
   ((princ "1 selected, 0 found. "))
  )
)
CurEnt
)
;
; == Copyright - Note (May be never deleted) ==================================
;
(princ "\n------------------------------------------------")
(princ "\n ?004-2005 MENZI ENGINEERING GmbH, Switzerland ")
(princ "\n------------------------------------------------")
(princ "\nType CopyPlineSeg in the command line to start the programm...")
(princ)
;
; == End CopyPlineSeg =========================================================

hs9898

LUCAS 发表于 2003-5-8 10:27

看不太懂，格式很特别，慢慢消化一下吧，长姿势了

xxwoaini897

虽然不懂，但是帮顶