单向阵列

/db_自贡黄明儒_ · 发表于 2013-5-30 08:16:01

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 /db_自贡黄明儒_ 于 2013-6-6 23:17 编辑

我写的单向阵列,其目的是:
1 如果选择有文字,使其末尾数字加一,用于布点。但由于在有些环境中A2并不变成A3，问题没有解决，就不给出函数EndNumberS了，去掉它仍可运行。
2 使用时,选择或者输入要少.
3 也可以动态曲线布置，问题是电脑运行速度快时，不停闪烁

;;;;;;;;;;;;;;;;;;;;;;单向阵列,文字递增或递减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

;;;;;;;;;;;;;;;;;;;;;;单向阵列,文字递增或递减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

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:单向阵列.lsp
下载次数:80 文件大小:6.64 KB
下载权限: 不限以上 [免费赚D豆]

/db_自贡黄明儒_ · 发表于 2013-5-30 08:21:31

本帖最后由 /db_自贡黄明儒_ 于 2013-5-30 09:00 编辑

;;;所取字符串末尾是不是数,返回真假
(defun obaEndIsNumber (otxt / E OBALENGTH)
(setq obaLength (strlen otxt))
(setq e (ascii (substr otxt obaLength 1)))
(and (> e 47) (< e 58))
) ;_ 结束defun
;;; 结束defun obaEndIsNumber
;; 亮显选择集或对象(夹点不显示) 函数
(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 
;; 亮显选择集或对象(夹点不显示) 函数 
  (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 
)

/db_自贡黄明儒_ · 发表于 2013-5-30 08:37:41

发错地方了!!:$

marting · 发表于 2013-5-30 08:46:49

感谢楼主分享，楼主，第一幅图片，如果30在曲线的另外一面，程序还能正常阵列吗？测试过没。

Lispboy · 发表于 2013-5-30 09:31:08

感谢楼主，看到了用了很多的COPY和ROTATE，楼主不试试用矩阵改写下？另外判断字符串是否有数字的，用正则表达式更方便些，免得下次替换别的规则的时候，代码改动量大。

XDSoft · 发表于 2013-5-30 16:46:46

楼主，什么情况下A2不能变成A3？

/db_自贡黄明儒_ · 发表于 2013-5-31 08:03:42

本帖最后由 /db_自贡黄明儒_ 于 2013-5-31 08:07 编辑

XDSoft 发表于 2013-5-30 16:46
楼主，什么情况下A2不能变成A3？

;;我原来是这样写的,现在改了没有问题了,
;;以下是原来写的,有时就出现问题(setq endnumber (rtos (1+ Nend)2 3))

(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 (rtos (1+ Nend)2 3))
(setq endnumber (rtos (1- Nend)2 3))
)
(setq scor (strcat qianZ (itoa endnumber)))
)
)
scor
)

(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 (rtos  (1+ Nend)2 3)) 
        (setq endnumber  (rtos  (1- Nend)2 3)) 
      ) 
      (setq scor (strcat qianZ (itoa endnumber))) 
    ) 
  ) 
  scor 
)

XDSoft · 发表于 2013-5-31 11:54:32

