• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

VBA Code voor verzenden email met afbeelding

Status
Niet open voor verdere reacties.
B

Boerlo

Gebruiker
Lid geworden
14 jan 2021
Berichten
40
Ik heb nu (o.a. dankzij dit forum) de volgende macro in gebruik voor het opstellen van een email vanuit Excel, en dat werkt prima:

Code: 
Sub mailBG()

    On Error GoTo ErrHandler
    
    ' SET Outlook APPLICATION OBJECT.
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
    
 Dim strbody As String
 
 strbody = "Order " & WorksheetFunction.Text(Worksheets("Data_Leverbon").Range("b5"), "DD.MM.YYYY") & " :" & vbNewLine & vbNewLine & _
              "-   " & Worksheets("Leverbon").Range("b31") & " KN" & vbNewLine & _
              "-   " & "GW " & WorksheetFunction.Text(Worksheets("Data_Leverbon").Range("a5"), "DD.MM.YYYY") & vbNewLine & _
              "-   " & Worksheets("Leverbon").Range("b28") & vbNewLine & _
              "-   Prijs franco"
              
              
    ' CREATE EMAIL OBJECT.
    Dim objEmail As Object
    Set objEmail = objOutlook.CreateItem(olMailItem)

    With objEmail
        .to = "test@test.nl"
        .cc = "test@test.nl"
        .Subject = "KN " & WorksheetFunction.Text(Worksheets("Data_Leverbon").Range("b5"), "DD.MM.YYYY")
        .Body = strbody
        .Display        ' DISPLAY MESSAGE.
    End With
    
    ' CLEAR.
    Set objEmail = Nothing:    Set objOutlook = Nothing


ErrHandler:


End Sub


(NB. Er is gekozen voor .Display om de mail eerst te controleren en dan handmatig te verzenden)

Ik zou aan de mail graag ook een afbeelding (logo) toe willen voegen of gewoon de standaard ingevulde handtekening van Outlook invoegen. Kan dat?
 
Laatst bewerkt:
ZO:
Code: 
Sub mailBG()

    On Error GoTo ErrHandler
    
    [COLOR="#008000"]' SET Outlook APPLICATION OBJECT.[/COLOR]
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
    
 Dim strbody As String
 
 strbody = "Order " & WorksheetFunction.Text(Worksheets("Data_Leverbon").Range("b5"), "DD.MM.YYYY") & " :<br><br>" & _
              "-   " & Worksheets("Leverbon").Range("b31") & " KN<br>" & _
              "-   " & "GW " & WorksheetFunction.Text(Worksheets("Data_Leverbon").Range("a5"), "DD.MM.YYYY") & "<br>" & _
              "-   " & Worksheets("Leverbon").Range("b28") & "<br>" & _
              "-   Prijs franco"
              
              
    [COLOR="#008000"]' CREATE EMAIL OBJECT.[/COLOR]
    Dim objEmail As Object
    Set objEmail = objOutlook.CreateItem(olMailItem)

    With objEmail
        .Display        [COLOR="#008000"]' DISPLAY MESSAGE.[/COLOR]
        .to = "test@test.nl"
        .cc = "test@test.nl"
        .Subject = "KN " & WorksheetFunction.Text(Worksheets("Data_Leverbon").Range("b5"), "DD.MM.YYYY")
        .HTMLBody = strbody & "<br>" & .HTMLBody
        .Display [COLOR="#008000"]'Of .Send[/COLOR]
    End With
    
    [COLOR="#008000"]' CLEAR.[/COLOR]
    Set objEmail = Nothing:    Set objOutlook = Nothing


ErrHandler:


End Sub
 
Laatst bewerkt:
En een beetje ingekort.

