|
Funktioniert noch nicht alles wie gewünscht:
In diesem Fall brauche ich den kopierten Beriech nicht (sBer = "A20:K33" 'Kopierbereich), was muss ich alles löschen das es trotzdem funktioniert?
Beim Button klick fragt das Outlook 2x ob "das Programm auf die Adressbuchinformaton" zugegriffen werden darf. Erst bei 2 zustimmen fügt es das PDF ein. Kann man die 2 Zustimmungsklicks verhindern?
.To = hier möchte ich direkt die E-Mailadressen aus dem Excel einzufügen, geht das? Es ist eine verbundene Zelle E9:G10 und kann manchmal mehrere Mailadressen enthalten
.Subject = "Bestellung" & WSh.Range("B4").Value greift es den Wert nicht ab,
das gleiche ist beim sMailtext = "Guten Tag," & vbLf & vbLf & "Im Anhang sende ich Ihnen die Bestellung für Auftrag " _
& WSh.Range("B4").Value & "." & vbLf & "Gerne erwarte ich Ihre Bestätigung." & vbLf
Was müsste da geändern werden?
Gruss
ch79
'BetreffSub Mail_Senden_mit_PDF()
'Sendet Mail mit integriertem Bereich als Bild mit Signatur
'Das Bild wird über das Kürzel ~ im Text platziert
Dim WSh As Worksheet, WkS As Worksheet
Dim sMailtext As String, sBild As String, sSignatur As String
Dim sBer As String, sDateiName As String
Dim P As Integer, iEinf As Integer
sDateiName = ThisWorkbook.FullName
sDateiName = Left$(sDateiName, InStrRev(sDateiName, ".")) & "pdf"
'<<<Tabellenblatt anpassen>>>
ThisWorkbook.Sheets("Furnierte Platten").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sDateiName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
sBer = "A20:K33" 'Kopierbereich
Set WSh = ThisWorkbook.Sheets("Tabelle1") 'Blatt mit Maildaten
On Error Resume Next
'Bereich kopieren
Do
WSh.Range(sBer).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
If Err.Number = 0 Then Exit Do
Err.Clear
Loop
With CreateObject("Outlook.Application").CreateItem(0)
.BodyFormat = 2 'HTML-Format, Angabe optional
.Subject = "Bestellung" 'Betreff
.To = "Mail@test.de" 'Empfänger
sMailtext = "Guten Tag," & vbLf & vbLf & "Im Anhang sende ich Ihnen die Bestellung für Auftrag " _
& WSh.Range("B4").Value & "." & vbLf & "Gerne erwarte ich Ihre Bestätigung." & vbLf
.GetInspector: sSignatur = .HTMLBody 'Signatur holen
.HTMLBody = Replace(sMailtext, vbLf, "<br>") & sSignatur
.Display
iEinf = Len(sMailtext) - 1 'Grafik Einfügestelle
With .GetInspector.WordEditor.Application.Selection
.Start = iEinf: .End = iEinf
.Paste 'Grafik in Mail einfügen
End With
If Dir$(sDateiName) <> "" Then
.Attachments.Add sDateiName 'Anlage anfügen
End If
End With
End Sub
|