明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
123
返回列表 发新帖
楼主: 树櫴希德

收藏73哥函数 程序---列出文件夹下所有子文件荚或者文件名

[复制链接]
 楼主| 发表于 2022-9-19 19:42:52 | 显示全部楼层

表内汉语根据声母首字母排序
  1. ;[llsheng_73]■■■(275988734) 2022/9/19 17:52:06
  2. (defun sortn(l keys funs fuzz / n mposition);;;keys关键字列号要么为nil要么为表,funs各个关键字的排序方式,通常为<或>,也可以为自定义序列,比如'("张三""李四")
  3.   (defun mposition(e l / i)(if(setq i(vl-position e l))i(length l)))
  4.   (or(listp(car l))(setq l(mapcar'list l)))
  5.   (or(listp funs)(setq funs(list funs)))
  6.   (if(zerop(setq n(length keys)))(setq n(length(car l))))
  7.   (while(<(length funs)n)(setq funs(cons(car funs)funs)))
  8.   (mapcar(function(lambda(x)(nth x l)))
  9.    (vl-sort-i(if keys(mapcar(function(lambda(x)(mapcar'(lambda(y)(nth y x))keys)))l)l)
  10.        (function(lambda(x y / n )(setq n 0)
  11.           (while(and(equal(car x)(car y)fuzz)(cdr x)(cdr y))(setq x(cdr x)y(cdr y)n(1+ n)))
  12.             (if(listp(setq n(nth n funs)))
  13.         (<(mposition(car x)n)(mposition(car y)n))
  14.         (n(car x)(car y))))))))

  15. ;[llsheng_73]■■■(275988734) 2022/9/19 17:52:18
  16. ;_$ (SORTN'(("上海""崇明区")("北京""朝阳区")("上海""静安区")("北京""房山区")("重庆""酉阳")("四川""成都"))'(0 1)'(("北京""上海")("静安区""朝阳区""房山区""崇明区""成都""酉阳"))0)
  17. (("北京" "朝阳区") ("北京" "房山区") ("上海" "静安区") ("上海" "崇明区") ("四川" "成都") ("重庆" "酉阳"))




点评

文不对题。排序依据根本没有涉及到发音。。。排序的依据是给定的关键字次序  发表于 2022-11-9 14:02
 楼主| 发表于 2022-11-6 20:59:25 | 显示全部楼层
  1. (defun GetFolder(msg / WinShell shFolder path catchit);选取文件夹
  2.       (setq shFolder(vlax-invoke-method (vlax-create-object "Shell.Application")'BrowseForFolder 0 msg 1))
  3.       (setq  catchit(vl-catch-all-apply'(lambda()(setq shFolder(vlax-get-property shFolder'self))
  4.             (setq path(vlax-get-property shFolder'path)))))
  5.       (if(vl-catch-all-error-p catchit)nil path))
  6. (defun xdirectory(folder)
  7.       (setq folder(list(list folder)))
  8.       (while(car(setq folder(cons(apply'append(mapcar'(lambda(x)(mapcar'(lambda(y)(strcat x"\\"y))(cddr(vl-directory-files X nil -1))))
  9.                  (car folder)))folder))))(apply'append folder))
  10. (defun getpath(msg ext / path paths files)
  11.   (and(setq path(GETFOLDER msg))
  12.       (setq paths(XDIRECTORY path))
  13.       (setq files(apply'append(mapcar'(lambda(x)(mapcar'(lambda(y)(strcat x "\\"y))(VL-DIRECTORY-FILES x ext 1)))paths)))
  14.       )(list paths files))
  15. (defun StrType(a / b c d e);;字符串分离全角、符号、字母、数字,存在问题:连续小数点与数字相连不能精确分离数字和小数点
  16.     (setq b(vl-string->list a))
  17.     (while b
  18.       (setq a(car b)b(cdr b)c(last d))
  19.       (if(or(not d)
  20.       (and(< 0 a 32)(< 0 c 32));;非打印字符
  21.       (or(= 46 a)(= 46 c)(and(< 47 a 58)(< 47 c 58)));数字和小数点
  22.       (vl-every'(lambda(x)(vl-some'(lambda(y)(<(car y)x(cadr y)))'((31 48)(57 65)(90 98)(122 129))))(list a c));其它字符包括小数点
  23.       (vl-every'(lambda(x)(vl-some'(lambda(y)(<(car y)x(cadr y)))'((64 91)(96 123))))(list a c));;字母
  24.       (and(> a 128)(> c 128)));;全角字符
  25.   (if(> a 128)(setq d(vl-list*(car b)a d)b(cdr b))(setq d(cons a d)))
  26.   (setq e(cons(reverse d)e)d(if(> a 128)(list(car b)a)(List a))b(if(> a 128)(cdr b)b))))
  27.     (mapcar'vl-list->string(reverse(cons(reverse d)e))))

  28. (defun c:tt(/ wdapp docs fs)
  29.   (and(setq wdapp(vlax-create-object"word.application"))
  30.       (setq docs(vlax-get-property wdapp 'documents)
  31.       files(cadr(getpath"选择文件夹,批量修改WORD文件名""*.doc*")))
  32.       (vl-every(function(lambda(x / doc i a b)
  33.       (setq doc(vlax-invoke-method docs'open x)Paragraphs(vlax-get-property doc'Paragraphs)i 0)
  34.       (while(not a)
  35.         (or(WCMATCH(setq i(1+ 0)a(vlax-get-property(vlax-get-property(vlax-invoke-method Paragraphs'item i)'range)'TEXT))"*\r")
  36.            (setq a nil)))
  37.       (vlax-invoke-method doc'close)
  38.       (if a(progn(setq a(substr a 1(1-(strlen a))))
  39.            (while(vl-position a fs)
  40.        (setq a(if(numberp(setq as(StrType a)b(read(last as))))
  41.           (apply'strcat(append(reverse(cdr(reverse as)))(list(itoa(1+ b)))))
  42.           (strcat a"1"))))
  43.            (setq fs(cons a fs))
  44.            (vl-file-rename x(strcat(VL-FILENAME-DIRECTORY x)"\\"a(VL-FILENAME-EXTENSION x)))))t))files)
  45.       (vlax-invoke-method wdapp'quit)))

发表于 2022-12-5 10:45:47 | 显示全部楼层
好帖子,收藏!!!
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-6 09:39 , Processed in 0.157051 second(s), 18 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表