ET中已知函数的整理

自贡黄明儒 · 发表于 2013-9-4 13:44

本帖最后由自贡黄明儒于 2013-10-26 14:00 编辑

;;特别字符处理(ACET-STR-ESC-WILDCARDS "#a@b");"`#a`@b"
(defun ACET-STR-ESC-WILDCARDS (A / X LST)
(SETQ LST '("#" "@" "." "*" "?" "~" "[" "]" ","))
(foreach X LST
(SETQ A (ACET-STR-REPLACE X (STRCAT "`" X) A))
)
A
)
;;(ACET-STR-REPLACE "B" "2" "ssABCsBs");"ssA2Cs2s"
(defun ACET-STR-REPLACE1 (o n s)
(XD::String:Replace (strcat "[" o "]") s n "I")
)
;;(ACET-STR-TO-LIST "B" "ssABCsBs");("ssA" "Cs" "s")
(defun ACET-STR-TO-LIST1 (d str)
(XD::String:RegExpS (strcat "[^" d "]+") str "I")
)
;;(ACET-STR-WCMATCH "ssABCsBs" "*c*");T
(defun ACET-STR-WCMATCH1 (str f)
(if (XD::String:RegExpS (strcat "[" f "]+") str "") T)
)
;; 用正则表达式替换字符 by 梁雄啸.2007.7
(defun XD::String:Replace (pat str nstr key / end)
(vl-load-com)
(if (not *xxvbsexp)
(setq *xxvbsexp (vlax-get-or-create-object "VBScript.RegExp"))
)
(vlax-put *xxvbsexp 'Pattern pat)
(if (not key)(setq key ""))
(setq key (strcase key))
(setq keys '(("I" "IgnoreCase")("G" "Global")("M" "Multiline")))
(mapcar '(lambda(x)
(if (wcmatch key (strcat "*" (car x) "*"))
(vlax-put *xxvbsexp (read(cadr x)) 0)
(vlax-put *xxvbsexp (read(cadr x)) -1)
))
keys)
(vlax-invoke *xxvbsexp 'replace str nstr)
)
;|
ACET-STR-WCMATCH (EXRXSUBR)
ACET-STR-TO-LIST (SUBR)
ACET-STR-SPACE-TRIM (SUBR)
ACET-STR-REPLACE (EXRXSUBR)
ACET-STR-M-FIND (SUBR)
ACET-STR-LR-TRIM (SUBR)
ACET-STR-LIST-SELECT (SUBR)
ACET-STR-IS-PRINTABLE (SUBR)
ACET-STR-FORMAT (EXRXSUBR)
ACET-STR-FIND (EXRXSUBR)
ACET-STR-ESC-WILDCARDS (SUBR)
ACET-STR-EQUAL (EXRXSUBR)
ACET-STR-ENV-EXPAND (SUBR)
ACET-STR-COLLATE (EXRXSUBR)
|;
;;限定角度在0~2pi之间
(defun ACET-ANGLE-FORMAT (A / B)
(SETQ B (+ PI PI))
(while (< A 0)
(SETQ A (+ A B))
)
(while (>= A B)
(SETQ A (- A B))
)
(if (EQUAL A B 1.0e-008)
(SETQ A 0.0)
)
A
)
(defun ACET-SYS-LMOUSE-DOWN ()
(< (ACET-SYS-KEYSTATE 1) 0)
)
(defun ACET-SYS-CONTROL-DOWN ()
(< (ACET-SYS-KEYSTATE 17) 0)
)
(defun ACET-SYS-SHIFT-DOWN ()
(< (ACET-SYS-KEYSTATE 16) 0)
)
;;取得用户坐标系
;;(ACET-UCS-GET (car (entsel)));((-1824.72 3183.16 0.0) (-0.389905 0.920855 0.0) (-0.920855 -0.389905 0.0))
;;(ACET-UCS-GET nil)世界坐标系
(defun ACET-UCS-GET (NA / E1 ORG XDIR YDIR)
(if (and NA
(SETQ E1 (ENTGET NA ("*")))
(= "VIEWPORT" (CDR (ASSOC 0 E1)))
(= 1 (CDR (ASSOC 71 E1)))
)
(SETQ ORG (CDR (ASSOC 110 E1))
XDIR (CDR (ASSOC 111 E1))
YDIR (CDR (ASSOC 112 E1))
)
(SETQ ORG (GETVAR "ucsorg");当前坐标系原点
XDIR (GETVAR "ucsxdir");当前空间中当前视口的当前 UCS 的 X 方向
YDIR (GETVAR "ucsydir");当前空间中当前视口的当前 UCS 的 Y 方向
)
)
(LIST ORG XDIR YDIR)
)
;;alert
(defun ACET-ALERT (MSG)
(if (NOT (EQUAL 4 (LOGAND 4 (GETVAR "cmdactive"))))
(ALERT MSG)
(PRINC (STRCAT "\n" MSG))
)
(PRINC)
)
;;表中第n项插入A
;;(ACET-LIST-INSERT-NTH 1 '(3 3 3 3) 2);(3 3 1 3 3)
(defun ACET-LIST-INSERT-NTH (A LST N / LST2 J)
(SETQ J 0)
(repeat N
(SETQ LST2 (CONS (NTH J LST) LST2))
(SETQ J (+ J 1))
)
(SETQ LST2 (CONS A LST2))
(repeat (- (LENGTH LST) N)
(SETQ LST2 (CONS (NTH J LST) LST2))
(SETQ J (+ J 1))
)
(REVERSE LST2)
)
;;图元列表增加默认值
(defun ACET-ELIST-ADD-DEFAULTS (E1 / N)
(SETQ N (VL-POSITION (ASSOC 8 E1) E1))
(SETQ N (+ N 1))
(if (NOT (ASSOC 6 E1))
(SETQ E1 (ACET-LIST-INSERT-NTH (CONS 6 "BYLAYER") E1 N)
N (+ N 1)
)
)
(if (NOT (ASSOC 39 E1))
(SETQ E1 (ACET-LIST-INSERT-NTH (CONS 39 0.0) E1 N)
N (+ N 1)
)
)
(if (NOT (ASSOC 48 E1))
(SETQ E1 (ACET-LIST-INSERT-NTH (CONS 48 1.0) E1 N)
N (+ N 1)
)
)
(if (NOT (ASSOC 62 E1))
(SETQ E1 (ACET-LIST-INSERT-NTH (CONS 62 256) E1 N)
N (+ N 1)
)
)
(if (NOT (ASSOC 370 E1))
(SETQ E1 (ACET-LIST-INSERT-NTH (CONS 370 255) E1 N)
N (+ N 1)
)
)
E1
)
;;返回文件目录(ACET-FILENAME-DIRECTORY "C:\\Program Files\\DTIImain.DCL");"C:\\Program Files\\"
(defun ACET-FILENAME-DIRECTORY (A / B)
(SETQ A (VL-FILENAME-DIRECTORY A))
(if (NOT A)
(SETQ A "")
)
(if (and (NOT (EQUAL A ""))
(SETQ B (SUBSTR A (STRLEN A) 1))
(NOT (EQUAL B "\\"))
(NOT (EQUAL B ":"))
(NOT (EQUAL B "/"))
)
(SETQ A (STRCAT A "\\"))
)
A
)
;;进度显示
(defun ACET-SPINNER ()
(if (NOT #SPIN)
(SETQ #SPIN "-")
)
(cond
((= #SPIN "-") (SETQ #SPIN "\\"))
((= #SPIN "\\") (SETQ #SPIN "|"))
((= #SPIN "|") (SETQ #SPIN "/"))
(t (SETQ #SPIN "-"))
)
(PRINC (STRCAT (CHR 8) #SPIN))
)
;;提取组码
(defun ACET-DXF (CODE E1)
(CDR (ASSOC CODE E1))
)
;;布局时，取得一个视口对象(ACET-PSPACE-VIEWPORT-ENAME)
(defun ACET-PSPACE-VIEWPORT-ENAME (/ SS)
(SETQ SS
(SSGET "_x"
(LIST '(0 . "VIEWPORT")
'(67 . 1)
'(69 . 1)
(CONS 410 (GETVAR "ctab"))
)
)
)
(if SS
(SSNAME SS 0)
)
)

;;特别字符处理(ACET-STR-ESC-WILDCARDS "#a@b");"`#a`@b" 
(defun ACET-STR-ESC-WILDCARDS (A / X LST) 
  (SETQ LST '("#" "@" "." "*" "?" "~" "[" "]" ",")) 
  (foreach X LST 
    (SETQ A (ACET-STR-REPLACE X (STRCAT "`" X) A)) 
  ) 
  A 
) 
;;(ACET-STR-REPLACE "B" "2" "ssABCsBs");"ssA2Cs2s" 
(defun ACET-STR-REPLACE1 (o n s)   
  (XD::String:Replace (strcat "[" o "]") s n "I") 
) 
;;(ACET-STR-TO-LIST "B" "ssABCsBs");("ssA" "Cs" "s") 
(defun ACET-STR-TO-LIST1 (d str) 
  (XD::String:RegExpS (strcat "[^" d "]+") str "I") 
) 
;;(ACET-STR-WCMATCH "ssABCsBs" "*c*");T 
(defun ACET-STR-WCMATCH1 (str f) 
  (if (XD::String:RegExpS (strcat "[" f "]+") str "") T) 
) 
;; 用正则表达式替换字符 by 梁雄啸.2007.7 
(defun XD::String:Replace (pat str nstr key / end)   
  (vl-load-com) 
  (if (not *xxvbsexp) 
    (setq *xxvbsexp (vlax-get-or-create-object "VBScript.RegExp")) 
  ) 
  (vlax-put *xxvbsexp 'Pattern pat) 
  (if (not key)(setq key "")) 
  (setq key (strcase key)) 
  (setq keys '(("I"  "IgnoreCase")("G"  "Global")("M"  "Multiline"))) 
  (mapcar '(lambda(x) 
             (if (wcmatch key (strcat "*" (car x) "*")) 
               (vlax-put *xxvbsexp (read(cadr x)) 0) 
               (vlax-put *xxvbsexp (read(cadr x)) -1) 
               )) 
          keys) 
  (vlax-invoke *xxvbsexp 'replace str nstr) 
) 
 
;| 
ACET-STR-WCMATCH                        (EXRXSUBR)          
ACET-STR-TO-LIST                        (SUBR)               
ACET-STR-SPACE-TRIM                     (SUBR)               
ACET-STR-REPLACE                        (EXRXSUBR)          
ACET-STR-M-FIND                         (SUBR)               
ACET-STR-LR-TRIM                        (SUBR)               
ACET-STR-LIST-SELECT                    (SUBR)               
ACET-STR-IS-PRINTABLE                   (SUBR)               
ACET-STR-FORMAT                         (EXRXSUBR)          
ACET-STR-FIND                           (EXRXSUBR)          
ACET-STR-ESC-WILDCARDS                  (SUBR)               
ACET-STR-EQUAL                          (EXRXSUBR)          
ACET-STR-ENV-EXPAND                     (SUBR)               
ACET-STR-COLLATE                        (EXRXSUBR) 
|; 
 
 
 
;;限定角度在0~2pi之间 
(defun ACET-ANGLE-FORMAT (A / B) 
  (SETQ B (+ PI PI)) 
  (while (< A 0) 
    (SETQ A (+ A B)) 
  ) 
  (while (>= A B) 
    (SETQ A (- A B)) 
  ) 
  (if (EQUAL A B 1.0e-008) 
    (SETQ A 0.0) 
  ) 
  A 
) 
 
(defun ACET-SYS-LMOUSE-DOWN () 
  (< (ACET-SYS-KEYSTATE 1) 0) 
) 
(defun ACET-SYS-CONTROL-DOWN () 
  (< (ACET-SYS-KEYSTATE 17) 0) 
) 
(defun ACET-SYS-SHIFT-DOWN () 
  (< (ACET-SYS-KEYSTATE 16) 0) 
) 
 
;;取得用户坐标系 
;;(ACET-UCS-GET (car (entsel)));((-1824.72 3183.16 0.0) (-0.389905 0.920855 0.0) (-0.920855 -0.389905 0.0)) 
;;(ACET-UCS-GET nil)世界坐标系 
(defun ACET-UCS-GET (NA / E1 ORG XDIR YDIR) 
  (if (and NA 
           (SETQ E1 (ENTGET NA ("*"))) 
           (= "VIEWPORT" (CDR (ASSOC 0 E1))) 
           (= 1 (CDR (ASSOC 71 E1))) 
      ) 
    (SETQ ORG  (CDR (ASSOC 110 E1)) 
          XDIR (CDR (ASSOC 111 E1)) 
          YDIR (CDR (ASSOC 112 E1)) 
    ) 
    (SETQ ORG  (GETVAR "ucsorg");当前坐标系原点 
          XDIR (GETVAR "ucsxdir");当前空间中当前视口的当前 UCS 的 X 方向 
          YDIR (GETVAR "ucsydir");当前空间中当前视口的当前 UCS 的 Y 方向 
    ) 
  ) 
  (LIST ORG XDIR YDIR) 
) 
 
;;alert 
(defun ACET-ALERT (MSG) 
  (if (NOT (EQUAL 4 (LOGAND 4 (GETVAR "cmdactive")))) 
    (ALERT MSG) 
    (PRINC (STRCAT "\n" MSG)) 
  ) 
  (PRINC) 
) 
 
;;表中第n项插入A 
;;(ACET-LIST-INSERT-NTH 1 '(3 3 3 3) 2);(3 3 1 3 3) 
(defun ACET-LIST-INSERT-NTH (A LST N / LST2 J) 
  (SETQ J 0) 
  (repeat N 
    (SETQ LST2 (CONS (NTH J LST) LST2)) 
    (SETQ J (+ J 1)) 
  ) 
  (SETQ LST2 (CONS A LST2)) 
  (repeat (- (LENGTH LST) N) 
    (SETQ LST2 (CONS (NTH J LST) LST2)) 
    (SETQ J (+ J 1)) 
  ) 
  (REVERSE LST2) 
) 
;;图元列表增加默认值 
(defun ACET-ELIST-ADD-DEFAULTS (E1 / N) 
  (SETQ N (VL-POSITION (ASSOC 8 E1) E1)) 
  (SETQ N (+ N 1)) 
  (if (NOT (ASSOC 6 E1)) 
    (SETQ E1 (ACET-LIST-INSERT-NTH (CONS 6 "BYLAYER") E1 N) 
          N  (+ N 1) 
    ) 
  ) 
  (if (NOT (ASSOC 39 E1)) 
    (SETQ E1 (ACET-LIST-INSERT-NTH (CONS 39 0.0) E1 N) 
          N  (+ N 1) 
    ) 
  ) 
  (if (NOT (ASSOC 48 E1)) 
    (SETQ E1 (ACET-LIST-INSERT-NTH (CONS 48 1.0) E1 N) 
          N  (+ N 1) 
    ) 
  ) 
  (if (NOT (ASSOC 62 E1)) 
    (SETQ E1 (ACET-LIST-INSERT-NTH (CONS 62 256) E1 N) 
          N  (+ N 1) 
    ) 
  ) 
  (if (NOT (ASSOC 370 E1)) 
    (SETQ E1 (ACET-LIST-INSERT-NTH (CONS 370 255) E1 N) 
          N  (+ N 1) 
    ) 
  ) 
  E1 
) 
 
;;返回文件目录(ACET-FILENAME-DIRECTORY "C:\\Program Files\\DTIImain.DCL");"C:\\Program Files\\" 
(defun ACET-FILENAME-DIRECTORY (A / B) 
  (SETQ A (VL-FILENAME-DIRECTORY A)) 
  (if (NOT A) 
    (SETQ A "") 
  ) 
  (if (and (NOT (EQUAL A "")) 
           (SETQ B (SUBSTR A (STRLEN A) 1)) 
           (NOT (EQUAL B "\\")) 
           (NOT (EQUAL B ":")) 
           (NOT (EQUAL B "/")) 
      ) 
    (SETQ A (STRCAT A "\\")) 
  ) 
  A 
) 
 
;;进度显示 
(defun ACET-SPINNER () 
  (if (NOT #SPIN) 
    (SETQ #SPIN "-") 
  ) 
  (cond 
    ((= #SPIN "-") (SETQ #SPIN "\\")) 
    ((= #SPIN "\\") (SETQ #SPIN "|")) 
    ((= #SPIN "|") (SETQ #SPIN "/")) 
    (t (SETQ #SPIN "-")) 
  ) 
  (PRINC (STRCAT (CHR 8) #SPIN)) 
) 
;;提取组码 
(defun ACET-DXF        (CODE E1) 
  (CDR (ASSOC CODE E1)) 
) 
 
;;布局时，取得一个视口对象(ACET-PSPACE-VIEWPORT-ENAME) 
(defun ACET-PSPACE-VIEWPORT-ENAME (/ SS) 
  (SETQ        SS 
         (SSGET        "_x" 
                (LIST '(0 . "VIEWPORT") 
                      '(67 . 1) 
                      '(69 . 1) 
                      (CONS 410 (GETVAR "ctab")) 
                ) 
         ) 
  ) 
  (if SS 
    (SSNAME SS 0) 
  )   
)

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

[讨论] ET中已知函数的整理

浏览过的版块