社区 › 源码共享 › 复制文件相关函数（搬运非原创）

CAD智能@未来 发表于 2024-8-23 09:37:56

复制文件相关函数（搬运非原创）

本帖最后由 CAD智能@未来 于 2024-8-23 09:42 编辑


;功能： 复制文件或目录
(Defun vldos-copy (from to / sys folder)
(setq        from (vldos-formatpath from)
        to   (vldos-formatpath to)
)
(if (null (vl-file-directory-p to))
    (setq to (vldos-mkdir to))
)
(if (setq sys (vlax-get-or-create-object "Shell.Application"))
    (progn
      (if (setq folder (vlax-invoke-method sys 'namespace to))
        (progn
          (vlax-invoke-method folder 'copyhere from (+ 4 16))
          (vlax-release-object folder)
        )
      )
      (vlax-release-object sys)
    )
)
(princ)
)
;功能：复制目录下所有文件和目录
(Defun vldos-copy2 (From to / rtn)
(cond
    ((vl-file-directory-p From)
   (if (< (strlen to) 3)
       (setq to (strcat to "\\"))
       (if (not (vl-file-directory-p to))
       (vldos-mkdir to)
       )
   )
   (if (setq
           Rtn (vlax-get-or-create-object "Scripting.FileSystemObject")
       )
       (progn
       (vlax-invoke-method Rtn 'CopyFolder From to T)
       (vlax-release-object Rtn)
       (if (vl-file-directory-p to)
           (setq Rtn (vldos-formatpath to))
       )
       )
   )
    )
    ((findfile From)
   (vl-file-copy From to)
   (if (setq rtn (findfile to))
       (setq rtn (vldos-formatpath rtn))
   )
    )
)
rtn
)
;功能：自动创建参数中所有不存在的目录
(Defun vldos-MkDir (Folder / FolderX Fil FFF Pos DIR DRV)
(if (null
        (setq
          Fil (vlax-get-or-create-object "Scripting.FileSystemObject")
        )
      )
    (setq Folder nil)
    (progn
      (while (vl-string-search "/" Folder)
        (setq Folder (vl-string-subst "\\" "/" Folder))
      )
      (if (wcmatch Folder "*\\")
        (setq Folder (substr Folder 1 (1- (strlen Folder))))
      )
      (setq FolderX Folder)
      (while (setq Pos (vl-string-search "\\" Folder))
        (setq FFF    (cons (substr Folder 1 Pos) FFF)
              Folder (substr Folder (+ Pos 2))
        )
      )
      (setq FFF        (reverse (cons Folder FFF))
          DRV        (car FFF)
          FFF        (cdr FFF)
      )
      (foreach DIR FFF
        (if
          (null        (vl-file-directory-p (setq DRV (strcat DRV "\\" DIR)))
          )
           (vlax-invoke-method
             Fil
             'createfolder
             DRV
           )
        )
      )
      (vlax-release-object Fil)
      (if (setq Folder (vl-file-directory-p FolderX))
        (setq Folder (vldos-formatpath FolderX))
      )
    )
)
Folder
)
;功能：转换路径中字符 "/" 为 "\\" 并返回大写值
(Defun vldos-formatpath        (string)
(while (vl-string-search "/" string)
    (setq string (vl-string-subst "\\" "/" string))
)
(while (vl-string-search "\\\\" string)
    (setq string (vl-string-subst "\\" "\\\\" string))
)
(setq string (strcase string))
string
)

zark 发表于 2024-8-25 10:12:32

用DOS来会不会更快？

w379106181 发表于 2024-8-28 07:47:29

感谢大神分享

查看完整版本: 复制文件相关函数（搬运非原创）