[分享]：複制多義線的某一段

taner

[PHP]; =============================================================================
; 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 =========================================================
[/PHP]

xlmx-whj

楼主能否请您说明下这个程序主要派什么用场谢了。

taner

最初由 xlmx-whj 发布
[B]楼主能否请您说明下这个程序主要派什么用场谢了。 [/B]

作用就是不用炸開多義直接COPY多義線的某段.

裏面有兩個不錯的函數.

eachy

只是 Explode  在程序中完成而已

狂刀

没错。
其实不用ｅｘｐｌｏｄｅ也可以的，而且可以保留宽度。。。

sincereheart

如果能够保留多义线宽度以及提供偏移功能就更好了！亟待佳音！