Ontvangen e-mail opslaan als draft in outlook met VBA

[Axel05]

Hoi allen,

Ik probeer een inkomende e-mail, inclusief attachments, door middel van VBA op te slaan als draft. Het opslaan als draft gaat goed, maar ik wil de body, attachments en het subject van de geselecteerde e-mail meenemen. Het liefst zou ik ook meerdere e-mails tegelijk willen selecteren.

Momenteel heb ik dit:

Sub SaveAsDraft()
    Dim objOutlook As Object
    Dim objMsg As Outlook.MailItem
    Dim emlBody, sendTo As String
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    

    
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMsg = objOutlook.CreateItem(0)
    sendTo = "Mymail@mail.com"
    sendBCC = "Mymail@mail.com"
    emlBody = "My special message"
    With objMsg
        .To = sendTo
        .BCC = sendBCC
        .HTMLBody = emlBody
        .Subject = "Test"
        .Display
        .Save
        .Close olPromtForSave
    End With  
    

End Sub

wie kan me verder op weg helpen?

Alvast bedankt,
Axel

 

[Axel05]

Heb een kleine aanpassing gedaan, hij neemt nu de body en subject over van alle geselecteerde mails. echter slaat hij ze op in de ontvangen bestanden en niet meer als draft.. Ook geeft hij een foutmelding bij de attachments. Wie kan me helpen?

Sub SaveAsDraft()
    Dim objOutlook As Object
    Dim objMsg As Outlook.MailItem
    Dim emlBody, sendTo As String
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim objMessage As Outlook.MailItem
    

    Set objOutlook = CreateObject("Outlook.Application")
    Set objSelection = objOutlook.ActiveExplorer.Selection
    'Set objAttachments = objMsg.Attachments
    
For Each objMsg In objSelection

    Set objMessage = objOutlook.CreateItem(0)
    sendTo = "Mymail@mail.com"
    sendBCC = "Mymail@mail.com"
    With objMsg
        .To = sendTo
        .BCC = sendBCC
        .HTMLBody = objMsg.HTMLBody
        .Subject = objMsg.Subject
        '.Attachments = objMsg.Attachments
        .Display
        .Save
        .Close olPromtForSave
    End With
    
Next
    
End Sub

 

[Axel05]

Ben weer een stuk verder, hij slaat nu alle geselecteerde mails op als draft, alleen de attachments geeft een foutmelding.. wat doe ik hier verkeerd?

Sub SaveAsDraft()
    Dim objOutlook As Object
    Dim objMsg As Outlook.MailItem
    Dim emlBody, sendTo As String
    Dim objSelection As Outlook.Selection
    Dim objMessage As Outlook.MailItem
    Dim ObjOutlook2 As Object
    

    Set objOutlook = CreateObject("Outlook.Application")
    Set objSelection = objOutlook.ActiveExplorer.Selection

    
For Each objMsg In objSelection
    
    Set ObjOutlook2 = CreateObject("Outlook.Application")
    Set objMessage = ObjOutlook2.CreateItem(olMailItem)
    sendTo = "Mymail@mail.com"
    sendBCC = "Mymail@mail.com"
    With objMessage
        .To = sendTo
        .BCC = sendBCC
        .HTMLBody = objMsg.HTMLBody
        .Subject = objMsg.Subject
        .Attachments = objMsg.Attachments
        .Display
        .Save
        '.send
        .Close olPromtForSave
    End With
    
Next
    
End Sub

 

[snb]

Gebruik:

Sub M_snb()
    With CreateObject("Outlook.Application").GetNamespace("MAPI")
       for each it in .GetDefaultFolder(6).Items
          it.Move .GetDefaultFolder(16)
       next
    End With
End Sub

Kijk ook eens hier:

http://www.snb-vba.eu/VBA_Outlook_external.html#L154

 

[Axel05]

Bedankt voor de reactie. Ik krijg hem helaas nog niet werkend.. Waar staat 'it' voor?

 

[snb]

Ik hab mijn laatste suggestie aangepast/verbeterd.

 

[Axel05]

