求助动态递增阵列增加原位递增功能

669423907

这是在论坛下的动态阵列递增程序，我自己改了一下，可以左键递增，右键递减。
哪位帮忙修改一下，在不原来的基础上，增加可以原位递增的功能（实现d1），谢谢了
(defun c:d1(/ ss p1)
(if (setq ss (ssget":e:s") )
(progn
(setq p1 (cadr(grread 3)))
(LM:incarray nil ss 1 p1 p1)
(vl-cmdf "_move" (entlast) "" "non" p1 "\\")
)
)
)


(defun c:d2(/ ss p1 p2 x_x)

(defun x_x(ss)
(if (setq p1 (getpoint (strcat "\n 指定复制基点：（左键 + 右键 -）") ) )
(if (setq p2 (getpoint p1 (strcat "\n 指定阵列间距：") ) ) (LM:incarray t ss 1 p1 p2) )
(if (and (setq p1 (getpoint (strcat "\n 指定复制基点：（递减）") ) ) (setq p2 (getpoint p1 (strcat "\n 指定阵列间距：") ) ) ) (LM:incarray t ss -1 p1 p2) )
) )

(if (ssget"i") (setq ss (ssget"i")) (setq ss (ssget) ) )

(if ss (x_x ss) )

(vl-cmdf "undo" "be")
(princ))

;www.lee-mac.com
                           阵列 对象 增量 基点 间距
