[编程申请]：(有点难度)判断斜杠/左右两边数字乘积的大小决定加前缀Z、D或F

lengliqun

判断斜杠/左右两边数字乘积的大小决定加前缀Z、D或F    字符串格式为　*]*/*]*  如　a]c/b]d　　其中a、c、b、b为数字。
条件：
如果 axc > bxd ，则加前缀Z
如果 axc < bxd ，则加前缀D
如果 axc = bxd ，则加前缀F
可以框选多个字符串，谢谢！

zxq0220

程序未经调试
[php]
(DEFUN C:ADD-ASC ()
(PRINC "\nPlease Select Text(s) 请选择文字 :")
(SETQ SS (SSGET '((0 . "TEXT"))))
(SETQ I 0)
(REPEAT (SSLENGTH SS)
  (SETQ ENT (ENTGET (SSNAME SS I)) I (1+ I)
        STR (CDR (ASSOC 1 ENT)))
  (IF (WCMATCH STR "*]*/*]*") (PROGN
   (SETQ A (ATOI STR) J 1 SL (STRLEN STR))
   (WHILE (<= J SL)
    (IF (= (SUBSTR J 1) "]")
     (SETQ STR1 (SUBSTR STR (1+ J)) J SL)
     (SETQ J (1+ J))
    )
   )
   (SETQ C (ATOI STR1) J 1 SL (STRLEN STR1))
   (WHILE (<= J SL)
    (IF (= (SUBSTR J 1) "/")
     (SETQ STR1 (SUBSTR STR1 (1+ J)) J SL)
     (SETQ J (1+ J))
    )
   )
   (SETQ B (ATOI STR1) J 1 SL (STRLEN STR1))
   (WHILE (<= J SL)
    (IF (= (SUBSTR J 1) "/")
     (SETQ STR1 (SUBSTR STR1 (1+ J)) J SL)
     (SETQ J (1+ J))
    )
   )
   (SETQ D (ATOI STR1))
   (COND
    ((> (* A C) (* B D)) (SETQ STR1 (STRCAT "Z" STR)))
    ((< (* A C) (* B D)) (SETQ STR1 (STRCAT "D" STR)))
    ((= (* A C) (* B D)) (SETQ STR1 (STRCAT "F" STR)))
   )
   (SETQ ENT (SUBST (CONS 1 STR1) (CONS 1 STR) ENT))
   (ENTMOD ENT)
  ))
)
(PRINC)
)
[/php]

lengliqun

报告，不能运行，提示有误如下，请参考附件调试，谢谢。

命令:
ADD-ASC
Please Select Text(s) 请选择文字 :
选择对象: 指定对角点: 找到 5 个

选择对象:

错误: 参数类型错误: stringp 1

命令:

zxq0220

更改后:
[php](DEFUN C:ADD-ASC ()
(PRINC "\nPlease Select Text(s) 请选择文字 :")
(SETQ SS (SSGET '((0 . "TEXT"))))
(SETQ I 0)
(REPEAT (SSLENGTH SS)
  (SETQ ENT (ENTGET (SSNAME SS I)) I (1+ I)
        STR (CDR (ASSOC 1 ENT)))
  (IF (WCMATCH STR "*]*/*]*") (PROGN
   (SETQ A (ATOI STR) J 1 SL (STRLEN STR))
   (WHILE (<= J SL)
    (IF (= (SUBSTR STR J 1) "]")
     (SETQ STR1 (SUBSTR STR (1+ J)) J SL)
     (SETQ J (1+ J))
    )
   )
   (SETQ C (ATOI STR1) J 1 SL (STRLEN STR1))
   (WHILE (<= J SL)
    (IF (= (SUBSTR STR1 J 1) "/")
     (SETQ STR1 (SUBSTR STR1 (1+ J)) J SL)
     (SETQ J (1+ J))
    )
   )
   (SETQ B (ATOI STR1) J 1 SL (STRLEN STR1))
   (WHILE (<= J SL)
    (IF (= (SUBSTR STR1 J 1) "]")
     (SETQ STR1 (SUBSTR STR1 (1+ J)) J SL)
     (SETQ J (1+ J))
    )
   )
   (SETQ D (ATOI STR1))
   (COND
    ((> (* A C) (* B D)) (SETQ STR1 (STRCAT "Z" STR)))
    ((< (* A C) (* B D)) (SETQ STR1 (STRCAT "D" STR)))
    ((= (* A C) (* B D)) (SETQ STR1 (STRCAT "F" STR)))
   )
   (SETQ ENT (SUBST (CONS 1 STR1) (CONS 1 STR) ENT))
   (ENTMOD ENT)
  ))
)
(PRINC)
)
[/php]

无痕

[php]
;;(addpre "1]2/3]4") -> "D1]2/3]4"
(defun addpre (str / lst ab cd)
  (setq lst (mapcar 'eval (read(strcat "(" (vl-string-translate "]/]"  "   " str)")")))
        ab  (*(car lst)(cadr lst))
        cd  (*(caddr lst)(last lst)))
  (strcat (cond((> ab cd) "Z")((< ab cd) "D")((= ab cd) "F"))str)
)
;; 主程序:
(defun c:tt ( / *doc ss i e ent str)
  (setq *doc (vla-get-activedocument(vlax-get-acad-object)))
  (vla-startundomark *doc)
  (setq ss (ssget '((0 . "TEXT")(1 . "*]*/*]*")))
        i  -1)
  (while (setq e (ssname ss (setq i (1+ i))))
    (setq ent (entget e)
          str (cdr(assoc 1 ent)))
    (entmod (subst (cons 1 (addpre str))(assoc 1 ent)ent))
  )(vla-endundomark *doc)(princ)
)[/php]

lengliqun

谢谢两位，辛苦了，两个LSP都可以用。