Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ' SET STARTING FOLDER IN FODLER CHOOSER AS USERS [P DRIVE]
- Const STARTING_FOLDER = "P:"
- Dim objFSO As Object
- ' [COPY] THE OUTLOOK FOLDER
- Sub CopyOutlookFolderToFileSystem()
- ExportController "Copy"
- End Sub
- ' [MOVE] THE OUTLOOK FOLDER
- Sub MoveOutlookFolderToFileSystem()
- ExportController "Move"
- End Sub
- ' [USER] SELECTION OF FOLDER TO SAVE MESSAGES INTO ON SYSTEM
- Sub ExportController(strAction As String)
- Dim olkFld As Outlook.MAPIFolder, strPath As String
- strPath = SelectFolder(STARTING_FOLDER)
- If strPath = "" Then
- MsgBox "No Folder selected! Export cancelled.", vbInformation + vbOKOnly, "Export Outlook Folder"
- Else
- Set objFSO = CreateObject("Scripting.FileSystemObject")
- Set olkFld = Application.ActiveExplorer.CurrentFolder
- ExportOutlookFolder olkFld, strPath
- If LCase(strAction) = "move" Then olkFld.Delete
- End If
- Set olkFld = Nothing
- Set objFSO = Nothing
- End Sub
- ' FOR [ALL] MESSAGES IN THE FOLDER, EXPORT [ALL] MESSAGES
- Sub ExportOutlookFolder(ByVal olkFld As Outlook.MAPIFolder, strStartingPath As String)
- Dim olkSub As Outlook.MAPIFolder, olkItm As Object, strPath As String, strMyPath As String, strSubejct As String, intCount As Integer
- strPath = strStartingPath & "\" & olkFld.Name
- objFSO.CreateFolder strPath
- For Each olkItm In olkFld.Items
- strSubject = "[From] " & olkItm.SenderName & " [Subject] " & RemoveIllegalCharacters(olkItm.Subject)
- strFilename = strSubject & ".msg"
- intCount = 0
- Do While True
- strMyPath = strPath & "\" & strFilename
- If objFSO.FileExists(strMyPath) Then
- intCount = intCount + 1
- strFilename = strSubject & " (" & intCount & ").msg"
- Else
- Exit Do
- End If
- Loop
- olkItm.SaveAs strMyPath, olMSG
- ChangeTimeStamp strMyPath, olkItm.ReceivedTime
- Next
- For Each olkSub In olkFld.Folders
- ExportOutlookFolder olkSub, strPath
- Next
- Set olkFld = Nothing
- Set olkItm = Nothing
- End Sub
- Function SelectFolder(varStartingFolder As Variant) As String
- ' STANDARD ERROR HANDLING
- Dim objFolder As Object, objShell As Object
- On Error Resume Next
- ' CREATE A DIALOG OBJECT FOR FOLDER SELECTION & RETURN THE FOLDER [PATH]
- Set objShell = CreateObject("Shell.Application")
- Set objFolder = objShell.BrowseForFolder(0, "Select the System folder you want to export to ...", 0, varStartingFolder)
- If TypeName(objFolder) <> "Nothing" Then SelectFolder = objFolder.self.Path
- ' STANDARD ERROR HANDLING
- Set objFolder = Nothing
- Set objShell = Nothing
- On Error GoTo 0
- End Function
- Function RemoveIllegalCharacters(strValue As String) As String
- ' REMOVE [ALL CHARACTERS] THAT CANNOT BE CONTAINED IN A FILESYSTEM NAME
- RemoveIllegalCharacters = strValue
- RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "<", "")
- RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ">", "")
- RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ":", "")
- RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), "'")
- RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "/", "")
- RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "\", "")
- RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "|", "")
- RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "?", "")
- RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "*", "")
- End Function
- Sub ChangeTimeStamp(strFile As String, datStamp As Date)
- ' SAVE IN THE FILENAME THE [TIME] AND [DATE] OF THE [ORIGINAL] MESSAGE BEING SENT/RECIEVED
- Dim objShell As Object, objFolder As Object, objFolderItem As Object, varPath As Variant, varName As Variant
- varName = Mid(strFile, InStrRev(strFile, "\") + 1)
- varPath = Mid(strFile, 1, InStrRev(strFile, "\"))
- Set objShell = CreateObject("Shell.Application")
- Set objFolder = objShell.NameSpace(varPath)
- Set objFolderItem = objFolder.ParseName(varName)
- objFolderItem.ModifyDate = CStr(datStamp)
- Set objShell = Nothing
- Set objFolder = Nothing
- Set objFolderItem = Nothing
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement