RangeToHTML funktioniert nicht mehr

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code:

Option Explicit

Private Sub Mail_BereichalsBereich()
' Sendet Mail mit integriertem Bereich mit Signatur
' Bereich wird über Range2HTML bereitgestellt
  Dim WSh1 As Worksheet, WSh2 As Worksheet
  Dim sMailtext As String, sBer As String
  
  sBer = "A3:G23"                               ' Kopierbereich
  Set WSh1 = ThisWorkbook.Sheets("Tabelle1")    ' Blatt mit Maildaten
  Set WSh2 = ThisWorkbook.Sheets("Tabelle2")    ' Datenblatt
  
  With CreateObject("Outlook.Application").CreateItem(0)
      .BodyFormat = 2                           ' HTML-Format, Angabe optional
      .Subject = WSh1.Range("A2").Value         ' Betreff
      .To = WSh1.Range("A3").Value              ' Empfänger
      .CC = WSh1.Range("A4").Value              ' Kopie an
'     .Bcc = WSh1.Range("A4").Value
      sMailtext = WSh1.Range("A5").Value        ' Mailtext
      .Getinspector
      .htmlbody = Replace(sMailtext, vbLf, "<br>") _
      & Range2Html(WSh2.Range(sBer)) & .htmlbody
      .Display
  End With

End Sub

Private Function Range2Html(oBereich As Range) As String
' Gibt den angegebenen Bereich als HTML zurück, incl.Bilder
  Dim sTmpDatei As String, sTmp As String, sTmpVz As String
  Dim iff As Integer, P As Long

' Bereich in Datei exportieren
  With oBereich
      sTmpVz = Environ$("temp") & "\"
      sTmpDatei = sTmpVz & Format(Now, "ddmmyy" & Int(Timer) * 10) & ".htm"
      .Parent.Parent.PublishObjects.Add( _
      SourceType:=xlSourceRange, _
      Filename:=sTmpDatei, Sheet:=.Parent.Name, Source:=.Address, _
      HtmlType:=xlHtmlStatic).Publish Create:=True
      
      iff = FreeFile
      Open sTmpDatei For Input As iff
      Range2Html = Replace(Input(LOF(iff), iff), "align=center x:publishsource=", _
      "align=left x:publishsource=")
      Close iff

' Feststellen, ob auch Bilder im Bereich sind
      P = InStr(1, Range2Html, "<link rel=File-List href=") + 26
      If P > 26 Then
         sTmp = Mid$(Range2Html, P, InStr(P, Range2Html, "/filelist.xml") - P)
         Range2Html = Replace(Range2Html, sTmp, sTmpVz & sTmp)
      End If
      
  End With
  
  On Error Resume Next
  Kill sTmpDatei
  Kill sTmpVz & sTmp

End Function

Hallo Karl-Heinz,
der Vollständigkeit halber hier noch einmal der ganze Code der vorher funktioniert hatte. Deine Lösungsvorschläge werde ich wie bereits erwähnt ausprobieren.
Gruß Ulf

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,AC:AT,BB:BI,BT:CS").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 Text2 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:BS" & lloWeekEnd).SpecialCells(xlCellTypeVisible)
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.Createitem(0)
    
    MailTo = ""
    MailCc = ""

    Betreff = ""
    Anrede = ""
    Text1 = ""
    Text = Anrede & Text1 & RangeToHTML(rng)
    
    With olMail
        .GetInspector.Display
        strOldBody = .htmlBody
        .to = MailTo
        .cc = MailCc
        .bcc = MailBcc
        .Subject = Betreff
        .htmlBody = Text & strOldBody
        .Display
    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

Code:

Private Sub Mail_BereichalsBereich_Word2()
' Sendet Mail mit integriertem Bereich als Bereich ohne Signatur
  Dim WSh1 As Worksheet, WSh2 As Worksheet
  Dim sBer As String
  
  sBer = "A3:G23"                               ' Kopierbereich
  Set WSh1 = ThisWorkbook.Sheets("Tabelle1")    ' Blatt mit Maildaten
  Set WSh2 = ThisWorkbook.Sheets("Tabelle2")    ' Datenblatt
  
  WSh2.Range(sBer).Copy                         ' Bereich kopieren
' WSh2.Range(sBer).CopyPicture Appearance:=xlScreen, Format:=xlBitmap _
 'als Bild
  
  With CreateObject("Outlook.Application").CreateItem(0)
      .BodyFormat = 2                           ' 2=HTML-Format, 3=Richtext
      .Subject = WSh1.Range("A2").Value         ' Betreff
      .To = WSh1.Range("A3").Value              ' Empfänger
      .CC = WSh1.Range("A4").Value              ' Kopie
      .Display
      
      .Getinspector.WordEditor.Range.Paste      ' Grafik in Mail einfügen
  End With

End Sub

Code:

Private Sub Mail_BereichalsBereich_Word3()
' Sendet Mail mit integriertem Bereich als Bereich mit Signatur
' Das Bild wird über das Kürzel ~ im Text platziert
  Dim WSh1 As Worksheet, WSh2 As Worksheet
  Dim sMailtext As String, sSignatur As String
  Dim sBer As String, iEinf As Integer
  
  sBer = "A3:G23"                               ' Kopierbereich
  Set WSh1 = ThisWorkbook.Sheets("Tabelle1")    ' Blatt mit Maildaten
  Set WSh2 = ThisWorkbook.Sheets("Tabelle2")    ' Datenblatt
  
  WSh2.Range(sBer).Copy                         ' Bereich kopieren
  
  With CreateObject("Outlook.Application").CreateItem(0)
      .BodyFormat = 2                           ' 2=HTML-Format, 3=Richtext
      .Subject = WSh1.Range("A2").Value         ' Betreff
      .To = WSh1.Range("A3").Value              ' Empfänger
      .CC = WSh1.Range("A4").Value              ' Kopie
      sMailtext = WSh1.Range("A5").Value & vbLf
      .Getinspector                             ' Signatur holen
      .htmlbody = Replace(sMailtext, vbLf, "<br>") & .htmlbody
      .Display
      
      iEinf = InStr(sMailtext, "~")
      If iEinf = 0 Then iEinf = Len(sMailtext)  ' Grafik Einfügestelle
      
      With .Getinspector.WordEditor.Application.Selection
           .Start = iEinf: .End = iEinf
           .Paste                              'Grafik in Mail einfügen
      End With
      
  End With

End Sub

Beliebteste Forumthreads (12 Monate)

RangeToHTML funktioniert nicht mehr

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

RangeToHTML funktioniert nicht mehr

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread