Exporter des dossiers Outlook Exchange vers le système de fichiers Windows

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

Comme vous ne l’avez pas précisé si cela DOIT être fait via le script VB de la vieille école ... je voudrais utiliser Services Web Exchange puis exporter les courriels de cette façon vers un serveur de fichiers. Vous n'avez pas besoin d'un client Outlook ici. Cependant, vous devez écrire quelque chose en C #. Ici est un exemple:

private static void ExportMIMEEmail(ExchangeService service)
{
    Folder inbox = Folder.Bind(service, WellKnownFolderName.Inbox);
    ItemView view = new ItemView(1);
    view.PropertySet = new PropertySet(BasePropertySet.IdOnly);

    // This results in a FindItem call to EWS.
    FindItemsResults<Item> results = inbox.FindItems(view);

    foreach (var item in results)
    { 
        PropertySet props = new PropertySet(EmailMessageSchema.MimeContent);

        // This results in a GetItem call to EWS.
        var email = EmailMessage.Bind(service, item.Id, props);

        string emlFileName = @"C:\export\email.eml";
        string mhtFileName = @"C:\export\email.mht";

        // Save as .eml.
        using (FileStream fs = new FileStream(emlFileName, FileMode.Create, FileAccess.Write))
        {
            fs.Write(email.MimeContent.Content, 0, email.MimeContent.Content.Length);
        }

        // Save as .mht.
        using (FileStream fs = new FileStream(mhtFileName, FileMode.Create, FileAccess.Write))
        {
            fs.Write(email.MimeContent.Content, 0, email.MimeContent.Content.Length);
        }
    }
}