李大仁博客

'VBA Base64 编码/加密函数：
Function Base64Encode(StrA As String) As String                                  'Base64 编码
    On Error GoTo over                                                          '排错
    Dim buf() As Byte, length As Long, mods As Long
    Dim Str() As Byte
    Dim i, kk As Integer
    kk = Len(StrA) - 1
    ReDim Str(kk)
    For i = 0 To kk
        Str(i) = Asc(Mid(StrA, i + 1, 1))
    Next i
    Const B64_CHAR_DICT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
    mods = (UBound(Str) + 1) Mod 3   '除以3的余数
    length = UBound(Str) + 1 - mods
    ReDim buf(length / 3 * 4 + IIf(mods <> 0, 4, 0) - 1)
    For i = 0 To length - 1 Step 3
        buf(i / 3 * 4) = (Str(i) And &HFC) / &H4
        buf(i / 3 * 4 + 1) = (Str(i) And &H3) * &H10 + (Str(i + 1) And &HF0) / &H10
        buf(i / 3 * 4 + 2) = (Str(i + 1) And &HF) * &H4 + (Str(i + 2) And &HC0) / &H40
        buf(i / 3 * 4 + 3) = Str(i + 2) And &H3F
    Next
    If mods = 1 Then
        buf(length / 3 * 4) = (Str(length) And &HFC) / &H4
        buf(length / 3 * 4 + 1) = (Str(length) And &H3) * &H10
        buf(length / 3 * 4 + 2) = 64
        buf(length / 3 * 4 + 3) = 64
    ElseIf mods = 2 Then
        buf(length / 3 * 4) = (Str(length) And &HFC) / &H4
        buf(length / 3 * 4 + 1) = (Str(length) And &H3) * &H10 + (Str(length + 1) And &HF0) / &H10
        buf(length / 3 * 4 + 2) = (Str(length + 1) And &HF) * &H4
        buf(length / 3 * 4 + 3) = 64
    End If
    For i = 0 To UBound(buf)
        Base64Encode = Base64Encode + Mid(B64_CHAR_DICT, buf(i) + 1, 1)
    Next
over:
End Function

'需要遍历的目录路径
dim strDirPath = "c:\dir"
 
'遍历目录
Private Sub FileTree(strPath)
    Set obFso = CreateObject("Scripting.FileSystemObject")
    If obFso.FolderExists(strPath) Then
        Set obFolder = obFso.GetFolder(strPath)
        '遍历当前目录下的所有目录，递归调用
        Set obSubFolders = obFolder.SubFolders
        For Each obSubFolder In obSubFolders
            Call FileTree(obSubFolder.Path & "")
        Next
        '剔除当前目录
        If strPath = Trim(strDirPath) Then
            Exit Sub
        End If
        '遍历当前目录下的所有文件
        Set obFiles = obFolder.Files
        For Each obFile In obFiles
            Call ExcuteFolderConcentrate(obFile.Path & "")
        Next
    Else
        MsgBox "Invalide Path"
        Exit Sub
    End If
End Sub
 
'文件归集操作
Private Sub ExcuteFolderConcentrate(strPath)
    Set obFso = CreateObject("Scripting.FileSystemObject")
    If obFso.FileExists(strPath) Then
        fullPath = Trim(strDirPath) & “\"
        '按目录层级设置新文件名
        newFileName = Replace(Right(strPath, Len(strPath) - Len(fullPath)), "\", "_”)
        '重复文件重新命名
        If obFso.FileExists(fullPath & newFileName) Then
            Call obFso.copyFile(strPath, fullPath & newFileName & ".duplicate")
        Else
            Call obFso.copyFile(strPath, fullPath & newFileName)
        End If
    End If
End Sub
 
'遍历整个目录，完成文件归集
FileTree (strDirPath)
'重新打开目录文件夹
CreateObject("Shell.Application").Explore strDirPath