Range - Picture - Outlook Body...

OptionExplicit
' Bedingte Kompilierung für 32/64 Bit
#If Win64 Then
PrivateDeclarePtrSafeFunctionSearchTreeForFileLib"imagehlp.dll"_
(ByValRootPathAsString,ByValInputPathNameAsString,_
ByValOutputPathBufferAsString)AsLong
PrivateDeclarePtrSafeFunctionMakeSureDirectoryPathExists_
Lib"imagehlp.dll"(ByValPfadAsString)AsLong
#Else
PrivateDeclareFunctionSearchTreeForFileLib"imagehlp.dll"_
(ByValRootPathAsString,ByValInputPathNameAsString,_
ByValOutputPathBufferAsString)AsLong
PrivateDeclareFunctionMakeSureDirectoryPathExists_
Lib"imagehlp.dll"(ByValPfadAsString)AsLong
#End If
PublicSubMain()
' Puffer für Pfad- und Dateiname festlegen
DimstrPathNameAsString*255
DimstrNameAsString
DimobjFSOAsObject
DimlngCalcAsLong
DimlngTMPAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
WithApplication
.AskToUpdateLinks=False
.EnableEvents=False
lngCalc=.Calculation
.Calculation=xlCalculationManual
.DisplayAlerts=False
EndWith
' Verzeichnis im %Temp% Ordner wird erstellt
CallMakeSureDirectoryPathExists(Environ("Temp")&"\TT\")
' Bereich "B3:D7" wird als Bild kopiert
CallThisWorkbook.Worksheets("Lieferung").Range("B3:D7").CopyPicture(xlScreen,xlBitmap)
' ERST hier die Bildschirmaktualisierung ausschalten, SONST BLEIBT DAS BILD LEER!
Application.ScreenUpdating=False
' Tabellenblatt hinzufügen - dies ist dann automatisch das aktive
ThisWorkbook.Worksheets.Add
' Bild in A1 einfügen
ThisWorkbook.ActiveSheet.Paste
' Bereich als "htm-Datei" im %Temp% Ordner speichern. Dabei wird das Bild automatisch
' als PNG-Datei in einen Unterordner abgelegt
WithThisWorkbook.PublishObjects.Add(xlSourceRange,_
Environ("Temp")&"\TT\TT.htm",ActiveSheet.Name,"$A:$E",xlHtmlStatic,"TT","")
.Publish(True)
.AutoRepublish=False
EndWith
' Temporäres Tabellenblatt wieder löschen
ThisWorkbook.ActiveSheet.Delete
' Grafikdatei suchen - hat immer den Namen (hier TT) und 001.png im Namen
lngTMP=SearchTreeForFile(Environ("Temp"),"\TT\TT_*001.png",strPathName)
' Wenn gefunden...
IflngTMP<>0Then
' Den Pfad- und Dateiname auf die richtige Länge eindampfen
strPathName=Left$(strPathName,InStr(1,strPathName,vbNullChar)-1)
strName=RTrim(strPathName)
' Mail senden - mit dem Pfad- und Dateinamen der Grafikdatei
CallMail(strName)
EndIf
' Ordner im %Temp% wieder löschen
SetobjFSO=CreateObject("Scripting.FileSystemObject")
objFSO.DeleteFolder(Environ("Temp")&"\TT"),True
Fin:
' Objektvariablen zurücksetzen
SetobjFSO=Nothing
' Die Applikation aufwecken
WithApplication
.ScreenUpdating=True
.AskToUpdateLinks=True
.EnableEvents=True
.Calculation=lngCalc
.DisplayAlerts=True
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Fehler: "&_
Err.Number&" "&Err.Description
EndSub
SubMail(ByValstrTMPAsString)
DimobjOutAppAsObject
DimstrText1AsString
DimstrText2AsString
DimstrText3AsString
DimstrFileAsString
' Outlook starten - gleich mit neuer Mail - das ist die 0 - Kontakt wäre 2
SetobjOutApp=CreateObject("Outlook.Application").CreateItem(0)
' Die Variable in der richtigen Form mit dem Pfad- und Dateinamen der Grafikdatei befüllen
strFile=" <img src=""file://"&strTMP&""">"
' Texte die später im Body auftauchen sollen. Muss man so nicht machen
' Man kann auch alles mit HTML-Code im Body schreiben
strText1="Sehr geehrte Damen und Herren,"
strText2="wir benötigen nächste Woche folgende LKW's:"
WithobjOutApp
' Standardsignatur aufrufen und...
.GetInSpector.Display
' ... zwischenspeichern
strText3=.HTMLBody
' An...
.To="Mail@dd.de"
'.CC = "An@WenNoch.de
' Versteckte Empfänger...
'.BCC = "AuchNoch@AnDen.de; UndNoch@AnJene.de"
' Anhang...
'.Attachments.Add "C:\Temp\IrgendwasVonIrgendwo.xlsx"
' Betreff...
.Subject="Lieferungen "&ThisWorkbook.Worksheets("Lieferung").Range("A1").Text&"/"&Year(Date)
' Body...
.HTMLBody=strText1&"<br>"&"<br>"&strText2&"<br>"&"<br>"&strFile&strText3
' Hier wird die Mail angezeigt, sonst gleich ".Send"
.Display
'.Send
EndWith
SetobjOutApp=Nothing
EndSub