Extra bijlage invoegen + afbeelding in "BODY" tekst

[Schipper1994]

Hallo,

ik ben bezig met een vba voor een e-mail te sturen met bijlage vanuit excel.
dit lukt goed.
nu moet ik nog 2 dingetjes inorde maken.

ik zou graag automatisch nog een 2de bijlage toevoegen als dit mogelijk is, vanuit mijn computer. Dit zal altijd een vaste plek hebben op mijn pc.
ook wil ik graag weten of ik mijn vast e-mail handtekening kan laten toevoegen via VBA.
vanaf dat ik body tekst gebruik in de e-mail, valt heel mijn automatische handtekening weg.


(enkele dingen zijn in dit voorbeeld aangepast om privacyredenen)

Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
 
Set xSht = Worksheets("testsheet")
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

    With xFileDlg
       .InitialFileName = Sheets("settings2").Range("b2")
    End With
    

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If

xFolder = xFolder + "\" & xSht.Cells(19, 4) & " " & xSht.Cells(22, 9) & ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & "Bestaat al." & vbCrLf & vbCrLf & "Wilt u deze overschrijven?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "Deze sheet is niet opgeslagen." _
                    & vbCrLf & vbCrLf & "Druk OK om af te sluiten", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
     
    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = xSht.Cells(13, 3)
        .CC = ""
        .body = "Beste" & " " & xSht.Cells(14, 5) & "," & vbNewLine & "Gelieve onze" & xSht.Cells(12, 2) & "in bijlage te vinden." & vbNewLine & _
" " & vbNewLine
        .Subject = xSht.Cells(19, 4) & " " & xSht.Cells(22, 9)
        .Attachments.Add xFolder
        If DisplayEmail = False Then
        '.Send
        End If
    End With
Else
  MsgBox "sheet mag niet blanco zijn"
  Exit Sub
End If
End Sub

deze code heb ik ergens van op internet en hij werkt

 

[edmoor]

Voorbeeld:

[COLOR="#FF0000"]Dim Handtekening As String[/COLOR]
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
    .Display
    [COLOR="#FF0000"]Handtekening = .HTMLBody[/COLOR]
    .To = xSht.Cells(13, 3)
    .CC = ""
   [COLOR="#FF0000"] .HTMLBody = "Beste " & xSht.Cells(14, 5)  & ",<br>" & "Gelieve onze " & xSht.Cells(12, 2) & "in bijlage te vinden.<br><br>" & Handtekening[/COLOR]
    .Subject = xSht.Cells(19, 4) & " " & xSht.Cells(22, 9)
    [COLOR="#FF0000"].Attachments.Add "Pad en naam vast bestand"[/COLOR]
    .Attachments.Add xFolder
    If DisplayEmail = False Then
    [COLOR="#008000"]  '.Send[/COLOR]
    End If
End With