Outlook - Entwürfe - Mails...

Frage: In Outlook im Ordner Entwürfe liegen einige Mails. Diese werden vor dem verschicken noch bearbeitet. Z. B. sollen Anhänge hinzugefügt werden. Das Beispiel unten funktioniert natürlich nur, wenn auch Mails im Ordner Entwürfe vorhanden sind!

In Outlook Drafts folder are some mails. These are still being processed before sending. E.G. attachments should be added. The example below only works if there are messages in the Drafts folder!

Hier noch eine Beispieldatei / Here's a sample file:
Outlook - Entwürfe - Mails...[XLS 40 KB]

OptionExplicit
Dim blnTMP AsBoolean
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 05.02.2013 
' Purpose   : Outlook Entwürfe auf Mails zugreifen... 
'-------------------------------------------------------------------------- 
PublicSub Main()
    Dim objNameSpace AsObject
    Dim objFolder AsObject
    Dim objItem AsObject
    Dim objApp AsObject
    OnErrorGoTo Fin
    'Set objApp = OffApp("Word") 
    'Set objApp = OffApp("Word", False) 
    Set objApp = OffApp("Outlook")
    'Set objApp = OffApp("Outlook", False) 
    'Set objApp = OffApp("PowerPoint") 
    'Set objApp = OffApp("PowerPoint, False") 
    'Set objApp = OffApp("ACCESS") 
    'Set objApp = OffApp("ACCESS", False) 
    IfNot objApp IsNothingThen
        Set objNameSpace = objApp.GetNamespace("MAPI")
        ' Nachfolgend die Elemente bzw. Konstanten von "OlDefaultFolders" 
        ' Entnommen aus Objektkatalog (F2 im VBA-Editor) in Outlook 2010 
        'Const olFolderCalendar = 9 
        'Const olFolderConflicts = 19 
        'Const olFolderContacts = 10 
        'Const olFolderDeletedItems = 3 
        Const olFolderDrafts = 16
        'Const olFolderInbox = 6 
        'Const olFolderJournal = 11 
        'Const olFolderJunk = 23 
        'Const olFolderLocalFailures = 21 
        'Const olFolderManagedEmail = 29 
        'Const olFolderNotes = 12 
        'Const olFolderOutbox = 4 
        'Const olFolderRssFeeds = 25 
        'Const olFolderSentMail = 5 
        'Const olFolderServerFailures = 22 
        'Const olFolderSuggestedContacts = 30 
        'Const olFolderSyncIssues = 20 
        'Const olFolderTasks = 13 
        'Const olFolderToDo = 28 
        'Const olPublicFoldersAllPublicFolders = 18 
        ' Hier ist jetzt der Ordner "Entwürfe" = "olFolderDrafts" = 16 
        Set objFolder = objNameSpace.GetDefaultFolder(olFolderDrafts)
        ' Ist überhaupt eine Mail in Entwürfe, dann... 
        If objFolder.Items.Count > 0Then
            ' Schleife über alle Mails in Entwürfe 
            ForEach objItem In objFolder.Items
                ' Ausgabe Anzahl der Anhänge 
                Debug.Print objItem.Attachments.Count
                ' Zwei Dateien anhängen 
                objItem.Attachments.Add "C:\Temp\Test.doc"
                objItem.Attachments.Add "C:\Temp\Test.txt"
                ' Ausgabe Anzahl der Anhänge 
                Debug.Print objItem.Attachments.Count
            Next objItem
        Else
            ' Hinweis - es ist keine Mail in Entwürfe 
            MsgBox "There are "& objFolder.Items.Count &" mail in draft."
        EndIf
    Else
        MsgBox "Application not installed!"
    EndIf
Fin:
    IfNot objApp IsNothingThen
        If blnTMP = TrueThen
            objApp.Quit
            blnTMP = False
        EndIf
    EndIf
    Set objFolder = Nothing
    Set objNameSpace = Nothing
    Set objApp = Nothing
    If Err.Number <> 0Then MsgBox "Error: "& _
        Err.Number &" "& Err.Description
EndSub
PrivateFunction OffApp(ByVal strApp AsString, _
    Optional blnVisible AsBoolean = True) AsObject
    Dim objApp AsObject
    OnErrorResumeNext
    Set objApp = GetObject(, strApp &".Application")
    SelectCase Err.Number
        Case429
            Err.Clear
            Set objApp = CreateObject(strApp &".Application")
            blnTMP = True
            If blnVisible = TrueThen
                OnErrorResumeNext
                objApp.Visible = True
                Err.Clear
            EndIf
    EndSelect
    OnErrorGoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
EndFunction

Wenn Sie weitere Informationen über die Mails im Ordner Entwürfe brauchen, dann klicken Sie einen Haltepunkt (oder F9) in folgender Codezeile "Debug.Print objItem.Attachments.Count". Verschiedene Informationen können im VBA Editor im Lokalfenster (z. B. Empfänger, Bodytext...) kontrolliert werden.

If you need more information about the messages in the Drafts folder, then click a breakpoint (or F9) in the following line of code "Debug.Print objItem.Attachments.Count". Various information in the VBA editor in the local window can be controlled (eg, recipient, body text ...).