Screenshot in Mail einfügen
10.11.2021 14:18:31
Tamás
Allerdings ist nun ein Problem aufgetreten.
Es geht dabei speziell um das skalieren des Screenshots in der Outlook Mail. Das Problem dabei ist dass wir ab heute mit einer neuen Signatur arbeiten die ebenfalls Grafiken enthält. Der Screenshot soll ja auch eine bestimmte Breite skaliert werden, das macht das Makro nun aber auch für die Grafiken in der Signatur. Das ist natürlich nicht erwünscht.
Wie muss ich denn den Code anpassen damit die Grafiken in der Signatur unverändert beliben?
hier der Code der bisher tadellos funktioniert hat:
Sub SCREENSHOT_MAIL()
'Sendet Mail mit integriertem Bereich als Bild mit Signatur
Dim sMailtext As String, sDateiname As String
Dim iEinf As Integer, oShp As Object
Dim WSh1 As Worksheet, WSh2 As Worksheet
Dim sBetreff As String
Set WSh1 = Sheets("Mailversand") 'Blatt referenzieren
Set WSh2 = Sheets("Ausgabe") 'Blatt referenzieren
sBetreff = "Screenshot " & WSh2.Range("K4").Value
sDateiname = "C:\Temp\Screenshot " & WSh2.Range("K4").Value & ".pdf"
Sheets("Quelle").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
sDateiname, _
Quality:=xlQualityStandard, IncludeDocProperties:=False, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
On Error Resume Next
Do
WSh2.Range("A1:Y36").CopyPicture _
Appearance:=xlScreen, Format:=xlBitmap 'Bereich kopieren, ggf. xlPicture
If Err.Number = 0 Then Exit Do 'Bei Problemen
Err.Clear 'mehrfach versuchen
Loop
On Error GoTo 0
With CreateObject("Outlook.Application").CreateItem(0)
.BodyFormat = 2 '2=HTML-Format, 3=Richtext
.Subject = sBetreff 'Betreff"
.To = WSh1.Range("B3").Value 'Empfänger
.Cc = WSh1.Range("B4").Value 'Kopie
sMailtext = "Hallo," & vbLf & "hier die Daten" & vbLf
.Getinspector: 'Signatur holen
.htmlbody = Replace(sMailtext, vbLf, "
") & .htmlbody
.Display
iEinf = Len(sMailtext) 'Grafik Einfügestelle, ggf. justieren
With .Getinspector.WordEditor.Application.Selection
.Start = iEinf: .End = iEinf
.Paste 'Grafik in Mail einfügen
End With
For Each oShp In .Getinspector.WordEditor.InlineShapes
oShp.Width = 300 'Grafik skalieren
Next oShp
'Anlage dran
.Attachments.Add sDateiname
End With
End Sub