Code anpassen

Private Sub EMAIL_Senden(Empfänger As String, Betreff As String, rngBody As Range) Dim MyOutApp As Object, MyMessage As Object Dim sPath$, sHTMLBody$, sInhalt$ Dim F% sPath = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\") sPath = sPath & "tmpHTMLFile.html" ThisWorkbook.PublishObjects.Add( _ xlSourceRange, _ sPath, _ rngBody.Parent.Name, _ rngBody.Address, _ xlHtmlStatic).Publish (True) F = FreeFile Open sPath For Binary As #F sInhalt = Space$(LOF(F)) Get #F, , sInhalt Close Kill sPath sInhalt = Replace(sInhalt, "align=center", "align=left") Set MyOutApp = CreateObject("Outlook.Application") Set MyMessage = MyOutApp.CreateItem(0) With MyMessage .To = Empfänger '"Hier kommt die Adresse rein" .CC = "" .Bcc = "" .Subject = Betreff '"Text für Betreffzeile" .htmlBody = sInhalt .Display '.Attachments.Add sPath '.Send 'Hier wird die Mail gesendet End With Set MyOutApp = Nothing Set MyMessage = Nothing End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Bereich_Mail() EMAIL_Senden "", Tabelle1.Ranger("G1").Value, Tabelle1.Range("A2:E10") End Sub Private Sub EMAIL_Senden(Empfänger As String, Betreff As String, rngBody As Range) Dim MyOutApp As Object, MyMessage As Object Dim sPath$, sHTMLBody$, sInhalt$ Dim F% sPath = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\") sPath = sPath & "tmpHTMLFile.html" ThisWorkbook.PublishObjects.Add( _ xlSourceRange, _ sPath, _ rngBody.Parent.Name, _ rngBody.Address, _ xlHtmlStatic).Publish (True) F = FreeFile Open sPath For Binary As #F sInhalt = Space$(LOF(F)) Get #F, , sInhalt Close Kill sPath sInhalt = Replace(sInhalt, "align=center", "align=left") Set MyOutApp = CreateObject("Outlook.Application") Set MyMessage = MyOutApp.CreateItem(0) With MyMessage .To = Empfänger '"Hier kommt die Adresse rein" .CC = "" .Bcc = "" .Subject = Betreff '"Text für Betreffzeile" .htmlBody = sInhalt .Display '.Attachments.Add sPath '.Send 'Hier wird die Mail gesendet End With Set MyOutApp = Nothing Set MyMessage = Nothing End Sub

Hallo,
vielleicht so.

Sub Makro1()
Dim rngBereichToPDF As Range, rngBody As Range
Dim sPath$, sTmp$

sPath = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
sPath = sPath & "MePDF.pdf"

Set rngBereichToPDF = Tabelle1.Range("A2:E10")

sTmp = rngBereichToPDF.Parent.PageSetup.PrintArea
rngBereichToPDF.Parent.PageSetup.PrintArea = rngBereichToPDF.Address

rngBereichToPDF.Parent.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    sPath, Quality:=xlQualityStandard, IncludeDocProperties:= _
    True, IgnorePrintAreas:=False, OpenAfterPublish:=False

rngBereichToPDF.Parent.PageSetup.PrintArea = sTmp

'rngBody ist kein Bereich zugewiesen 
EMAIL_Senden "", "Betreff", rngBody, sPath

''oder rngBody ist ein Bereich zugewiesen & sPath = "" bzw. leer 
'Set rngBody = rngBereichToPDF 
'EMAIL_Senden "", "Betreff", rngBody, "" 

''oder rngBody ist ein Bereich zugewiesen & sPath = ein Pfad 
'Set rngBody = rngBereichToPDF 
'EMAIL_Senden "", "Betreff", rngBody, sPath 

End Sub

Private Sub EMAIL_Senden(Empfänger As String, Betreff As String, rngBody As Range, strPath$)
Dim MyOutApp As Object, MyMessage As Object
Dim sPath$, sHTMLBody$, sInhalt$
Dim F%

If Not rngBody Is Nothing Then
    sPath = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
    sPath = sPath & "tmpHTMLFile.html"
    ThisWorkbook.PublishObjects.Add( _
    xlSourceRange, _
    sPath, _
    rngBody.Parent.Name, _
    rngBody.Address, _
    xlHtmlStatic).Publish (True)


    F = FreeFile
    Open sPath For Binary As #F
    sInhalt = Space$(LOF(F))
    Get #F, , sInhalt
    Close


    Kill sPath
    
    sInhalt = Replace(sInhalt, "align=center", "align=left")
End If

Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)

With MyMessage
  .To = Empfänger '"Hier kommt die Adresse rein" 
  .CC = ""
  .Bcc = ""
  .Subject = Betreff '"Text für Betreffzeile" 
  If strPath <> "" Then .Attachments.Add strPath
  .htmlBody = sInhalt
  .Display
  '.Send 'Hier wird die Mail gesendet 
End With
Set MyOutApp = Nothing
Set MyMessage = Nothing
    
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread