Afbeelding mee kopieren, of laten invoegen in de e-mail body vanuit excel

[HWV]

Beste,

Ik gebruik een code vanuit een userform om een deel van een werkblad te kopieeren naar outlook. Enkel met het kopieren neemt hij geen afbeelding mee.
Hoe krijg ik dit voor elkaar , of is er een mogelijkheid om deze in de code te verwerken, zoals ik doe met een attachments. ".Attachments.Add "

   Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
 
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    Set rng = Nothing
    On Error Resume Next

[COLOR="red"]    Set rng = Sheets("Leeg").Range("A2:F" & Sheets("Leeg").Range("E1")).SpecialCells(xlCellTypeVisible)
    ' Set rng = Sheets("Leeg").Range("A2:F" & Sheets("leeg").[A100].End(xlUp).Offset(1, 0)).SpecialCells(xlCellTypeVisible)[/COLOR]
    
    On Error GoTo 0

 
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    On Error Resume Next
If form_Adres.ComboBox2.Value = "Zaak" Then
    With OutMail
        .To = "info@email.nl"
        .CC = ""
        .BCC = ""
        .Subject = [A2] & " " & [A5]
        .HTMLBody = RangetoHTML(rng) & Signature
        .Attachments.Add ("c:\NL Voorwaarden.pdf")
        .Attachments.Add ("C:\Users\Alternate\Documents\NL Voorwaarden.pdf")
        .Display   'or use .Send
        
    End With
    
Else

    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = [D1] & " " & [A2]
        .HTMLBody = RangetoHTML(rng)
        .Attachments.Add ("c:\NL Voorwaarden.pdf")
        .Attachments.Add ("C:\Users\Alternate\Documents\NL Voorwaarden.pdf")
        .Display   'or use .Send
    End With
    
End If
    On Error GoTo 0
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
 
    Set OutMail = Nothing
    Set OutApp = Nothing
    
End If

Groet HWV

 

[pasan]

ik gebruik deze om afbeelding in de body van een mail te zetten van uit een werkblad

Sub Knop1_Klikken()
intkeuze = MsgBox("alles ingevuld? en klaar om te verzenden?", vbYesNo)
Select Case intkeuze
Case Is = vbYes
Dim AWorksheet As Worksheet
Dim Sendrng As Range
Dim rng As Range
Application.ScreenUpdating = False
Sheets("eigen blad").Unprotect 
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Fill in the Worksheet/range you want to mail
'Note: if you use one cell it will send the whole worksheet
Set Sendrng = Worksheets("eigen blad").Range("eigen range")
'Remember the activesheet
Set AWorksheet = ActiveSheet
'Create the mail and send it
With Sendrng
' Select the worksheet with the range you want to send
.Parent.Select
'Remember the ActiveCell on that worksheet
Set rng = ActiveCell
'Select the range you want to mail
.Select
' Create the mail and send it
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
With .Item
.To = "eigen@mail.nl"
.Subject = 
.Send
End With
End With
'select the original ActiveCell
rng.Select
End With
'Activate the sheet that was active before you run the macro
AWorksheet.Select
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
Sheets("eigen blad").Protect 
Application.ScreenUpdating = True
Case Is = vbNo
Exit Sub
End Select

 

[HWV]

Foutmelding in de code

Beste,

Ik krijg een fout in de code( zie rode stuk in de code )

Sub Knop1_Klikken()
intkeuze = MsgBox("alles ingevuld? en klaar om te verzenden?", vbYesNo)
Select Case intkeuze
Case Is = vbYes
Dim AWorksheet As Worksheet
Dim Sendrng As Range
Dim rng As Range
Application.ScreenUpdating = False
Sheets("Leeg").Unprotect
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Fill in the Worksheet/range you want to mail
'Note: if you use one cell it will send the whole worksheet
Set Sendrng = Worksheets("Leeg").Range("A2:D40")
'Remember the activesheet
Set AWorksheet = ActiveSheet
'Create the mail and send it
With Sendrng
' Select the worksheet with the range you want to send
.Parent.Select
'Remember the ActiveCell on that worksheet
Set rng = ActiveCell
'Select the range you want to mail
.Select
' Create the mail and send it
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
With .Item
.To = "hwv@helpmij.nl"
.Display
End With
End With
'select the original ActiveCell
rng.Select
End With
'Activate the sheet that was active before you run the macro
AWorksheet.Select
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
[COLOR="red"]ActiveWorkbook.EnvelopeVisible = False[/COLOR]
Sheets("Leeg").Protect
Application.ScreenUpdating = True
Case Is = vbNo
Exit Sub
End Select
End Sub

Outlook staat open, maar hij doet niks

Groet HWV

 

[pasan]

welke office versie gebruik je? met 2010 werkt het wel

 

[HWV]

Versie 20007

Beste,

Ik werk met versie 2007.

Groet HWV

 

[pasan]

http://www.rondebruin.nl/mail/folder3/mailenvelope.htm

ik zit weer achter mn eigen pc en moest ff zoeken waar ik dit onderwerp gevonden had
maar bij deze de link

 

[pasan]

als ik .Display gebruik zoals jij dan werkt het bij mij ook niet
maar als ik .Send dus meteen als mail versturen gebruik dan werkt het prima