单向阵列
本帖最后由 自贡黄明儒 于 2013-6-13 15:03 编辑;;;;;;;;;;;;;;;;;;;;;;单向阵列,文字递增或递减SingleArray
(defun C:SA (/ $ORR MY*ERROR* P0 P1 SS0 SSP0 SSP1 SS_MOVE)
;;0错误处理
(defun MY*error* (s)
;;如果有活动编组，先结束之
(if (= 8 (logand (getvar "undoctl") 8))
(command "_undo" "_e")
)
(if ss_move
(command "._erase" ss_move "")
)
(setq *error* $orr)
(princ "\n 出错啦!")
)
;;1尾数是数字,则加1
(defun endIncrease (otxt)
(if (obaEndIsNumber otxt)
(EndNumberS otxt T) ;增1
(setq otxt (strcat otxt "1"))
)
)
;;2选择集内数字增加
(defun change (ss1 / ELIST N OBN OTXT)
(repeat (setq n (sslength ss1))
(setq obn (ssname ss1 (setq n (1- n))))
(setq elist (entget obn))
(cond ((wcmatch (LI_item 0 elist) "ATTDEF")
(setq otxt (endIncrease (LI_item 2 elist)))
(entmod (subst (cons 2 otxt) (assoc 2 elist) elist))
)
(T
(setq otxt (endIncrease (LI_item 1 elist)))
(entmod (subst (cons 1 otxt) (assoc 1 elist) elist))
)
)
)
)
;;3对象na之后所有实体产生的选择集
(defun newsel (na / ss e1)
(if na
(setq na (entnext na))
(setq na (entnext))
)
(setq ss (ssadd))
(while na
(setq e1 (entget na))
(if (wcmatch (LI_item 0 e1) "VERTEX,SEQEND,ATTRIB")
nil
(setq ss (ssadd na ss))
)
(setq na (entnext na))
)
ss
)
;;4.1 非曲线时，鼠标移动
(defun do_move (ss0 p0 p1-p0 n / B P1)
(if ss_move
(command "._erase" ss_move "")
)
(setq b (entlast))
(setq p1 p0)
(repeat n
(setq p1 (mapcar '+ p1 p1-p0))
(command "copy" ss0 "" "non" p0 "non" p1)
)
(setq ss_move (newsel b))
)
;;4.2 非曲线时，阵列
(defun do_arry (ss0 p0 p1-p0 n / B P1 SS SS1)
(if ss_move
(command "._erase" ss_move "")
)
(setq p1 p0)
(setq ss ss0)
(repeat n
(setq b (entlast))
(command "copy" ss "" "non" p1 "non" (setq p1 (mapcar '+ p1 p1-p0)))
(setq ss (newsel b))
(command "._Select" ss "")
(if (setq ss1 (ssget "_p" '((0 . "*TEXT,ATTDEF"))))
(change ss1)
)
)
)
;;4 非曲线时，移动阵列
(defun p0-next (ss0 p0 p1 / A CODE DISTANC LOOP N NN P1-P0 P2 SS)
(setq p1-p0 (mapcar '- p1 p0))
(setq distanc (distance p1 p0))
(princ "\n >>>> 输入距离或者拾取点,阵列到:")
(setq loop T)
(while loop
(setq code (grread T 8))
(cond ((= (car code) 5)
(setq p2 (cadr code))
(setq nn n)
(setq n (fix (/ (distance p2 p0) distanc)))
(if (/= nn n)
(do_move ss0 p0 p1-p0 n)
)
)
(t (setq loop nil) (do_arry ss0 p0 p1-p0 n))
)
)
)
;;5.3 曲线时，鼠标移动
(defun curve-move (ss0 p00 distanc n en / B DIS DP1)
(if ss_move
(command "._erase" ss_move "")
)
(setq b (entlast))
(setq dis (vlax-curve-getDistAtPoint en p00))
(repeat (abs n)
(setq p1 (vlax-curve-getPointAtDist en (setq dis (+ dis distanc))))
(command "_.copy" ss0 "" "non" p00 "non" p1)
)
(setq ss_move (newsel b))
)
;;5.2 曲线时，阵列
(defun curve-arry (ss0 p00 distanc n en / AN B DIS P1 PP PT SS SS1 VT an0)
(if ss_move
(command "._erase" ss_move "")
)
(setq dis (vlax-curve-getDistAtPoint en p00))
(setq pp(vlax-curve-getParamAtPoint en p00) ;得到这点参数
vt(vlax-curve-getFirstDeriv en pp) ;得到切线
an0 (angle '(0 0 0) vt) ;切线角
)
(setq ss ss0)
(setq pt p00)
(repeat (abs n)
(setq b (entlast))
(setq p1 (vlax-curve-getPointAtDist en (setq dis (+ dis distanc))))
(command "_.copy" ss "" "non" pt "non" p1)
(setq pt p1)
(setq pp (vlax-curve-getParamAtPoint en p1) ;得到这点参数
vt (vlax-curve-getFirstDeriv en pp) ;得到切线
an (angle '(0 0 0) vt) ;切线角
)
(setq ss (newsel b))
(command "_.rotate" SS "" "non" p1 (/ (* 180 (- an an0)) pi))
(setq an0 an)
(command "._Select" ss "")
(if (setq ss1 (ssget "_p" '((0 . "*TEXT,ATTDEF"))))
(change ss1)
)
)
)
;;5.1 检测到曲线时，移动阵列
(defun curveDoNext (ss0 p0 p1 en / CODE DIST0 DIST1 DIST2 DISTANC LOOP N NN P00 P11 P2)
(setq p00 (vlax-curve-getClosestPointTo en p0))
(setq dist0 (vlax-curve-getDistAtPoint en p00))
(setq p11 (vlax-curve-getClosestPointTo en p1))
(setq dist1 (vlax-curve-getDistAtPoint en p11))
(setq distanc (- dist1 dist0))
(princ "\n >>>> 输入距离或者拾取点,阵列到:")
(setq loop T)
(while loop
(setq code (grread T 8))
(cond ((= (car code) 5)
(setq p2 (cadr code))
(setq nn n)
(setq p2 (vlax-curve-getClosestPointTo en p2))
(setq dist2 (vlax-curve-getDistAtPoint en p2))
(setq n (fix (/ (- dist2 dist0) distanc)))
(if (/= nn n)
(curve-move ss0 p00 distanc n en)
)
)
(t (setq loop nil) (curve-arry ss0 p00 distanc n en))
)
)
)
;;5 检测到曲线时，判断是否有相同的曲线
(defun curveDo (ss0 SSp0 SSp1 p0 p1 / BOOL BOOL1 EN I N)
;;检测两个选择集是否有相同的曲线
(setq bool T)
(setq n (sslength SSp0))
(setq i -1)
(while bool
(setq en (ssname SSp0 (setq i (1+ i))))
(if (ssmemb en SSp1)
(progn (setq bool nil) (setq bool1 T))
)
(if (= i n)
(setq bool nil)
)
)
(if bool1
(curveDoNext ss0 p0 p1 en)
(p0-next ss0 p0 p1)
)
)
;;6 本程序主程序
(command "undo" "be")
(setq $orr *error*)
(setq *error* MY*error*);保证自定义出错处理函数执行,将(defun MY*error*定义为(defun *error*时，可以不用这句
(if (and (princ "\n > 选择对象来阵列:")
(setq ss0 (ssget))
(ayEntSSHighLight ss0)
)
(progn
(if (setq p0 (getpoint "\n>> 基点:"))
(setq SSp0 (ssget "c" p0 p0 '((0 . "*line,arc"))))
)
(if (and p0 (setq p1 (getpoint p0 "\n >>> 输入距离或者拾取点,阵列间距:")))
(setq SSp1 (ssget "c" p1 p1 '((0 . "*line,arc"))))
)
(if (and p0 p1 (not (equal p0 p1 0.01)))
(if (and SSp0 SSp1)
(curveDo ss0 SSp0 SSp1 p0 p1)
(p0-next ss0 p0 p1)
)
)
)
)
(setq *error* $orr)
(command "undo" "e")
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;单向阵列,文字递增或递减SingleArray
本帖最后由 自贡黄明儒 于 2013-5-30 09:03 编辑
;; 亮显选择集或对象(夹点不显示) 函数
(defun ayEntSSHighLight (SSorEntName / oldGrips)
(setq oldGrips (getvar "Grips"))
(setvar "Grips" 0)
(cond ((= (type SSorEntName) 'PICKSET) ; 选择集.
(sssetfirst nil SSorEntName)
) ; end_switch
((= (type SSorEntName) 'ENAME) ; 单一实体.
(sssetfirst nil (ssadd SSorEntName (ssadd)))
) ; end_switch
) ; end_cond
(setvar "Grips" oldGrips)
)
(Defun LI_item (N E) (CDR (Assoc N E)));;(setq str "aa 10.2 b10x20.002")
(defun EndNumberS (str bool / ENDNUMBER N N1 N2 N3 NEND QIANZ SCOR STREND ZNUMBER)
(setq n3 (strlen str));字符串总长
(setq strEND (getNumberS str));末尾数字的字符串
(setq Nend (nth (1- (length strEND)) strEND))
(setq n1 (strlen Nend));最后一位数字符串总长
(setq qianZ (substr str 1 (- n3 n1)));前缀
(setq Znumber (fix (atof Nend))) ;最后一位数字小数前数字
(setq n2 (strlen (itoa Znumber))) ;最后一位数字小数前数字长度
(setq n (- n1 n2 1)) ;小数位数
(if (> n 0)
(progn
(setq Nend (* (expt 10 n) (atof Nend)))
(if bool
(setq endnumber (1+ Nend))
(setq endnumber (1- Nend))
)
(setq scor (strcat qianZ (rtos (/ endnumber (expt 10 n)) 2 3)))
)
(progn
(if bool
(setq endnumber (1+ (atoi Nend)))
(setq endnumber (1- (atoi Nend)))
)
(setq scor (strcat qianZ (itoa endnumber)))
)
)
scor
)
一开始那个版本只懂改成让文字也能阵列，递增还做不到，黄大师能否指点一下 这个功能对路的可能有用啊！支持！ 多谢分享，较为实用 无论我怎么选，都一直提示“出错啦！” 不明白什么意思？ ;;;所取字符串末尾是不是数,返回真假
(defun obaEndIsNumber (otxt / E OBALENGTH)
(setq obaLength (strlen otxt))
(setq e (ascii (substr otxt obaLength 1)))
(and (> e 47) (< e 58))
) ;_ 结束defun
;;; 结束defun obaEndIsNumber 单向阵列.lsp程序无法使用! 很不错！ 支持下 多谢分享，较为实用，支持下