动态多重复制

KO你

原帖http://bbs.mjtd.com/forum.php?mo ... hlight=%B8%B4%D6%C6
参考狼大的多重复制优化了一下，目前遇到的问题和狼版的一样，
有时同方向复制空格多了，会出现重复复制到同个位置重叠，
有时又没问题，不知道是什么原因。
分享给大家使用。可以一起探讨解决
快捷键  cc  多重复制
(defun c:cc (/ *error* ent lastEnt basePt nextPt dist ang ss userError)
(princ "动态多重复制\n")
(defun *error* (msg)
(command ".UNDO" "E")
(setvar "osmode" oldSnap)
(setq *error* userError))
(setq oldSnap (getvar "osmode")
userError *error*
*error* *error*
cmdEcho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(if (and (setq ss (ssget))
(setq basePt (getpoint "\n指定基点: ")))
(progn
(command ".UNDO" "BE")
(setq dist nil ang 0)
(while (princ "\n指定下一点或距离: ")
(if dist (princ (strcat "<" (rtos dist) ">: ")))
(setq lastEnt (entlast))
(command ".copy" ss "" basePt pause)
(setq nextPt (getvar "lastpoint"))
(command ".erase" (ssdelDraft lastEnt) "")
(if (equal basePt nextPt 1e-8)
(setq nextPt (polar basePt ang dist))
(setq dist (distance basePt nextPt)
ang (angle basePt nextPt)))
(setq lastEnt (entlast))
(command ".copy" ss "" basePt nextPt)
(setq ss (ssdelDraft lastEnt)
basePt nextPt))
(command ".UNDO" "E")))
(setvar "osmode" oldSnap)
(setq *error* userError)
(princ))
(defun ssdelDraft (ent / ss entData)
(setq ss (ssadd))
(while (setq ent (entnext ent))
(setq entData (entget ent))
(if (not (wcmatch (cdr (assoc 0 entData)) "ATTRIB,VERTEX,SEQEND"))
(ssadd ent ss)))ss)

hubeiwdlue

院长说的对，捕捉的问题，还有就是把容差取大一点点试一下

KO你

hubeiwdlue 发表于 2025-6-26 15:41
院长说的对，捕捉的问题，还有就是把容差取大一点点试一下

(defun c:cc (/ *error* ent lastEnt basePt nextPt dist ang ss userError)
(princ "动态多重复制\n")
(defun *error* (msg)
(command ".UNDO" "E")
(setvar "osmode" oldSnap);;这里的oldSnap改成0,或者这行都删掉
(setq *error* userError))
(setq oldSnap (getvar "osmode")
userError *error*
*error* *error*
cmdEcho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(if (and (setq ss (ssget))
(setq basePt (getpoint "\n指定基点: ")))
(progn
(command ".UNDO" "BE")
(setq dist nil ang 0)
(while (princ "\n指定下一点或距离: ")
(if dist (princ (strcat "<" (rtos dist) ">: ")))
(setq lastEnt (entlast))
(command ".copy" ss "" basePt pause)
(setq nextPt (getvar "lastpoint"))
(command ".erase" (ssdelDraft lastEnt) "")
(if (equal basePt nextPt 1e-8)
(setq nextPt (polar basePt ang dist))
(setq dist (distance basePt nextPt)
ang (angle basePt nextPt)))
(setq lastEnt (entlast))
(command ".copy" ss "" basePt nextPt)
(setq ss (ssdelDraft lastEnt)
basePt nextPt))
(command ".UNDO" "E")))
(setvar "osmode" oldSnap);;这里的oldSnap改成0,或者这行都删掉
(setq *error* userError)
(princ))
(defun ssdelDraft (ent / ss entData)
(setq ss (ssadd))
(while (setq ent (entnext ent))
(setq entData (entget ent))
(if (not (wcmatch (cdr (assoc 0 entData)) "ATTRIB,VERTEX,SEQEND"))
(ssadd ent ss)))ss)
请问是否这样修改

以下修改是完全没有捕捉设置，复制对象捕捉不到点，已经失去功能的意义
(defun c:cc (/ *error* ent lastEnt basePt nextPt dist ang ss userError oldSnap)
(princ "动态多重复制\n")
(defun *error* (msg)
(command ".UNDO" "E")
(if oldSnap (setvar "osmode" oldSnap))  ; 确保恢复捕捉设置
(setq *error* userError)
(princ))
(setq userError *error*
oldSnap (getvar "osmode")
cmdEcho (getvar "cmdecho"))
(setvar "cmdecho" 0)  
(if (and (setq ss (ssget))
(setq basePt (getpoint "\n指定基点: ")))
(progn
(command ".UNDO" "BE")
(setq dist nil ang 0)
(setvar "osmode" 0)  ; 关键修改：关闭对象捕捉   
(while (princ "\n指定下一点或距离: ")
(if dist (princ (strcat "<" (rtos dist) ">: ")))
(setq lastEnt (entlast))
(command ".copy" ss "" basePt pause)
(setq nextPt (getvar "lastpoint"))
(command ".erase" (ssdelDraft lastEnt) "")
(if (equal basePt nextPt 1e-8)
(setq nextPt (polar basePt ang dist))
(setq dist (distance basePt nextPt)
ang (angle basePt nextPt)))   
(setq lastEnt (entlast))
(command ".copy" ss "" basePt nextPt)
(setq ss (ssdelDraft lastEnt)
basePt nextPt))
(command ".UNDO" "E")))
(setvar "osmode" oldSnap)  ; 恢复原始捕捉设置
(setq *error* userError)
(princ))
(defun ssdelDraft (ent / ss entData)
(setq ss (ssadd))
(while (setq ent (entnext ent))
(setq entData (entget ent))
(if (not (wcmatch (cdr (assoc 0 entData)) "ATTRIB,VERTEX,SEQEND"))
(ssadd ent ss)))ss)

alexmai

论坛有“文字递增lsp”同样达到你的目的，找不到原帖：

;;;;文字递增
(defun c:tz nil (IncArray   t)) ;; Dynamic Version

(defun IncArray

  ( dyn / *error* _splitstring _increment _ss->lst _copyvector dx gr i ls nl nx ob p0 p1 pd pw px vx )

  (defun *error* ( msg )
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " msg " **")))
    (redraw) (princ)
  )

  (defun _SplitString ( str / _isString _isNumber lst )
    ;; Original by Gile, modified by Lee Mac
   
    (defun _isString ( x lst / tmp )   
      (cond
        ( (null lst) (list x)
        )        
        ( (< 47 (car lst) 58)         
          (cons x (_isNumber (chr (car lst)) (cdr lst)))
        )      
        ( (= 45 (car lst))         
          (if
            (and (cadr lst)
              (numberp (read (setq tmp (strcat "-" (chr (cadr lst))))))
            )
            (cons x (_isNumber tmp (cddr lst)))
            (_isString (strcat x (chr (car lst))) (cdr lst))
          )
        )      
        ( (_isString (strcat x (chr (car lst))) (cdr lst)))
      )
    )
    (defun _isNumber ( x lst / tmp )   
      (cond
        ( (null lst) (list x)
        )        
        ( (= 46 (car lst))         
          (if
            (and (cadr lst)
              (numberp (read (setq tmp (strcat x "." (chr (cadr lst))))))
            )         
            (_isNumber tmp (cddr lst))
            (cons x (_isString (chr (car lst)) (cdr lst)))
          )
        )
        ( (< 47 (car lst) 58)         
          (_isNumber (strcat x (chr (car lst))) (cdr lst))
        )      
        ( (cons x (_isString (chr (car lst)) (cdr lst))))
      )
    )
    (if (setq lst (vl-string->list str))
      (
        (if
          (or
            (and (= 45 (car lst)) (< 47 (cadr lst) 58))
            (< 47 (car lst) 58)
          )
          _isNumber _isString
        )
        (chr (car lst)) (cdr lst)
      )
    )
  )

  (defun _increment ( str inc / num prc )
    (cond
      ( (eq (type (read str)) 'INT)
        (setq num (itoa (+ (atoi str) inc)))
        (repeat (- (strlen str) (strlen num))
          (setq num (strcat "0" num))
        )
        num
      )
      ( (eq (type (read str)) 'REAL)
        (setq prc (- (strlen str) (vl-string-position 46 str) 1)
              num (rtos (+ (atof str) inc) 2 prc)
        )
        (repeat (- (vl-string-position 46 str) (vl-string-position 46 num))
          (setq num (strcat "0" num))
        )
        (repeat (- prc (- (strlen num) (vl-string-position 46 num) 1))
          (setq num (strcat num "0"))
        )
        num
      )
      ( str )
    )
  )

  (defun _ss->lst ( ss / i lst obj )
    (if ss
      (repeat (setq i (sslength ss))
        (setq lst
          (cons
            (cons
              (setq obj (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
              (cond
                ( (wcmatch (vla-get-objectname obj) "AcDb*Text,AcDbMLeader")
                  (list
                    (cons 'textstring (_SplitString (vla-get-TextString obj)))
                  )
                )
                ( (wcmatch (vla-get-objectname obj) "AcDb*Dimension")
                  (list
                    (cons 'textoverride (_SplitString (vla-get-textoverride obj)))
                  )
                )
                ( (eq "AcDbAttributeDefinition" (vla-get-objectname obj))
                  (list
                    (cons 'tagstring    (_SplitString (vla-get-TagString    obj)))
                    (cons 'promptstring (_SplitString (vla-get-promptstring obj)))
                    (cons 'textstring   (_SplitString (vla-get-TextString   obj)))
                  )
                )
                ( (and
                    (eq "AcDbBlockReference" (vla-get-objectname obj))
                    (eq :vlax-true (vla-get-hasattributes obj))
                  )
                  (mapcar
                    (function
                      (lambda ( a )
                        (cons 'textstring (_SplitString (vla-get-textstring a)))
                      )
                    )
                    (vlax-invoke obj 'getattributes)
                  )
                )
              )
            )
            lst
          )
        )
      )
    )
  )

  (defun _CopyVector ( objs vec n / i base lst ) (setq i 1 base (vlax-3D-point '(0.0 0.0 0.0)))
    (repeat n
      (foreach obj objs
        (vla-move (car (setq lst (cons (vla-copy (car obj)) lst))) base
          (vlax-3D-point (mapcar '* vec (list i i i)))
        )
        (if
          (and
            (eq "AcDbBlockReference" (vla-get-objectname (car obj)))
            (eq :vlax-true (vla-get-hasattributes (car obj)))
          )
          (mapcar
            (function
              (lambda ( a b )
                (vl-catch-all-apply 'vlax-put-property
                  (list a (car b)
                    (apply 'strcat
                      (mapcar (function (lambda ( c ) (_increment c i))) (cdr b))
                    )
                  )
                )
              )
            )
            (vlax-invoke (car lst) 'getattributes)
            (cdr obj)
          )
          (foreach prop (cdr obj)
            (vlax-put-property (car lst) (car prop)
              (apply 'strcat
                (mapcar (function (lambda ( a ) (_increment a i))) (cdr prop))
              )
            )
          )
        )
      )
      (setq i (1+ i))
    )
    lst
  )

  (if
    (and
      (setq ls (_ss->lst (ssget "_" '((0 . "~VIEWPORT")))))
      (setq p0 (getpoint "\nBase Point: "))
      (setq px (getpoint "\nArray Vector: " p0))
      (setq pw (trans p0 1 0)
            pd (trans p0 1 3)
            vx (trans (mapcar '- px p0) 1 0 t)
            dx (distance '(0. 0. 0.) vx)
      )
      (not (equal dx 0.0 1e-14))
    )
    (cond
      ( dyn
        (princ "\nArray Endpoint: ")
        (while (= 5 (car (setq gr (grread 't 13 0)))) (redraw)
          (setq ob  (car (mapcar 'vla-delete ob))
                nx  (fix (setq nl (/ (caddr (trans (mapcar '- (cadr gr) p0) 1 vx t)) dx)))
                ob  (_copyvector ls (mapcar (if (minusp nx) '- '+) vx) (abs nx))
          )
          (grvecs (list -3 '(0. 0. 0.) (mapcar '* (trans vx 0 3) (list nl nl nl)))
            (list
              (list 1. 0. 0. (car   pd))
              (list 0. 1. 0. (cadr  pd))
              (list 0. 0. 1. (caddr pd))
              (list 0. 0. 0. 1.)
            )
          )
        )
        (redraw)
      )
      ( (setq p1 (getpoint p0 "\nArray Endpoint: "))
        (setq nx (fix (/ (caddr (trans (mapcar '- p1 p0) 1 vx t)) dx)))
        (_copyvector ls (mapcar (if (minusp nx) '- '+) vx) (abs nx))
      )
    )
  )
  (princ)
)