(defun LM:incarray( d    ss    inc   bpt    vxu / *error* dim dis ept lst obl qty vxw)
    (defun *error* ( msg )
        (if (= 'int (type dim))
            (setvar 'dimzin dim)
        )
        (foreach obj obl
            (if (and (= 'vla-object (type obj)) (not (vlax-erased-p obj)) (vlax-write-enabled-p obj))
                (vla-delete obj)
            )
        )
        (incarray:endundo (incarray:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\n Error: " msg))
        )
        (redraw) (princ)
    )
    (setq ER NIL)
  (setq ss (cadr (ssgetfirst)))
  (if (/= nil ss ) (progn
      (setq ent (ssname ss 0))(setq obj (vlax-ename->vla-object ent) nam (vlax-get-property obj "ObjectName"))
(if (wcmatch nam "*Db*Text")
  (progn
(if (= nam "TDbText")(command "explode" ss))
(setq ER "1")
        (setenv "LMac\\incarray" (incarray:num->str inc))

)
)
    )
  )
    (incarray:startundo (incarray:acdoc))
    (setq dim (getvar 'dimzin))
    (setvar 'dimzin 0)
    (cond
        (   (not
                (and
                  (setq lst2 (ssget "p" '((0 . "~viewport"))))
                    (setq lst (incarray:selection->list lst2))
                    (progn
                        (while
                            (and
                             vxu
                                (equal bpt vxu 1e-8)
                            )
                        )
                        vxu
                    )
(setq vxu (mapcar '- vxu bpt) vxw (trans vxu 1 0 t) dis (distance '(0.0 0.0 0.0) vxw) )
                )
            )
        )
        ( d
            (while (= 5 (car (setq ept (grread t 13 0))))
                (redraw)
                (foreach obj obl (vla-delete obj))
                (setq qty (/ (caddr (trans (mapcar '- (cadr ept) bpt) 1 vxw t)) dis)
                      obl (incarray:copyvector lst (mapcar (if (minusp qty) '- '+) vxw) (abs (fix qty)) inc)
                )
                (grvecs (list -3 bpt (mapcar '(lambda ( a b ) (+ (* a qty) b)) vxu bpt)))
            )
        )
        (   (setq ept (cadr(grread 3)))
            (setq qty (fix (/ (caddr (trans (mapcar '- ept bpt) 1 vxw t)) dis)))
            (incarray:copyvector lst (mapcar (if (minusp qty) '- '+) vxw) (abs (fix qty)) inc)
        )
    )
    (setvar 'dimzin dim)
    (incarray:endundo (incarray:acdoc))
    (redraw) (princ)
)
;;----------------------------------------------------------------------
(defun incarray:num->str ( x / dim rtn )
    (if (equal x (atof (rtos x 2 0)) 1e-8)
        (rtos x 2 0)
        (progn
            (setq dim (getvar 'dimzin))
            (setvar 'dimzin 8)
            (setq rtn (vl-catch-all-apply 'rtos (list x 2 15)))
            (setvar 'dimzin dim)
            (if (not (vl-catch-all-error-p rtn)) rtn)
        )
    )
)
;;----------------------------------------------------------------------
(defun incarray:copyvector (lst vec qty inc / cnt obj obl org)
    (setq org (vlax-3D-point 0 0) cnt 1)
    (repeat qty
        (foreach itm lst
            (setq obj (vla-copy (car itm))
                  obl (cons obj obl)
            )
            (vla-move obj org (vlax-3D-point (mapcar '* vec (list cnt cnt cnt))))
            (if (= "AcDbBlockReference" (vla-get-objectname obj))
                (mapcar
                    (function
                        (lambda ( att prp )
                            (vl-catch-all-apply 'vlax-put-property
                                (list att (car prp)
                                    (apply 'strcat
                                        (mapcar '(lambda ( x ) (incarray:increment x (* cnt inc)))
                                            (cdr prp)
                                        )
                                    )
                                )
                            )
                        )
                    )
                    (vlax-invoke obj 'getattributes)
                    (cdr itm)
                )
                (foreach prp (cdr itm)
                    (vlax-put-property obj (car prp)
                        (apply 'strcat
                            (mapcar '(lambda ( x ) (incarray:increment x (* cnt inc)))
                                (cdr prp)
                            )
                        )
                    )
                )
            )
        )
        (setq cnt (1+ cnt))
    )
    obl
)
;;----------------------------------------------------------------------
(defun incarray:selection->list (sel / idx lst obj obn)
    (if sel
        (repeat (setq idx (sslength sel))
            (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                  obn (vla-get-objectname obj)
            )
            (if (and (= "AcDbBlockReference" obn) (= :vlax-true (vla-get-hasattributes obj)))
                (setq lst
                    (cons
                        (cons obj
                            (mapcar '(lambda ( a ) (vl-list* 'textstring (incarray:splitstring (vla-get-textstring a))))
                                (vlax-invoke obj 'getattributes)
                            )
                        )
                        lst
                    )
                )
                (setq lst
                    (cons
                        (cons obj
                            (mapcar '(lambda ( p ) (vl-list* p (incarray:splitstring (vlax-get-property obj p))))
                                (cond
                                    (   (wcmatch obn "AcDb*Text,AcDbMLeader") '(textstring))
                                    (   (wcmatch obn "AcDb*Dimension")        '(textoverride))
                                    (   (= "AcDbAttributeDefinition" obn)     '(tagstring promptstring textstring))
                                )
                            )
                        )
                        lst
                    )
                )
            )
        )
    )
)
;;----------------------------------------------------------------------;;
(defun incarray:splitstring (str / lst)
    (setq lst (vl-string->list str))
    (read (vl-list->string (vl-list* 40 34 (incarray:split lst (< 47 (car lst) 58)))))
)
;;----------------------------------------------------------------------;;
(defun incarray:split (lst flg)
    (cond
        ((null lst) '(34 41))
        ((= 92 (car lst))
            (if flg
                (vl-list* 34 32 34 92 92 (incarray:split (cdr lst) nil))
                (vl-list* 92 92 (incarray:split (cdr lst) flg))
            )
        )
        ((or (< 47 (car lst) 58) (and (= 46 (car lst)) flg (< 47 (cadr lst) 58)))
            (if flg
                (vl-list* (car lst) (incarray:split (cdr lst) flg))
                (vl-list* 34 32 34 (car lst) (incarray:split (cdr lst) t))
            )
        )
        (flg (vl-list* 34 32 34 (car lst) (incarray:split (cdr lst) nil)))
        ((vl-list* (car lst) (incarray:split (cdr lst) nil)))
    )
)
;;----------------------------------------------------------------------
(defun incarray:increment (str inc / dci dcs len num)
    (if (numberp (read str))
        (progn
            (setq num (+ (distof str) inc)
                  inc (incarray:num->str inc)
                  str (vl-string-left-trim "-" str)
                  inc (vl-string-left-trim "-" inc)
                  dci (incarray:decimalplaces inc)
                  dcs (incarray:decimalplaces str)
                  len (strlen str)
                  str (vl-string-left-trim "-" (rtos num 2 (max dci dcs)))
            )
            (cond
                ((< 0 dcs) (setq len (+ (- len dcs) (max dci dcs))))
                ((< 0 dci) (setq len (+ dci len 1)))
            )
            (repeat (- len (strlen str))
                (setq str (strcat "0" str))
            )
            (if (minusp num)
                (strcat "-" str)
                str
            )
        )
        str
    )
)
;;----------------------------------------------------------------------
(defun incarray:decimalplaces (str / pos)
    (if (setq pos (vl-string-position 46 str))
        (- (strlen str) pos 1)
        0
    )
)
;;----------------------------------------------------------------------
(defun incarray:startundo(doc)
    (incarray:endundo doc)
    (vla-startundomark doc)
)
;;----------------------------------------------------------------------
(defun incarray:endundo(doc)
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)
;;----------------------------------------------------------------------
(defun incarray:acdoc nil
    (eval (list 'defun 'incarray:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (incarray:acdoc)
)
(princ)

669423907

哪位大师高抬贵手帮忙改一下咯

669423907

路过的大师帮忙改一下啦

依然小小鸟

有gif图吗

669423907

依然小小鸟 发表于 2021-12-20 13:42
有gif图吗

公司把CAD加密了，在CAD界面上不能截图不能录屏
我是想要 (LM:incarray nil ss 1 p1 p2)  时可以原位（复制）递增，
是不是可以通过改这一段可以达到原位（复制）递增的效果？
        (   (setq ept (cadr(grread 3)))
            (setq qty (fix (/ (caddr (trans (mapcar '- ept bpt) 1 vxw t)) dis)))
            (incarray:copyvector lst (mapcar (if (minusp qty) '- '+) vxw) (abs (fix qty)) inc)
        )

669423907

顶起来，哪位帮指点一下改哪里也好啊