AW: Html-Mail aus Excel
25.01.2011 13:44:25
Heinz
Hallo Martin,
so hier ein Beispiel:
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long
Private Const SW_HIDE = 0&
Private Sub SendMails()
Dim ol As Object
Dim oMail As Object
Dim sPath As String, sTxt As String
Dim iRow As Integer
Dim Adresse As String
Dim AdresseK As String
On Error GoTo ERRORHANDLER
ThisWorkbook.Worksheets("Schreiben").Select
sPath = ThisWorkbook.Path & "\mail.html"
Adresse = "heinz.wankmueller@ktn.gv.at"
AdresseK = "123@ktn.gv.at"
If ActiveWorkbook.PublishObjects.Count = 1 Then
ActiveWorkbook.PublishObjects(1).Delete
End If
ActiveWorkbook.PublishObjects.Add _
SourceType:=xlSourceRange, _
Filename:=sPath, _
Sheet:=ActiveSheet.Name, _
Source:=ActiveSheet.UsedRange.Address, _
HtmlType:=0
ActiveWorkbook.PublishObjects(1).Publish Create:=True
Call GetText(sPath, sTxt)
Set ol = CreateObject("Outlook.Application")
Set oMail = ol.CreateItem(0)
oMail.Save
oMail.To = Adresse
If AdresseK "" Then oMail.CC = AdresseK
oMail.Subject = wsG.Range("R1").Value
oMail.HTMLBody = sTxt
oMail.Importance = 1
oMail.ReadReceiptRequested = True
oMail.Sensitivity = 1
oMail.Send
Set ol = Nothing
Set oMail = Nothing
Exit Sub
ERRORHANDLER:
MsgBox "Die Mail konnte nicht auf den Weg gebracht werden -" & vbLf & _
"ist Outlook nicht gestartet oder ist" & vbLf & _
"Outlook nicht das Standard-Email-Programm?", , "Heinz A. Wankmüller:"
End Sub
Sub GetText(ByVal sFile As String, ByRef sTxt As String)
Dim lngChars As Long
Dim intFile As Integer
intFile = FreeFile
Open sFile For Input As intFile
lngChars = LOF(intFile)
sTxt = Input(lngChars, intFile)
Close intFile
End Sub
Wenn in der Tabelle Schreiben eine Grafik vorhanden ist, habe ich das geschilderte Problem.
Vielen Dank
Heinz