/db_自贡黄明儒_ 发表于 2013-5-31 08:03
;;我原来是这样写的,现在改了没有问题了,
;;以下是原来写的,有时就出现问题(setq endnumber (rtos (1 ...

哦，那你发现是什么问题会出现偶尔的错误？

/db_自贡黄明儒_ · 发表于 2013-5-31 13:20:58

XDSoft 发表于 2013-5-31 11:54
哦，那你发现是什么问题会出现偶尔的错误？

我用ET工具的变量_.sysvdlg工具,将两张图的变量比较,没有发现变量影响这个问题,所以就改者程序了.问题的原因至今没有找到!!

/db_自贡黄明儒_ · 发表于 2013-6-1 15:49:20

本帖最后由 /db_自贡黄明儒_ 于 2013-6-1 15:51 编辑

看来尾部数字+1的函数得修改了

;;练习正则表达式，文字最后数字加1
(defun C:w1 (/ ENT I REGEX S STR STR1 STR2)
(setq ent (car (entsel))) ;选择文字
(setq regex (vlax-create-object "Vbscript.RegExp")) ;引用正则表达式控件
;;(vlax-put-property regex "IgnoreCase" 0) ; 不忽略大小写
;;(vlax-put-property regex "Global" 0) ;只匹配第一处
;;(vlax-put-property regex "RightToLeft") ;从右向左查找(语法不对)
(setq str (cdr (assoc 1 (entget ent)))) ;文本内容
(vlax-put-property regex "Pattern" "[0-9]+$") ;查找规则，提最后一位数字;"[0-9]+$"最后数字
(setq s (vlax-invoke-method regex "Execute" str)) ;将规则运用到STR字符，得到提取出的文字内容
(VLAX-FOR tmp s
(setq str1 (cons (vlax-get-property tmp "value") str1))
) ;将内容转换为LISP语言就可以直接观察了
(if str1
(progn (setq str2 (itoa (1+ (atoi (car str1))))) ;提取的尾数+1
(setq i (- (strlen (car str1)) (strlen str2)))
(if (> i 0)
(repeat i (setq str2 (strcat "0" str2)))
)
;;(setq s (vlax-invoke-method regex "Replace" str "")) ;字符串前缀
(setq str (vlax-invoke-method regex "Replace" str str2)) ;替换字符串
)
(setq str (strcat str "1"))
)
(vlax-put-property (vlax-ename->vla-object ent) 'TextString str) ;改变特性
(vlax-release-object regex) ;释放正则表达式
(princ)
)
;;小数点后数字加1
(defun C:w2 (/ ENT ENTLIST I QIANZ STR STR1 STR2 STRLEN1 STRLEN2)
(setq ent (car (entsel))) ;选择文字
(setq entlist (entget ent))
(setq str (cdr (assoc 1 entlist))) ;文本内容
(setq strlen1 (strlen str)) ;长度
(setq QianZ (vl-string-right-trim "0123456789" str)) ;去除右边数字
(setq strlen2 (strlen QianZ)) ;前缀长度
(setq str1 (substr str (1+ strlen2) (- strlen1 strlen2))) ;小数点后数字
(if str1
(progn (setq str2 (itoa (1+ (atoi str1)))) ;提取的尾数+1
(setq i (- (strlen str1) (strlen str2)))
(if (> i 0)
(repeat i (setq str2 (strcat "0" str2)))
)
)
(setq str2 "1")
)
(setq str (strcat QianZ str2))
(entmod (subst (cons 1 str) (assoc 1 entlist) entlist))
(princ)
)

;;练习正则表达式，文字最后数字加1 
(defun C:w1 (/ ENT I REGEX S STR STR1 STR2) 
  (setq ent (car (entsel)))                                 ;选择文字 
  (setq regex (vlax-create-object "Vbscript.RegExp"))       ;引用正则表达式控件 
  ;;(vlax-put-property regex "IgnoreCase" 0)                  ; 不忽略大小写 
  ;;(vlax-put-property regex "Global" 0)                      ;只匹配第一处 
  ;;(vlax-put-property regex "RightToLeft")                   ;从右向左查找(语法不对) 
  (setq str (cdr (assoc 1 (entget ent))))                   ;文本内容 
  (vlax-put-property regex "Pattern" "[0-9]+$")             ;查找规则，提最后一位数字;"[0-9]+$"最后数字 
  (setq s (vlax-invoke-method regex "Execute" str))         ;将规则运用到STR字符，得到提取出的文字内容 
  (VLAX-FOR tmp s 
    (setq str1 (cons (vlax-get-property tmp "value") str1)) 
  )                                                         ;将内容转换为LISP语言就可以直接观察了 
  (if str1 
    (progn (setq str2 (itoa (1+ (atoi (car str1)))))        ;提取的尾数+1 
           (setq i (- (strlen (car str1)) (strlen str2))) 
           (if (> i 0) 
             (repeat i (setq str2 (strcat "0" str2))) 
           ) 
           ;;(setq s (vlax-invoke-method regex "Replace" str "")) ;字符串前缀 
           (setq str (vlax-invoke-method regex "Replace" str str2)) ;替换字符串 
    ) 
    (setq str (strcat str "1")) 
  ) 
  (vlax-put-property (vlax-ename->vla-object ent) 'TextString str) ;改变特性 
  (vlax-release-object regex)                               ;释放正则表达式 
  (princ) 
) 
;;小数点后数字加1 
(defun C:w2 (/ ENT ENTLIST I QIANZ STR STR1 STR2 STRLEN1 STRLEN2) 
  (setq ent (car (entsel)))                                 ;选择文字 
  (setq entlist (entget ent)) 
  (setq str (cdr (assoc 1 entlist)))                        ;文本内容 
  (setq strlen1 (strlen str))                               ;长度 
  (setq QianZ (vl-string-right-trim "0123456789" str))      ;去除右边数字 
  (setq strlen2 (strlen QianZ))                             ;前缀长度 
  (setq str1 (substr str (1+ strlen2) (- strlen1 strlen2))) ;小数点后数字 
  (if str1 
    (progn (setq str2 (itoa (1+ (atoi str1))))              ;提取的尾数+1 
           (setq i (- (strlen str1) (strlen str2))) 
           (if (> i 0) 
             (repeat i (setq str2 (strcat "0" str2))) 
           ) 
    ) 
    (setq str2 "1") 
  ) 
  (setq str (strcat QianZ str2)) 
  (entmod (subst (cons 1 str) (assoc 1 entlist) entlist)) 
  (princ) 
)

热土流风 · 发表于 2017-8-17 17:28:08

有意思！！！！

账号		自动登录	找回密码
密码			立即注册

[研讨] 单向阵列

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

点评

点评

点评

评分

点评