RangeToHTML Frage
22.07.2022 09:35:12
Ulf
mit der Hilfe von diesem tollen Forum und seinen Beiträgen, sowie der tatkräftigen Unterstützung von z.B. MCO und Oberschlumpf, habe ich folgenden Code zusammen gebaut der alles macht was er soll. Allerdings hat er noch einen "kleinen" Schönheitsfehler, wo ich nicht weiß wie ich ihn lösen kann.
Es werden im ersten Step Zeilen und Spalten ausgeblendet und dann sollte eigentlich nur der angezeigte Bereich kopiert und in eine Mail eingefügt werden. Leider wird aber der ganze Bereich angezeigt und in die Mail eingefügt und ich weiß nicht warum. Könnt Ihr mir da bitte weiter helfen? Wahrscheinlich muss irgendwo noch ein Hide gesetzt werden?
Gruß Ulf
Option Explicit
Sub Hide()
Dim liWeekNow As Integer, lloSearchWeek As Long
Dim lloWeekStart As Long, lloWeekEnd As Long
ActiveWorkbook.Save
With ActiveSheet
.Cells.EntireRow.Hidden = False
.Cells.EntireColumn.Hidden = False
.Range("D:D,F:Y,AB:AC,AE:AN,AV:BC,BJ:CK").EntireColumn.Hidden = True
liWeekNow = DINKw(Date)
For lloSearchWeek = .Cells(.Rows.Count, 3).End(xlUp).Row To 6 Step -8
If Year(.Range("C" & lloSearchWeek - 1).Value) = Year(Date) Then
If .Range("C" & lloSearchWeek).Value = liWeekNow Then
If Weekday(Date) vbMonday Then
lloWeekStart = lloSearchWeek - 15
lloWeekEnd = lloSearchWeek
Exit For
Else
lloWeekStart = lloSearchWeek - 23
lloWeekEnd = lloSearchWeek - 8
Exit For
End If
End If
End If
Next
.Rows(lloWeekStart & ":" & lloWeekEnd).EntireRow.Hidden = False
.Rows("6:" & lloWeekStart - 1).EntireRow.Hidden = True
.Rows(lloWeekEnd + 1 & ":" & .Cells(.Rows.Count, 3).End(xlUp).Row).EntireRow.Hidden = True
End With
Dim MailTo As String
Dim MailCc As String
Dim MailBcc As String
Dim Betreff As String
Dim Anrede As String
Dim Text1 As String
Dim Text As String
Dim olApp As Object
Dim olMail As Object
Dim strOldBody As String
Dim rng As Range
Set rng = Range("B4:BI" & lloWeekEnd)
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.Createitem(0)
MailTo = "u@s.com"
'MailCc = ""
'MailBcc = ""
Betreff = "Text (KW " & Range("C" & lloWeekEnd - 8).Value & " + " & Range("C" & lloWeekEnd).Value & " / Text"
Anrede = "Guten Tag zusammen,
"
Text1 = "anbei erhalten Sie der letzten beiden Wochen:
"
Text = Anrede & Text1 & RangeToHTML(rng)
With olMail
.GetInspector.Display
strOldBody = .htmlBody
.to = MailTo
.cc = MailCc
.bcc = MailBcc
.Subject = Betreff
.htmlBody = "" & Text & "" & strOldBody
.Display
'.Send
End With
Set olApp = Nothing
Application.DisplayAlerts = False
'ActiveWindow.Close SaveChanges:=False
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
Function DINKw(DAT As Date) As Integer
Dim kw As Integer
kw = Int((DAT - DateSerial(Year(DAT), 1, 1) + _
((Weekday(DateSerial(Year(DAT), 1, 1)) + 1) _
Mod 7) - 3) / 7) + 1
If kw = 0 Then
kw = DINKw(DateSerial(Year(DAT) - 1, 12, 31))
ElseIf kw = 53 And (Weekday(DateSerial(Year(DAT), 12, 31)) - 1) Mod 7