VBA Outlook // BroseForFolder：如何访问所有文件夹（Explorer.exe）

Question

我需要你的帮助。 我必须添加什么代码才能访问所有文件夹（例如标准资源管理器窗口）。 特别是链接的文件夹。 非常感谢您的提前帮助。

这是我的代码：

Option Explicit
 Function BrowseForFolder(Optional OpenAt As Variant) As Variant

  Dim ShellApp As Object

 Set ShellApp = CreateObject("Shell.Application"). _
      BrowseForFolder(0, "Bitte den Ordner auswählen:", &H1000, OpenAt)

 'Set BrowseDir = ShellApp.BrowseForFolder(0, "Bitte Ordner auswählen", &H4000, OpenAt)

 On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
     On Error GoTo 0

 Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
       Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
   Exit Function

Invalid:
 BrowseForFolder = False


End Function

Public Sub speichern()

    Dim oMail As Outlook.mailitem
    Dim objItem As Object
    Dim sPath, strFolderpath As String
    Dim dtDate As Date
    Dim sName As String
    Dim enviro As String

    enviro = CStr(Environ("USERPROFILE"))

    strFolderpath = BrowseForFolder
    sPath = strFolderpath & "\"

    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem
            sName = oMail.Subject
            ReplaceCharsForFileName sName, "-"
            dtDate = oMail.ReceivedTime
            sName = Format(dtDate, "yyyy-mm-dd", vbUseSystemDayOfWeek, _
              vbUseSystem) & " " & "-" & " " & UCase(Split(Trim(Split(objItem.SenderEmailAddress, "@")(0)), ".")(1)) & " " & "-" & " " & sName & ".msg"
            Debug.Print sPath & sName
            sName = InputBox( _
            prompt:="Dateiname. Bei Fertigstellung OK klicken.", _
            Default:=sName)
            oMail.SaveAs sPath & sName, olMSG
         End If
    Next
End Sub

   Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

Answer 1

Hummm，我刚刚不到1分钟前回答了这样的问题。 我想您想列出所有文件夹和所有子文件夹中的所有文件。 查看此链接。

http://www.learnexcelmacro.com/wp/2011/11/how-to-get-list-of-all-files-in-a-folder-and-sub-folders/

下载文件； 那是要走的路。

i）用户想要获取文件夹中所有文件的列表复制并粘贴以下代码，这将列出该文件夹中所有文件的列表。 这将仅列出指定文件夹中的所有文件。 其他子文件夹中是否有其他文件。 查看普通副本到剪贴板吗？

Sub GetFilesInFolder(SourceFolderName As String)  

'--- For Example:Folder Name= "D:\Folder Name\"  

Dim FSO As Scripting.FileSystemObject  
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder  
Dim FileItem As Scripting.File  

    Set FSO = New Scripting.FileSystemObject  
    Set SourceFolder = FSO.GetFolder(SourceFolderName)  

    '--- This is for displaying, whereever you want can be configured  

    r = 14  
    For Each FileItem In SourceFolder.Files  
        Cells(r, 2).Formula = r - 13  
        Cells(r, 3).Formula = FileItem.Name  
        Cells(r, 4).Formula = FileItem.Path  
        Cells(r, 5).Formula = FileItem.Size  
        Cells(r, 6).Formula = FileItem.Type  
        Cells(r, 7).Formula = FileItem.DateLastModified  
        Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"  

        r = r + 1   ' next row number  
    Next FileItem  

    Set FileItem = Nothing  
    Set SourceFolder = Nothing  
    Set FSO = Nothing  
End Sub

ii）用户想要获取文件夹内所有文件的列表以及子文件夹，请复制并粘贴以下代码，这将列出该文件夹内所有文件以及子文件夹的列表。 如果某些其他子文件夹中还有其他文件，则它将列出每个文件夹和子文件夹中的所有文件。 查看普通副本到剪贴板吗？

Sub GetFilesInFolder(SourceFolderName As String, Subfolders As Boolean)  

'--- For Example:Folder Name= "D:\Folder Name\" and Flag as Yes or No  

Dim FSO As Scripting.FileSystemObject  
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder  
Dim FileItem As Scripting.File  
'Dim r As Long  
    Set FSO = New Scripting.FileSystemObject  
    Set SourceFolder = FSO.GetFolder(SourceFolderName)  

    '--- This is for displaying, whereever you want can be configured  

    r = 14  
    For Each FileItem In SourceFolder.Files  
        Cells(r, 2).Formula = r - 13  
        Cells(r, 3).Formula = FileItem.Name  
        Cells(r, 4).Formula = FileItem.Path  
        Cells(r, 5).Formula = FileItem.Size  
        Cells(r, 6).Formula = FileItem.Type  
        Cells(r, 7).Formula = FileItem.DateLastModified  
        Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"  

        r = r + 1   ' next row number  
    Next FileItem  

    '--- This is the Function to go each and Every Folder and get the Files. This is a Nested-Function Calling.  

    If Subfolders = True Then  
        For Each SubFolder In SourceFolder.Subfolders  
            ListFilesInFolder SubFolder.Path, True  
        Next SubFolder  
    End If  

    Set FileItem = Nothing  
    Set SourceFolder = Nothing  
    Set FSO = Nothing  
End Sub