自贡黄明儒 发表于 2024-8-20 09:38:54

保证路径所在文件夹存在

为了将我的.mun文件拷贝到指定文件夹下面，我写了如下程序，用点用处，但作用不太

;;(vlax-invoke-method (vlax-create-object "Scripting.FileSystemObject") "GetFolder" (getenv "public"))
;;返回存在的文件夹路径
(defun DIRECTORY-P (str / A FLAG L STR1);(setq str (strcat (getenv "public") "/b/"))
(setq str1 (fnsplitl str))
(cond        ((and str1 (/= (last str1) ""))
       (setq str (vl-string-right-trim "/\\" (car str1)))
        )                                ;(setq str "C:\\Users\\Public\\b/1.txt")
        ((= (last str1) "") (setq str str))
        ;;(setq str "C:\\Users\\Public\\b")
        (T (setq str (vl-string-right-trim "/\\" str)))
                                        ;(setq str "C:\\Users\\Public\\b\\")
)
(if (VL-FILE-DIRECTORY-P str)
    str
    (progn
      (setq L (parse4 str "/\\"))
      (setq str1 (car L))
      (setq L (cdr L))
      (while (and (setq a (car L))
                  (not Flag)
             )
        (setq L (cdr L))
        (if (VL-FILE-DIRECTORY-P (strcat str1 "\\" a))
          (setq str1 (strcat str1 "\\" a))
          (setq Flag T)
        )
      )
      str1
    )
)
)
;;(DIRECTORY-P (strcat (getenv "public") "/b/d.txt"))
;;(DIRECTORY-P (strcat "D:/" "块包围盒.lsp"))
;;(DIRECTORY-P (strcat (getenv "public") "/b"))

;;返回存在的文件夹路径,如果文件夹不存在，则创建
;;如果str是文件全路径，则保证路径所在文件夹存在
;;例如(VL-FILE-COPY "D:\\1.txt" "C:\\Users\\Public\\b/c/.txt"),如果没有文件夹b 和c 则创建;
;;以确保拷贝成功
(defun DIRECTORYMake-P (str / A L STR1)
(setq str1 (fnsplitl str))
(cond        ((and str1 (/= (last str1) ""))
       (setq str (vl-string-right-trim "/\\" (car str1)))
        )                                ;(setq str "C:\\Users\\Public\\b/1.txt")
        ((= (last str1) "") (setq str str))
        ;;(setq str "C:\\Users\\Public\\b")
        (T (setq str (vl-string-right-trim "/\\" str)))
                                        ;(setq str "C:\\Users\\Public\\b\\")
)
(if (VL-FILE-DIRECTORY-P str)
    str
    (progn
      (setq L (parse4 str "/\\"))
      (setq str1 (car L))
      (setq L (cdr L))
      (while (setq a (car L))
        (setq L (cdr L))
        (setq str1 (strcat str1 "\\" a))
        (if (not (VL-FILE-DIRECTORY-P str1))
          (vl-mkdir str1)
        )
      )
      str1
    )
)
)
;;(DIRECTORYMake-P "C:\\Users\\Public\\b/c")

ymcui 发表于 2024-8-20 09:57:32

好源码下载学习,谢谢

czb203 发表于 2024-8-20 10:12:42

向黄大师学习

muai2010 发表于 2024-8-20 11:19:34

支持黄大师

kozmosovia 发表于 2024-8-20 11:22:52

没必要那么麻烦，直接(vl-catch-all-apply 'vl-mkdir (list dir))

ghgh0130 发表于 2024-8-23 10:29:55

支持黄大师

LYC688 发表于 2024-8-27 02:38:14

(defun c:usb ()   (vl-load-com)   (setq fldr "D:\\123")   (setq selection (ssget "WP" '(0. "INSERT") (cons 2 "*.dwg")))   (if (null selection)   (princ "\n未选择到任何文件。")   (progn       (setq acadObj (vlax-get-acad-object))       (setq drives (vlax-invoke-method acadObj 'GetInterfaceObject "AutoCAD.Application.19"))       (setq usbDrive nil)       (foreach drive drives         (if (vlax-get-property drive 'DriveType)             (if (= (vlax-get-property drive 'DriveType) 2)               (setq usbDrive drive)             )         )       )       (if usbDrive         (progn             (repeat (sslength selection)               (setq ent (ssname selection (setq i (1+ i))))               (setq block-ref (vlax-ename->vla-object ent))               (setq file-path (vla-get-pathname block-ref))               (vl-file-copy file-path (strcat (vlax-get-property usbDrive 'RootDirectory) "\\123\\" (vl-filename-base file-path) ".dwg"))             )             (princ "\n文件复制成功到 U 盘。")         )         (princ "\n未找到 U 盘。")       )   )   )   (princ) )
页: [1]
查看完整版本: 保证路径所在文件夹存在