求助动态递增阵列增加原位递增功能
本帖最后由 669423907 于 2021-12-11 23:30 编辑这是在论坛下的动态阵列递增程序，我自己改了一下，可以左键递增，右键递减。
哪位帮忙修改一下，在不原来的基础上，增加可以原位递增的功能（实现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)
哪位大师高抬贵手帮忙改一下咯 路过的大师帮忙改一下啦 有gif图吗 依然小小鸟 发表于 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)
) 顶起来，哪位帮指点一下改哪里也好啊
页:
[1]