Actuellement, une macro VBA est utilisée pour extraire des dossiers d’e-mails vers le système de fichiers Windows, mais il n’est pas en mesure d’extraire les dossiers stockés sur un serveur Exchange. Est-ce possible? Utiliser le VBScript ci-dessous
' 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
windows-7
microsoft-outlook
vba
exchange
visual-basic
Ryan Jacques
la source
la source