|
Hallo,
ich habe hier meinen Code aber komme leider nicht mehr weiter ...
Wenn der Wert hier über 180 beträgt, was er immer macht da die nummer immer mit 180.... anfängt soll er ein Email schicken mit jeweiligen Tabellenbereich.
Das funktioniert auch, aber wenn ich jetzt mehrere Tabellenbereiche schicken möchte und ich im ersten Range B11 nicht einen Wert eingegeben habe erstellt er die anderen E-Mails mit der anderen Tabelle nicht obwohl ein Wert enthalten ist.
Nur wenn ich bei B11 ein Wert habe erstellt er auch mit den jeweilig anderen Tabellenbereich die Emails.
Ich möchte jetzt z.B. in Tabelle 2 einen Wert eingeben und dass hier dann auch das E-Mail erstellt wird.
Kann mir da wer helfen.
Vielen Dank im Voraus.
Code:
Sub OÖTour()
Dim olApp As Object
Dim AWS As String
Dim olOldbody As String
If Range("B11").Value >= 180 Then
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.GetInspector.Display
olOldbody = .htmlBody
.To = Sheets("MONTAG").Range("B7")
.Subject = Sheets("Text").Range("A2")
.htmlBody = "Hallo,<br><br>folgende Abweichung bei:<br><br>" & _
RangeToHTML(Range("B7:F32")) & _
"<br><br><br>" & olOldbody
End With
End If
End Sub
Function RangeToHTML(rng As Range)
Dim Fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ts = Fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangeToHTML = ts.readall
ts.Close
RangeToHTML = Replace(RangeToHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set Fso = Nothing
Set TempWB = Nothing
If Range("H11").Value >= 180 Then
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.GetInspector.Display
olOldbody = .htmlBody
.To = Sheets("MONTAG").Range("H7")
.Subject = Sheets("Text").Range("A3")
.htmlBody = "Hallo,<br><br>folgende Abweichung bei:<br><br>" & _
RangeToHTML1(Range("H7:L32")) & _
"<br><br><br>" & olOldbody
End With
End If
End Function
Function RangeToHTML1(rng As Range)
Dim Fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ts = Fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangeToHTML1 = ts.readall
ts.Close
RangeToHTML1 = Replace(RangeToHTML1, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set Fso = Nothing
Set TempWB = Nothing
End Function
|