Software für Sie.

Wie kann ich einen ausgewählten Bereich einer Exceltabelle als HTML-Mail via Outlook versenden?

Const strTempOrdner As String = "C:\Eigene Dateien\" Sub Aufruf() Mail_erstellen "info@example.org" End Sub Sub Mail_erstellen(strAdresse As String) Dim strQuelle As String Dim OutApp Dim OutMail Dim olMailItem Dim strSubject strQuelle = "$B$1:$R$58" strSubject = Range("B1") Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(olMailItem) With OutMail .To = strAdresse .CC = "" .BCC = "" .Subject = strSubject .HTMLBody = Uebersetzung(strQuelle) '.Send .Display End With Set OutMail = Nothing Set OutApp = Nothing End Sub Public Function Uebersetzung(strQuelle As String) Dim objFSO As Object Dim objInhalt As Object Dim strTempDatei As String strTempDatei = strTempOrdner & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" With ActiveWorkbook.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=strTempDatei, _ Sheet:=ActiveSheet.Name, _ Source:=strQuelle, _ HtmlType:=xlHtmlStatic) .Publish (True) End With Set objFSO = CreateObject("Scripting.FileSystemObject") Set objInhalt = objFSO.GetFile(strTempDatei).OpenAsTextStream(1, -2) Uebersetzung = objInhalt.ReadAll objInhalt.Close Set objInhalt = Nothing Set objFSO = Nothing Kill strTempDatei End Function

Bei neueren Outlookversionen kann es zu einer Fehlermeldung kommen:

Ein Programm versucht, Nachrichten mit Item.Send zu senden. Ein Programm versucht, mit dem Befehl Item.Send der Anwendung Microsoft Outlook Visual Basic automatisch E-Mail-Nachrichten zu senden. Wenn Sie möchten, dass das Programm diese E-Mail-Nachricht sendet, klicken Sie auf Ja. Klicken Sie auf Nein, um das Programm zu beenden. Wenn Sie sich nicht sicher sind, welches Programm die E-Mail-Nachricht sendet oder warum, sollten Sie auf Nein klicken, um ein mögliches Verbreiten von Viren zu vermeiden.

Bei Anzeige dieser Meldung steht die Schaltfläche Ja 5 Sekunden lang nicht zur Verfügung.

Vielleicht ist dieser Tipp besser geeignet: Mails mit VBA und PHP versenden (mehrere Empfänger, mehrere Anhänge).

Vorsicht: Die Laufzeit dieser Schleifen kann sehr lang sein. Es ist deshalb mehr als ratsam, die zu durchsuchenden Ordner so stark wie möglich einzugrenzen.

Erste Möglichkeit:

Dim strPfad As String, bolWeiter As Boolean 'Aufruf Sub Suchen() strPfad = "": bolWeiter = True: Dateisuche "C:\", "test.txt" Range("A1") = strPfad End Sub Function Dateisuche(strLaufwerk, strDatei) Dim strTemp As String, strWdhlg As String On Error Resume Next strLaufwerk = strLaufwerk & IIf(Right(strLaufwerk, 1) <> "\", "\", "") strTemp = Dir(strLaufwerk & strDatei) Do While Len(strTemp) strPfad = strLaufwerk & strTemp If UCase(strTemp) = UCase(strDatei) Then Dateisuche = strPfad bolWeiter = False: Exit Function End If strTemp = Dir() Loop strTemp = Dir(strLaufwerk, vbDirectory) Do While Len(strTemp) If (strTemp <> ".") And (strTemp <> "..") Then If (GetAttr(strLaufwerk & strTemp) And vbDirectory) = vbDirectory Then If bolWeiter = True Then Dateisuche strLaufwerk & strTemp, strDatei Else Exit Function strWdhlg = Dir(strLaufwerk, vbDirectory) Do While strWdhlg <> strTemp: strWdhlg = Dir(): Loop End If End If strTemp = Dir() Loop End Function

Zweite Möglichkeit:

Sub suchen1() Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dateisuche fso.GetFolder("C:"), "test.txt" Set fso = Nothing End Sub Sub Dateisuche(objErstOrdner As Object, strDatei As String) Dim objDatei As Object, objOrdner As Object, sf As Object For Each objDatei In objErstOrdner.Files If LCase(objDatei.Name) = strDatei Then MsgBox objDatei.Path End If Next For Each objOrdner In objErstOrdner.SubFolders Dateisuche objOrdner, strDatei Next End Sub