Code: 
Sub VenA()
  x = [=text(Data_Leverbon!A5:B5,"dd.mm.yyyy")]
  y = Sheets("Leverbon").Range("B28:B31")

  strbody = "Order " & x(2) & " :<br><br>" & "-   " & y(4, 1) & " KN<br>" & "-   " & "GW " & x(1) & "<br>" & "-   " & y(1, 1) & "<br>" & "-   Prijs franco"

  With CreateObject("Outlook.Application").CreateItem(olMailItem)
    .Display
    .to = "test@test.nl"
    .cc = "test@test.nl"
    .Subject = "KN " & x(2)
    .HTMLBody = strbody & "<br>" & .HTMLBody
    .Display 'Of .Send
  End With
End Sub
 
Laatst bewerkt:
Er mist nu wel een .Display
 
Dank allebei!!

Ik ben weer een stap verder. Alleen als ik deze code uitvoer, krijg ik deze melding... :

test.png

Waar komt deze melding vandaan en hoe zou ik deze kunnen voorkomen?
 
Bedankt, heb 't gelezen. Maar ik krijg de melding niet weg. Kan het wel eenmalig toestaan of toestemming geven voor max. 10 minuten maar dat schiet niet op.
Antivirussoftware is in orde en bijgewerkt, dan zal het wel door Microsoft Exchange komen..? Ik kan de instellingen in het Vertrouwenscentrum niet aanpassen:
test.png

In de "oude" code (hieronder) kwam deze melding niet. Maar jullie code is veel beter en geeft ook de signature. Waar zit het verschil waardoor deze melding nu wel komt?

Code: 
Sub mailBG()

    On Error GoTo ErrHandler
    
    ' SET Outlook APPLICATION OBJECT.
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
    
 Dim strbody As String
 
 strbody = "Order " & WorksheetFunction.Text(Worksheets("Data_Leverbon").Range("b5"), "DD.MM.YYYY") & " :" & vbNewLine & vbNewLine & _
              "-   " & Worksheets("Leverbon").Range("b31") & " KN" & vbNewLine & _
              "-   " & "GW " & WorksheetFunction.Text(Worksheets("Data_Leverbon").Range("a5"), "DD.MM.YYYY") & vbNewLine & _
              "-   " & Worksheets("Leverbon").Range("b28") & vbNewLine & _
              "-   Prijs franco"
              
              
    ' CREATE EMAIL OBJECT.
    Dim objEmail As Object
    Set objEmail = objOutlook.CreateItem(olMailItem)

    With objEmail
        .to = "test@test.nl"
        .cc = "test@test.nl"
        .Subject = "KN " & WorksheetFunction.Text(Worksheets("Data_Leverbon").Range("b5"), "DD.MM.YYYY")
        .Body = strbody
        .Display        ' DISPLAY MESSAGE.
    End With
    
    ' CLEAR.
    Set objEmail = Nothing:    Set objOutlook = Nothing


ErrHandler:


End Sub
 
Het is mij slechts sporadisch gelukt die melding weg te krijgen.
Wat gebeurt er als je nu weer de oude code gebruikt?

Wat je nog kan proberen is dit in een .reg bestandje en dan uitvoeren als Administrator.
Vervang de 16.0 door je eigen versie van Office:
Code: 
Windows Registry Editor Version 5.00

[HKEY_CURRENT_USER\Software\Policies\Microsoft\Office\16.0\Outlook\Security]
"PromptOOMSend"=dword:00000002
"AdminSecurityMode"=dword:00000000
"PromptSimpleMAPISend"=dword:00000002
"PromptSimpleMAPINameResolve"=dword:00000002
"PromptSimpleMAPIOpenMessage"=dword:00000002

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\16.0\Outlook\Security]
"ObjectModelGuard"=dword:00000002

NB:
Maak eerst een backup van je register.
 
Laatst bewerkt:
Bedankt.

Als ik de oude code gebruik, krijg ik de melding niet.

Ik probeer eerst nog wat dingen voordat ik met het .reg bestandje aan de slag ga. Hoe zou ik dat trouwens moeten noemen?
 
Mag je Boerlo.reg noemen ;)
M.a.w., de naam is verder niet van belang.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan