AW: VBA daten von Excel nach Outlook + Signatur
30.07.2023 10:32:46
Ulf
Hi,
für alle, die wie meinereiner mehrere Konten in einer pst verwenden hier der angepasste Code zum Signieren:
Option Explicit
Public Sub SendToMail()
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim strBody As String
Dim strSign As String
Dim strFiles As Variant
Set objOutlook = New Outlook.Application
Set objMail = objOutlook.CreateItem(olMailItem)
'!!! Ranges anpassen !!!
strBody = RangeToHTML(Worksheets(1), Worksheets(1).Range("A1:F74"))
With objMail
.BodyFormat = olFormatHTML
strSign = holeSignatur(objMail)
.To = "max@mustermann.de"
.Subject = "Aktuelle Spielliste " & CStr(Date)
.HTMLBody = .HTMLBody & strBody & "
" & strSign
.Display
'.Send
End With
Set objMail = Nothing
Set objOutlook = Nothing
End Sub
Public Function RangeToHTML(objSheet As Worksheet, objRange As Range) As String
On Local Error GoTo RangeToHTMLERR
Dim strFilename As String
strFilename = Environ$("TEMP") & "/" & Format(Now, "dd-mm-yyyy_hh-mm-ss") & ".htm"
ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strFilename, _
Sheet:=objSheet.Name, _
Source:=objRange.Address, _
HtmlType:=xlHtmlStatic).Publish True
RangeToHTML = CreateObject("Scripting.FileSystemObject"). _
GetFile(strFilename).OpenAsTextStream(1, -2).ReadAll
Kill strFilename
RangeToHTMLOUT:
Exit Function
RangeToHTMLERR:
'msgbox err ...
Resume RangeToHTMLOUT
End Function
Public Function holeSignatur(ByRef objMail As Outlook.MailItem, Optional ByVal strName As String = "DEFAULT_HIER_EINTRAGEN") As String
On Local Error GoTo holeSignaturERR
Dim strPfad As String
Dim strDatei As String
Dim strFound As String
Dim strRet As String
Dim strTemp As String
Dim strErsatz As String
'Signaturen sollten in zu finden sein
'C:\Users\USERNAME\AppData\Roaming\Microsoft\Signatures
strPfad = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures"
strDatei = strName & ".htm"
strFound = Dir$(strPfad & "\" & strDatei, vbNormal)
If strFound = strDatei Then
strRet = CreateObject("Scripting.FileSystemObject"). _
GetFile(strPfad & "\" & strDatei).OpenAsTextStream(1, -2).ReadAll
End If
'!!! Diese image.001.jpg im entsprechenden Ordner einmalig suchen/anpassen !!!
'ggf. muß/kann man mit dir$().. im Text der htm-Datei suchen und hier einsetzen
strErsatz = Replace(strPfad, "\", "/") & "/" & strName & "-Dateien/image001.jpg"
strTemp = Replace(strRet, strName & "-Dateien/image001.jpg", strErsatz)
strRet = strTemp
holeSignaturOUT:
holeSignatur = strRet
Exit Function
holeSignaturERR:
strRet = ""
Resume holeSignaturOUT
End Function