Dim xFSO As Scripting.FileSystemObject Sub CopyOutlookFldStructureToWinExplorer() ExportAction "Copy" End Sub Sub ExportAction(xAction As String) Dim xFolder As Outlook.Folder Dim xFldPath As String xFldPath = SelectAFolder() If xFldPath = "" Then MsgBox "You did not select a folder. Export cancelled.", vbInformation + vbOKOnly, "Kutools for Outlook" Else Set xFSO = New Scripting.FileSystemObject Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder ExportOutlookFolder xFolder, xFldPath End If Set xFolder = Nothing Set xFSO = Nothing End Sub Sub ExportOutlookFolder(ByVal OutlookFolder As Outlook.Folder, xFldPath As String) Dim xSubFld As Outlook.Folder Dim xItem As Object Dim xPath As String Dim xFilePath As String Dim xSubject As String Dim xCount As Integer Dim xFilename As String On Error Resume Next xPath = xFldPath & "\" & OutlookFolder.Name '?????????,?????? If Dir(xPath, 16) = Empty Then MkDir xPath For Each xItem In OutlookFolder.Items xSubject = ReplaceInvalidCharacters(xItem.subject) xFilename = xSubject & ".msg" xCount = 0 xFilePath = xPath & "\" & xFilename If xFSO.FileExists(xFilePath) Then xCount = xCount + 1 xFilename = xSubject & " (" & xCount & ").msg" xFilePath = xPath & "\" & xFilename End If xItem.SaveAs xFilePath, olMSG Next For Each xSubFld In OutlookFolder.Folders ExportOutlookFolder xSubFld, xPath Next Set OutlookFolder = Nothing Set xItem = Nothing End Sub Function SelectAFolder() As String Dim xSelFolder As Object Dim xShell As Object On Error Resume Next Set xShell = CreateObject("Shell.Application") Set xSelFolder = xShell.BrowseForFolder(0, "Select a folder", 0, 0) If Not TypeName(xSelFolder) = "Nothing" Then SelectAFolder = xSelFolder.Self.Path End If Set xSelFolder = Nothing Set xShell = Nothing End Function Function ReplaceInvalidCharacters(Str As String) As String Dim xRegEx Set xRegEx = CreateObject("vbscript.regexp") xRegEx.Global = True xRegEx.IgnoreCase = False xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?" ReplaceInvalidCharacters = xRegEx.Replace(Str, "") End Function
Preview:
downloadDownload PNG
downloadDownload JPEG
downloadDownload SVG
Tip: You can change the style, width & colours of the snippet with the inspect tool before clicking Download!
Click to optimize width for Twitter