Blattinhalt via Email versenden
16.04.2020 13:11:35
ingo
Ich habe nun einen VBA Code bei welchem ich mit meinem Wissen (bescheiden) nicht mehr weiter komme.
Folgende Aufgabenstellung.
Es gibt das Blatt "Freigabe", dieses Blatt hat 135 Zeilen und 10 Spalten welche als Druckbereich markiert sind.
Je nach dem was auf einem anderen Blatt eingegeben wir kann es sein dass mehrere Zeilen im Blatt "Freigabe" ausgeblendet werden.
Nun soll via Button der Druck Bereich von Blatt "Freigabe" via email versandt werden.
Dies funktioniert auch einwandfrei, mein Problem ist aber dass er mir auch die ausgeblendeten Zeilen versendet, dies soll aber vermieden werden, d.h. es sollen nur die Zeilen versendet werden welche auch eingeblendet sind. Ich würde mich über jede Hilfe freuen.
Sub Freigabe_anfordern()
If ActiveSheet.Range("C5") = "" Then
MsgBox "zuerst Kundennamen ausfüllen", vbCritical
Else
If ActiveSheet.Range("C6") = "" Then
MsgBox "zuerst Kundennummer ausfüllen", vbCritical
Else
If ActiveSheet.Range("C7") = "" Then
MsgBox "zuerst Angebotsnummer ausfüllen", vbCritical
Else
If ActiveSheet.Range("C8") = "" Then
MsgBox "zuerst Postleitzahl ausfüllen", vbCritical
Else
If ActiveSheet.Range("C9") = "" Then
MsgBox "zuerst Stadt / Ort ausfüllen", vbCritical
Else
If ActiveSheet.Range("C10") = "" Then
MsgBox "zuerst Stassenname und Nr. ausfüllen", vbCritical
Else
If ActiveSheet.Range("C11") = "" Then
MsgBox "zuerst Ansprechpartner Vorname ausfüllen", vbCritical
Else
If ActiveSheet.Range("C12") = "" Then
MsgBox "zuerst Ansprechpartner Nachname ausfüllen", vbCritical
Else
Dim olApp As Object
Dim AWS As String
Dim olOldbody As String
Dim Betreff As String
Betreff = Format(Date, "YYYY MM DD ") & "Text" & Range("Datenblatt!C5").Value & (" - Kd.Nr.: ") _
_
& Range("Datenblatt!C6").Value & ("Text ") & Range("Datenblatt!C7").Value
ActiveWorkbook.Save
AWS = ActiveWorkbook.FullName
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.GetInspector.Display
olOldbody = .htmlBody
.To = "text@text"
.Subject = Betreff
.htmlBody = "
Text,
Text.
Text& _
RangeToHTML(Range("Freigabe!Druckbereich")) & olOldbody
End With
End If
End If
End If
End If
End If
End If
End If
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
End Function