文件夹操作Dir.cls

Option Explicit
Private Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Long
    hNameMappings As Long
    lpszProgressTitle As String '只有在 FOF_SIMPLEPROGRESS 时用
End Type

Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

'wFunc 常数
Const FO_COPY = &H2 'FO_COPY　 把 pFrom 文件拷贝到 pTo。
Const FO_DELETE = &H3 'FO_DELETE 删除 pFrom 中的文件（pTo 忽略）。
Const FO_MOVE = &H1 'FO_MOVE　 把 pFrom 文件移动到 pTo。

'fFlag 常数
Const FOF_ALLOWUNDO = &H40 '允许 Undo 。
Const FOF_NOCONFIRMATION = &H10 '不显示系统确认对话框。
Const FOF_NOCONFIRMMKDIR = &H200 '不提示是否新建目录。
Const FOF_SILENT = &H4 'FOF_SILENT 不显示进度对话框
'FOF_NOCONFIRMATION
'vbNormal 0 (缺省) 指定没有属性的文件。
'vbReadOnly 1 指定无属性的只读文件
'vbHidden 2 指定无属性的隐藏文件
'VbSystem 4 指定无属性的系统文件
'vbVolume 8 指定卷标文件；如果指定了其它属性，则忽略vbVolume
'vbDirectory 16 指定无属性文件及其路径和文件夹。


'如果存在就算了，不存在就创建
'验证方式，无目录，隐藏目录，系统目录，只读目录...
Public Sub 创建(路径 As String)
    If Dir(路径, vbDirectory) = "" Then
        MkDir 路径
    End If
End Sub

'移动文件或者目录
Public Sub ApiMove(P1 As String, P2 As String)
    Dim SHFileOp As SHFILEOPSTRUCT
    ' 移动
    SHFileOp.wFunc = FO_MOVE
    SHFileOp.pFrom = P1 + Chr(0)
    SHFileOp.pTo = P2
    SHFileOp.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
    Call SHFileOperation(SHFileOp)
End Sub

'复制文件或者目录
Public Sub ApiCopy(P1 As String, P2 As String, Optional Fok As Boolean = False)
    Dim SHFileOp As SHFILEOPSTRUCT
    ' 拷贝
    SHFileOp.wFunc = FO_COPY
    SHFileOp.pFrom = P1
    SHFileOp.pTo = P2
    If Fok = True Then
        SHFileOp.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMMKDIR + FOF_NOCONFIRMATION
    Else
        SHFileOp.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMMKDIR
    End If
    Call SHFileOperation(SHFileOp)
End Sub

'返回子目录列表
Public Function Dirs(Path As String) As String()
On Error GoTo E100
Dim S() As String, I As Long
Dim MyName As String
MyName = Dir(Path, vbDirectory Or vbHidden Or vbSystem Or vbReadOnly) ' 找寻第一项。
ReDim S(250)
S(0) = MyName
Do While MyName <> "" ' 开始循环。
   If MyName <> "." And MyName <> ".." Then

      If (GetAttr(Path & MyName) And vbDirectory) = vbDirectory Then
         S(I) = MyName
         I = I + 1
         If I > UBound(S) Then
            ReDim Preserve S(I + 250)
         End If
      End If
      
   End If
E100:
   MyName = Dir
Loop

ReDim Preserve S(I - 1)
Dirs = S
End Function


'返回子目录列表
Public Function Files(Path As String) As String()
On Error GoTo E100
Dim S() As String, I As Long
Dim MyName As String
MyName = Dir(Path, vbHidden Or vbSystem Or vbReadOnly) ' 找寻第一项。
ReDim S(250)
S(0) = MyName
Do While MyName <> "" ' 开始循环。
   If MyName <> "." And MyName <> ".." Then

      If (GetAttr(Path & MyName) And vbDirectory) <> vbDirectory Then
         S(I) = MyName
         I = I + 1
         If I > UBound(S) Then
            ReDim Preserve S(I + 250)
         End If
      End If
      
   End If
E100:
   MyName = Dir
Loop

ReDim Preserve S(I - 1)
Files = S
End Function

'判断文件或者文件夹是否存在
Public Function 存在(Path As String) As Boolean
    If Right(Path, 1) = "\" Then Path = Left(Path, Len(Path) - 1)
    存在 = False
    If Len(Trim(Path)) < 1 Then Exit Function
    '判断是否存在
    If Dir(Path, vbDirectory Or vbHidden Or vbSystem Or vbNormal Or vbReadOnly) <> "" Then
        '判断是否文件夹
        If (GetAttr(Path) And vbDirectory) = vbDirectory Then
            存在 = True '是文件夹
        End If
    End If
End Function

'返回目录名称
Public Function DirName(Path As String) As String

End Function