Bedankt, hij werkt! Hij kopieert alleen wel alle ontvangen bestanden naar de drafts. Heb dit aangepast naar enkel de selectie.. Alleen nu wil ik de geselecteerde items nog openzetten om direct te kunnen verzenden met wat aanpassingen in send-to etc. Hoe doe ik dit?

Sub M_snb()

Dim objSelection As Outlook.Selection
Dim objOutlook As Object
        

Set objOutlook = CreateObject("Outlook.Application")
Set objSelection = objOutlook.ActiveExplorer.Selection

        
    With CreateObject("Outlook.Application").GetNamespace("MAPI")
       For Each it In objSelection
          it.Move .GetDefaultFolder(16)
       Next
    End With
End Sub

 

[snb]

Sub M_snb()
    With CreateObject("Outlook.Application")
       For Each it In .ActiveExplorer.Selection
          it.Move .GetNamespace("MAPI").GetDefaultFolder(16)
       Next
    End With
End Sub

 

[Axel05]

Bedankt, maar het is ook de bedoeling om daarna op 'Send' te kunnen drukken zodat het een eigen verstuurde email is. Mijn sub doet dit, alleen geeft bij de attachments een foutmelding.. Hoe doe ik dit met bijbehorende attachments? Dus niet enkel verplaatsen, maar ook echt als nog te versturen mail aanmaken.

 

[Axel05]

Heb het opgelost door de file eerst de bestanden op te laten slaan en daarna te laden. Werkt perfect nu.

Laatste vraag: ik wil mijn handtekening graag toevoegen onderaan de sub. Heb eea opgezocht en heb wel een sub gevonden om mijn handtekening excl image te vinden, maar hoe krijg ik hier nu een plaatje bij?

voor de geinteresseerden, de sub:

Sub SaveAsDraft()
    Dim objOutlook As Object
    Dim objMsg As Outlook.MailItem
    Dim emlBody, sendTo As String
    Dim objSelection As Outlook.Selection
    Dim objMessage As Outlook.MailItem
    Dim ObjOutlook2 As Object
    
Timestamp = " " & Date & "-" & Time

Dim objAttachments As Outlook.Attachments
Dim I As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String



SigString = Environ("appdata") & _
                "\Microsoft\Signatures\Test.htm"

If Dir(SigString) <> "" Then
 Signature = GetBoiler(SigString)
Else
        Signature = ""
    End If



    Set objOutlook = CreateObject("Outlook.Application")
    Set objSelection = objOutlook.ActiveExplorer.Selection
    
For Each objMsg In objSelection

    
    Set ObjOutlook2 = CreateObject("Outlook.Application")
    Set objMessage = ObjOutlook2.CreateItem(olMailItem)
    sendTo = "mail@mail.com"
    sendBCC = "axel05@mail.com"
    With objMessage
        .SentOnBehalfOfName = "axel05@mail.com"
        .To = sendTo
        .BCC = sendBCC
        .HTMLBody = objMsg.HTMLBody & vbNewLine & "<br>" & Signature
        .Subject = objMsg.Subject
        
        
        
strFolderpath = "C:\Users\axel05\Desktop\Oud"
strFolderpath = strFolderpath & "\test\"
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""

If lngCount > 0 Then

' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.

For I = lngCount To 1 Step -1
strFile = objAttachments.Item(I).FileName

    If Right(objAttachments.Item(I).FileName, 3) = "pdf" Then
    strFile = strFolderpath & strFile

    ' Save the attachment as a file.
    objAttachments.Item(I).SaveAsFile strFile
    On Error Resume Next

    
        objMessage.Attachments.Add strFile, olByValue, 1, objAttachments.Item(I).FileName
        
        
        On Error Resume Next
        
        End If
        
        Next I
        
        End If
        
        
        'On Error Resume Next
        .Display
        .Save
        '.send
        .Close olPromtForSave
    End With

If objMsg.BodyFormat <> olFormatHTML Then
 objMsg.Body = objMsg.Body & vbCrLf & _
 "This email is saved as draft on " & Timestamp
 Else
 objMsg.HTMLBody = objMsg.HTMLBody & " " & vbCrLf & "This email is saved as draft on " & Timestamp
     objMsg.Save
     
 
 End If


    
Next

    
End Sub