分享自己编的编号字符串排序函数
本帖最后由 ld_117 于 2015-1-27 10:51 编辑分享自己编的编号字符串排序函数，本人只求实现功能，不求深入学习lisp，所以函数写的比较冗长，仅作参考....
(orderLst (lst keyW))
功能：对lst根据关键字进行排序并列出相同元素的个数
参数：lst 字符串数列keyW 关键字字符串
例：(orderLst '("KL5" "KL2(2)" "KL1a(2)" "KL2(2)" "KL1(1)") "KL")
返回(("KL1(1)" . 1) ("KL1a(2)" . 1) ("KL2(2)" . 2) ("KL5" . 1))
作者：Ld_117
(vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP
;---------正则表达式设置---------
(setq reg (vlax-create-object "vbscript.regexp")) ;创建正则表达式
(vlax-put-property reg 'global -1) ;是否匹配全部 （-1是 ，0 不是）
(vlax-put-property reg 'Multiline -1) ;是否多行匹配 （-1是 ，0 不是）
(vlax-put-property reg 'IgnoreCase -1) ;是否忽略大小写 （-1是 ，0 不是）
;---------正则表达式设置结束---------
;;排序函数开始
;;(orderLst (lst keyW))
;;功能：对lst根据关键字进行排序并列出相同元素的个数
;;参数：lst 字符串数列keyW 关键字字符串
;;例：(orderLst '("KL5" "KL2(2)" "KL1a(2)" "KL2(2)" "KL1(1)") "KL")
;; 返回(("KL1(1)" . 1) ("KL1a(2)" . 1) ("KL2(2)" . 2) ("KL5" . 1))
;;作者：Ld_117
(defun orderLst (lst keyW / x nLst len i lLst tnLst nowLst nnLst)
(setq nLst '() tnLst '())
(foreach x lst
(setq nLst (cons (cons x (getNum x keyW)) nLst));将lst做成点对形式
)
;获得排序后的列表
(foreach x (sortLst (reverse nLst))
(setq tnLst (append tnLst (list (car x))))
)
(setq
nLst tnLst
len (vl-list-length nLst)
i 0
nowLst '()
nNowLst '()
nnLst '()
)
;合并tnLst中相同元素并统计数量
(while (< i len)
(if (setq nowLst (assoc (nth i nLst) nnLst))
(progn
(setq nNowLst (cons (car nowLst) (1+ (cdr nowLst))))
(setq nnLst (subst nNowLst nowLst nnLst))
)
(setq nnLst (cons (cons (nth i nLst) 1) nnLst))
)
(setq i (1+ i))
)
(setq nnLst (reverse nnLst))
)
;;(getNum (str keyW))
;;功能：获得str中紧跟keyW的编号字符，编号可以包含数字及字母
;;参数：str 字符串keyW 关键字字符串
;;例：(getNum "KL5a(2)" "KL")
;; 返回"5a"
;;作者：Ld_117
(defun getNum (str keyW / matchcollect)
(vlax-put-property reg 'pattern (strcat "^" keyW))
(setq str (vlax-invoke-method reg 'Replace str ""))
(vlax-put-property reg 'pattern "^+")
(setq matchcollect (vlax-invoke-method reg 'Execute str))
(vlax-for match_item matchcollect (setq str (car (list (eval (vlax-get-property match_item 'value))))))
str
)
;;(sortLst (lst))
;;功能：调用vl-sort函数
(defun sortLst (lst)
(vl-sort lst
'sortLstFun
)
)
;;(sortLstFun (a b))
;;功能：函数vl-sort中的比较函数，返回值为t则vl-sort对表中a、b元素位置进行调换
;;参数：a 为lst中后一个列表元素b 前一个列表元素
;;例：(sortLstFun '("KL2" . "2") '("KL4" . "4"))
;; 返回t
;;作者：Ld_117
(defun sortLstFun (a b / a1 a2 b1 b2 len1 len2 len loop t1 t2 i)
(setq
a1 (cdr a)
b1 (cdr b)
result t
)
(vlax-put-property reg 'pattern "^+")
(setq matchcollect (vlax-invoke-method reg 'Execute (cdr a)))
(vlax-for match_item matchcollect (setq a1 (car (list (eval (vlax-get-property match_item 'value))))))
(setq a2 (vlax-invoke-method reg 'Replace (cdr a) ""))
(setq matchcollect (vlax-invoke-method reg 'Execute (cdr b)))
(vlax-for match_item matchcollect (setq b1 (car (list (eval (vlax-get-property match_item 'value))))))
(setq b2 (vlax-invoke-method reg 'Replace (cdr b) ""))
(if (> (atof a1) (atof b1))
(setq result nil)
(if (< (atof a1) (atof b1))
(setq result t)
(progn
(if (= a2 nil) (setq a2 ""))
(if (= b2 nil) (setq b2 ""))
(setq
len1 (strlen a2)
len2 (strlen b2)
len (max len1 len2)
loop t
i 1
)
(if (= len1 0)
(setq result t)
(if (= len2 0)
(setq result nil)
(while loop
(setq
t1 (ASCII (substr a2 i 1))
t2 (ASCII (substr b2 i 1))
i (1+ i)
)
(if (< t1 t2)
(setq loop nil result t)
(if (> t1 t2)
(setq loop nil result nil)
(setq loop nil result nil)
)
)
)
)
)
)
)
)
result
)
;;排序函数结束
wline 发表于 2024-10-28 15:21
下载学习下，不过命令是什么啊
函数，没有命令 ld_117 发表于 2024-10-29 09:39
函数，没有命令
麻烦问下那怎么用啊 下载学习下，不过命令是什么啊
我第一个出来支持你！放出源码才是正道！ 我也支持你！放出源码才是正道！ USER2128 发表于 2015-1-27 11:39 static/image/common/back.gif
我第一个出来支持你！放出源码才是正道！
你们能看到源码吗，我不常发帖不知道操作的对不对 ld_117 发表于 2015-1-28 17:27 static/image/common/back.gif
你们能看到源码吗，我不常发帖不知道操作的对不对
发贴没有问题，他是在赞扬你放出源码 lucas_3333 发表于 2015-1-28 21:20 static/image/common/back.gif
发贴没有问题，他是在赞扬你放出源码
本来想快点升级设置回复可见的。。。捣弄半天没弄成... ld_117 发表于 2015-1-28 23:53 static/image/common/back.gif
本来想快点升级设置回复可见的。。。捣弄半天没弄成...
论坛不鼓励回复可见的，所以一般等级没这个权限， 另外回复的多少跟你升级没有关系 支持源码， 支持下楼主，没钱就不下了 emk 发表于 2015-1-30 14:33 static/image/common/back.gif
支持下楼主，没钱就不下了
不是贴源码了吗，复制是一样的，lsp文件是留给土豪下载的
页:
[1]
2