Automatisch bestand meezenden in outlook

[WWWV]

Ik ben op zoek naar een code die ervoor zorgt dat als ik op een bestaande mail wil antwoorden, er automatisch een bestand dat op mijn computer staat, wordt meeverzonden in attachment.
Ook -in dezelfde aard- bij het opstellen van een nieuwe mail zou dit bestand in bijlage moeten zitten als er op 'nieuwe e-mail' wordt geklikt.

Specifiek: het is voor een restaurant die automatisch bij iedere mail zijn maandelijkse menu wil meezenden.

Kheb al verschillende codes geprobeerd, maar telkens komt er nog teveel handwerk aan te pas, of werkt ze niet.

Alvast bedankt!

 

[gast0660]

Hoi,
Bij deze iets in de richting
Op blad 1 zet je de bijlage
Op blad kies zet je ja bij de emailadressen waar een mail naar toe moet
Op blad kies is D de body van uw mail

 

[WWWV]

Bedankt voor het antwoord,

Maar het zou moeten lukken met VBA in outlook.
Hieronder een code die alle attachments van in de originele mail terug meestuurt bij het antwoord op die mail.

Sub ReplyWithAttachments()
    Dim oReply As Outlook.MailItem
    Dim oItem As Object
      
    Set oItem = GetCurrentItem()
    If Not oItem Is Nothing Then
        Set oReply = oItem.Reply
        CopyAttachments oItem, oReply
        oReply.Display
        oItem.UnRead = False
    End If
      
    Set oReply = Nothing
    Set oItem = Nothing
End Sub
  
Sub ReplyAllWithAttachments()
    Dim oReply As Outlook.MailItem
    Dim oItem As Object
      
    Set oItem = GetCurrentItem()
    If Not oItem Is Nothing Then
        Set oReply = oItem.ReplyAll
        CopyAttachments oItem, oReply
        oReply.Display
        oItem.UnRead = False
    End If
      
    Set oReply = Nothing
    Set oItem = Nothing
End Sub
Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
          
    Set objApp = Application
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
    End Select
      
    Set objApp = Nothing
End Function
  
Sub CopyAttachments(objSourceItem, objTargetItem)
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
   strPath = fldTemp.Path & "\"
   For Each objAtt In objSourceItem.Attachments
      strFile = strPath & objAtt.FileName
      objAtt.SaveAsFile strFile
      objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
      fso.DeleteFile strFile
   Next
  
   Set fldTemp = Nothing
   Set fso = Nothing
End Sub

Misschien kan hierop verder gebouwd worden?

 

[edmoor]

Gebruik deze eens:

Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
Private bDiscardEvents As Boolean
Dim oResponse As MailItem
   
Private Sub Application_Startup()
   Set oExpl = Application.ActiveExplorer
   bDiscardEvents = False
End Sub
   
Private Sub oExpl_SelectionChange()
   On Error Resume Next
   Set oItem = oExpl.Selection.Item(1)
End Sub

Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
    Dim Bijlage As String
    Cancel = True
    bDiscardEvents = True
    
    Bijlage = [COLOR="#FF0000"]"C:\Menu\Menukaart.pdf"[/COLOR]
 
    Set oResponse = oItem.Reply
    oResponse.Attachments.Add Bijlage
    oResponse.Display
End Sub

Wijzig het rode gedeelte naar wens.
Na het toevoegen van de code even in de VBE op Opslaan klikken en Outlook herstarten.
Dit werkt als je op "Beantwoorden" klikt.
Als dit is wat je wilt gaan we wel even kijken naar een zelfde mogelijkheid bij het opstellen van een nieuwe mail.

 

[WWWV]

Dat zou het zowat moeten zijn.
Echter klopt er iets niet, zie bijlage

 

[edmoor]

Ik zie geen foutmelding of zo in je plaatje.
Hier werkt het prima.
Doe het eens niet in een module.

 

[WWWV]

Ik krijg een compileerfout bij het opstarten van outlook.
Als ik op 'beantwoorden' klik, dan is er niks gewijzige, geen bijlage te vinden.

 

[edmoor]

Wat ik al zei, plaats die code niet in een module maar in de ThisOutlookSession sectie.

 

[WWWV]

Jep, inderdaad.
Dit werkt!
Alvast bedankt!

 

[edmoor]

Ok dan. Met dat voorbeeld zou je zelf de mogelijkheid kunnen maken die bijlage ook aan een nieuwe mail toe te voegen.
Als dat niet lukt dan laat het maar weten.

 

[WWWV]

t spijt mij zeer, maar ikzelf ga dat niet kunnen, weinig tot geen kennis van VBA.
Wel op de hoogte van de eindeloze mogelijkheden ervan.

Hulp is dus zeker nog welkom.

Nog een vraagje ivm deel 1: hoe doe ik het voor meerdere bijlagen?

 

[edmoor]

Voor meerdere bijlagen kan je de Sub oItem_Reply wijzigen in bijvoorbeeld dit:

Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
    Cancel = True
    bDiscardEvents = True

    Set oResponse = oItem.Reply
    oResponse.Attachments.Add "E:\Diversen\1.jpg"
    oResponse.Attachments.Add "E:\Diversen\2.jpg"
    oResponse.Attachments.Add "E:\Diversen\111.png"
    oResponse.Display
End Sub

Op die manier kan je net zoveel bijlagen meesturen als je maar wil.

Voor een nieuwe mail zal ik later naar kijken, ik moet nu weg.

 

[edmoor]

Als je dit gebruikt wordt bij zowel een nieuwe mail als bij antwoord op een bestaande mail de gewenste bijlage(n) toegevoegd. Vervang de vorige code dus door deze en kijk waar je de bijlagen moet wijzigen:

Option Explicit
Private WithEvents objinspectors As Outlook.Inspectors
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
Private bDiscardEvents As Boolean
Dim oResponse As MailItem
   
Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    
    Set olApp = Outlook.Application
    Set oExpl = Application.ActiveExplorer
    Set objinspectors = Application.Inspectors
    bDiscardEvents = False
End Sub
   
Private Sub objinspectors_NewInspector(ByVal Inspector As Inspector)
    Dim myItem As Outlook.MailItem
    Dim myAttachments As Outlook.Attachments
    
    If TypeName(Inspector.CurrentItem) = "MailItem" Then
        With Inspector.CurrentItem.Attachments
            .Add "E:\Diversen\1.jpg"
            .Add "E:\Diversen\2.jpg"
        End With
    End If
End Sub
   
Private Sub oExpl_SelectionChange()
   On Error Resume Next
   Set oItem = oExpl.Selection.item(1)
End Sub

Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
    Cancel = True
    bDiscardEvents = True

    Set oResponse = oItem.Reply
    With oResponse.Attachments
        .Add "E:\Diversen\1.jpg"
        .Add "E:\Diversen\2.jpg"
    End With
    oResponse.Display
End Sub

 

[WWWV]

Dat werkt !

Ik ben in ieder geval heel tevreden !

 

[edmoor]

Ok dan