vba创建多级目录和删除多级目录的自定义函数

mythqiu

创建多级目录：（解决mkdir只能创建一个目录问题）

1. Function MKDirs(Str As String) As Boolean
   
2. Rem mkdir的升级版本，根据目录地址创建文件夹
   
3. Rem 使用方法Call MKDirs("D:\test\test2\test3")
   
4. Rem if MKDirs("D:\test\test2\test3")=True then doSomething  else doOtherSomething
   
5.     On Error Resume Next
   
6.     Dim arr, i%, newStr$
   
7.     If Len(Str) = 0 Then Exit Function
   
8.     If InStr(1, Str, "\") > 0 Then
   
9.         arr = Split(Str, "\")
   
10.         For i = 0 To UBound(arr)
    
11.             If Len(arr(i)) > 0 Then
    
12.                 newStr = newStr & arr(i) & "\"
    
13.                 If Dir(newStr, vbDirectory) = "" Then
    
14.                     MkDir newStr
    
15.                     If Err.number <> 0 Then GoTo ele
    
16.                 End If
    
17.             End If
    
18.         Next i
    
19.     Else
    
20.         If Dir(Str, vbDirectory) = "" Then
    
21.             MkDir Str
    
22.             If Err.number <> 0 Then GoTo ele
    
23.         End If
    
24.     End If
    
25.     MKDirs = True   '创建多级目录成功
    
26.     Exit Function
    
27. ele:
    
28.     MKDirs = False  '创建多级目录失败
    
29.     'MsgBox Err.number & Err.Description
    
30. End Function

复制代码

删除多级目录：如 call rmdirs("D:\test") 将删除此test目录下所有目录和文件

1. Function RMDirs(Str As String) As Boolean
   
2. Rem RMdir的升级版本，根据目录地址删除最后文件夹及里面的文件
   
3. Rem 使用方法Call RMDirs("D:\test\test2\test3")
   
4. Rem if RMDirs("D:\test\test2\test3")=True then doSomething  else doOtherSomething
   
5.     Err.Clear
   
6.     On Error GoTo ele
   
7.     Dim fs, f
   
8.     If Len(Str) = 0 Then Exit Function
   
9.     Set fs = CreateObject("Scripting.FileSystemObject")
   
10.     Set f = fs.GetFolder(Str)
    
11.     f.Delete
    
12.     RMDirs = True   '删除多级目录成功
    
13.     Set fs = Nothing
    
14.     Set f = Nothing
    
15.     Exit Function
    
16. ele:
    
17.     RMDirs = False  '删除多级目录失败
    
18.     Set fs = Nothing
    
19.     Set f = Nothing
    
20.     'MsgBox Err.number & Err.Description
    
21. End Function

复制代码

mythqiu

自己收藏方便查找之用

逍遥爱迪生

Function CreateFolder(ByVal szCheckFolder As String) As Boolean
   
    Dim szFolderBuff()        As String
    Dim nFolderLayer        As Long
    Dim szFolderNow         As String
    Dim i                   As Long

    Dim szFolder            As String
      
    szFolderNow = ""
    Dim Lefts As String, ID As Long
    If Dir(szCheckFolder, vbDirectory) <> "" Then
        CreateFolder = True
        Exit Function
    End If
    ID = InStr(3, szCheckFolder, "\")
    If ID > 0 Then
        Lefts = Left(szCheckFolder, ID - 1)
        szCheckFolder = Mid(szCheckFolder, ID)
    End If
    'lefts=
    szFolderBuff = Split(szCheckFolder, "\")
    nFolderLayer = UBound(szFolderBuff)
    On Error Resume Next
    If nFolderLayer < 1 Then
        CreateFolder = False
    Else
        szFolderNow = szFolderBuff(0)
        szFolderNow = Lefts & szFolderNow
        For i = 1 To UBound(szFolderBuff)
            Err.Clear
            szFolderNow = szFolderNow & "\" & szFolderBuff(i)
            szFolder = Dir(szFolderNow & "\", vbDirectory)
            If 0 = Len(szFolder) Then
                MkDir szFolderNow
                'CreateDirectory(szFolderNow
               
            End If
        Next i
    End If
CreateFolder = Err.Number = 0
End Function

逍遥爱迪生

Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, Optional ByVal psa As Long) As Long

Function MakeDir2(Forlder1 As String) As Boolean
    ' 如果hwnd 設定為 Null,則不會顯示任何使用者介面
    MakeDir2 = SHCreateDirectoryEx(0, Forlder1) = 0
End Function