【K:CopySupportFile 】复制给定路径下给定格式的文件到支持路径

kucha007 · 发表于 2023-3-25 00:21:37

本帖最后由 kucha007 于 2023-3-25 01:31 编辑

用来复制<acadiso.pat>或<acad.pat>等常用的文件：

;复制给定路径下给定格式的文件到支持路径
(defun K:CopySupportFile (/ K:GetSubPath k:GetSupportPath SearchPath FileTypes PathLst FNamLst pt ft)
(vl-load-com)
(setq SearchPath "C:\\WorkTools");存放常用文件的路径
(setq FileTypes '("*.pat" "*.shx" "*.lin"));搜索文件格式类型，可自行添加
(progn ;基础函数
;返回所有子路径
(defun K:GetSubPath (Path / Folder)
(mapcar
'(lambda (x)
(setq Folder (strcat Path "\\" x))
(cons Folder (apply 'append (K:GetSubPath Folder)))
)
(cddr (vl-directory-files Path nil -1))
)
)
;返回图案所在的路径; by Gu_xl
(defun k:GetSupportPath (/ Tmp PatNam)
(if (= 1 (getvar 'measurement)) ;公制
(setq PatNam (getenv "ISOHatch")) ;公制
(setq PatNam (getenv "ANSIHatch")) ;英制
)
(if (setq Tmp (findfile (getenv "ISOHatch")))
(vl-filename-directory Tmp)
(progn
(setq Tmp (getvar 'roamablerootprefix))
(or (eq "\\" (substr Tmp (strlen Tmp)))
(setq Tmp (strcat Tmp "\\"))
)
(strcat Tmp "support")
)
)
)
(setq PathLst (apply 'append (cons (list SearchPath) (K:GetSubPath SearchPath))));获取所有路径
)
;-------------------
(if (vl-file-directory-p SearchPath);文件夹存在
(progn
(mapcar
'(lambda (pt)
(mapcar
'(lambda (ft)
(if (setq FNamLst (vl-directory-files pt ft 1))
(foreach fn FNamLst
(vl-file-copy (strcat pt "\\" fn) (strcat (k:GetSupportPath) "\\" fn) T)
)
)
)
FileTypes
)
)
PathLst
)
(while (> (getvar "CMDACTIVE") 0) (command PAUSE));等待前面的命令完成
(alert "文件已全部复制完成！")
)
(alert (strcat "文件夹<" SearchPath ">不存在"))
)
(princ)
)

;复制给定路径下给定格式的文件到支持路径 
(defun K:CopySupportFile (/ K:GetSubPath k:GetSupportPath SearchPath FileTypes PathLst FNamLst pt ft) 
  (vl-load-com) 
  (setq SearchPath "C:\\WorkTools");存放常用文件的路径 
  (setq FileTypes '("*.pat" "*.shx" "*.lin"));搜索文件格式类型，可自行添加 
   
  (progn ;基础函数 
    ;返回所有子路径 
    (defun K:GetSubPath (Path / Folder) 
      (mapcar 
        '(lambda (x) 
          (setq Folder (strcat Path "\\" x)) 
          (cons Folder (apply 'append (K:GetSubPath Folder))) 
        ) 
        (cddr (vl-directory-files Path nil -1)) 
      ) 
    ) 
    ;返回图案所在的路径; by Gu_xl 
    (defun k:GetSupportPath (/ Tmp PatNam) 
      (if (= 1 (getvar 'measurement)) ;公制 
        (setq PatNam (getenv "ISOHatch")) ;公制 
        (setq PatNam (getenv "ANSIHatch")) ;英制 
      ) 
      (if (setq Tmp (findfile (getenv "ISOHatch"))) 
        (vl-filename-directory Tmp) 
        (progn 
          (setq Tmp (getvar 'roamablerootprefix)) 
          (or (eq "\\" (substr Tmp (strlen Tmp))) 
              (setq Tmp (strcat Tmp "\\")) 
          ) 
          (strcat Tmp "support") 
        ) 
      ) 
    ) 
    (setq PathLst (apply 'append (cons (list SearchPath) (K:GetSubPath SearchPath))));获取所有路径 
  ) 
  ;------------------- 
  (if (vl-file-directory-p SearchPath);文件夹存在 
    (progn 
      (mapcar 
        '(lambda (pt) 
          (mapcar 
            '(lambda (ft) 
                (if (setq FNamLst (vl-directory-files pt ft 1)) 
                  (foreach fn FNamLst 
                    (vl-file-copy (strcat pt "\\" fn) (strcat (k:GetSupportPath) "\\" fn) T) 
                  ) 
                ) 
              ) 
            FileTypes 
          ) 
        ) 
        PathLst 
      ) 
      (while (> (getvar "CMDACTIVE") 0) (command PAUSE));等待前面的命令完成 
      (alert "文件已全部复制完成！") 
    ) 
    (alert (strcat "文件夹<" SearchPath ">不存在")) 
  ) 
  (princ) 
)

可以这样用：

(if (= 6 ;YES
(ACET-UI-MESSAGE
"复制<acadiso.pat>等文件到支持路径?"
"Copy_Support_File"
(+ Acet:YESNO Acet:ICONQUESTION)
)
)
(K:CopySupportFile)
(prin1)
)

cchessbd · 发表于 2023-3-25 14:04:59

本帖最后由 cchessbd 于 2023-3-25 14:06 编辑

您好，看到您有这个方面的研究，请教一下怎么添加线型到acadiso.lin呢？我是CAD 2008的用户。

我想加入自动运行，添加以下一些线型，但是我只需要添加一次，不需要每次都添加。
如果没有这些线型，那就添加。

;地质线型
*TLKC_BZHJZX, ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A,0,-0.35,[{shape138},ltypeshp.shx,s=0.3,r=0,x=-0.35,y=0],-2.65
*TLKC_BLDZJX,----x-----x----x-----x----x-----x--
A,6.35,-2.54,["x",TLStyle,s=2.54,r=0,x=-0.7,y=-1],-2.54

kucha007 · 发表于 2023-3-25 14:22:55

cchessbd 发表于 2023-3-25 14:04
您好，看到您有这个方面的研究，请教一下怎么添加线型到acadiso.lin呢？我是CAD 2008的用户。

我想加入 ...

我觉得你可以研究一下G版的程序，应该是差不多的原理？http://bbs.mjtd.com/forum.php?mod=viewthread&tid=91425&highlight=%CD%BC%B0%B8%2B%CC%EE%B3%E4

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

【K:CopySupportFile 】复制给定路径下给定格式的文件到支持路径

评分