Excel-blätter per Makro versenden

Hallo Zusammen,
ich habe mir ein Mako zusammengestellt, mit dem ich einzelne Excelblätter an verschiedene Empfänger per Outlook versenden kann, was gut funktioniert.


Sub MailVersand()
Dim OL As Object
Dim IsCreated As Boolean
Dim Wb As Workbook
Dim aWb As Workbook
Dim Ws As Worksheet
Dim An As String
Dim Cc As String
Dim From As String
Dim Subject As String
Dim Dpfad As String
Dim Body As String
Dim clc
Set Wb = ThisWorkbook
With Application
clc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
If Err Then
Set OL = CreateObject("Outlook.Application")
IsCreated = True
End If
On Error GoTo 0
For Each Ws In Wb.Worksheets
Ws.Copy
Set aWb = ActiveWorkbook
aWb.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
Dpfad = aWb.FullName
An = aWb.Worksheets(1).Range("AB2").Value
Cc = aWb.Worksheets(1).Range("AF2").Value
Body = aWb.Worksheets(1).Range("AB5").Value
From = aWb.Worksheets(1).Range("AB4").Value
Subject = aWb.Worksheets(1).Range("AB3").Value
aWb.Close True
With OL.CreateItem(0)
.SentOnBehalfOfName = From
.To = An
.Cc = Cc
.Body = Body
.Subject = Subject
.Attachments.Add Dpfad
.Send
End With
Kill Dpfad
Set aWb = Nothing
Next
If IsCreated Then OL.Quit
With Application
.Calculation = cld
.ScreenUpdating = True
End With
Set OL = Nothing
Set Wb = Nothing
Set Ws = Nothing
End Sub

Ich scheitere nun daran, dass ich versuche dieses Makro so umstellen, dass die einzelnen Blätter nicht als Excel sondern als PDF gesendet werden.


Sub PDFMailVersand()
Dim OL As Object
Dim IsCreated As Boolean
Dim Wb As Workbook
Dim aWb As Workbook
Dim Ws As Worksheet
Dim An As String
Dim Cc As String
Dim From As String
Dim Subject As String
Dim Dpfad As String
Dim Body As String
Dim strDateiname As String
Dim clc
Set Wb = ThisWorkbook
With Application
clc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
If Err Then
Set OL = CreateObject("Outlook.Application")
IsCreated = True
End If
On Error GoTo 0
For Each Ws In Wb.Worksheets
Ws.Copy
Set aWb = ActiveWorkbook
strDateiname = ThisWorkbook.Path & "\" & ActiveSheet.Name & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strDateiname, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
An = aWb.Worksheets(1).Range("AB2").Value
Cc = aWb.Worksheets(1).Range("AF2").Value
Body = aWb.Worksheets(1).Range("AB5").Value
From = aWb.Worksheets(1).Range("AB4").Value
Subject = aWb.Worksheets(1).Range("AB3").Value
aWb.Close True
With OL.CreateItem(0)
.SentOnBehalfOfName = From
.To = An
.Cc = Cc
.Body = Body
.Subject = Subject
.Attachments.Add strDateiname
.Send
End With
Kill strDateiname
Set aWb = Nothing
Next
If IsCreated Then OL.Quit
With Application
.Calculation = cld
.ScreenUpdating = True
End With
Set OL = Nothing
Set Wb = Nothing
Set Ws = Nothing
End Sub

Hier werde ich nun bei jedem Blatt aufgefordet dieses in Excel zu speichern. Egal ob ich nun tatsächlich zwischenspeichere oder nicht, der Versand funktioniert. Aber ich will natürlich nicht bei jedem Blatt aktiv werden müssen. Was kann ich tun um dies abzustellen?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Imzadi,
ich denke, wenn du die Schleife über die Tabellenblätter so schreibst, sollte das funktionieren:
Set Wb = ThisWorkbook
For Each Ws In Wb.Worksheets
strDateiname = ThisWorkbook.Path & "\" & Ws.Name & ".pdf"
Ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strDateiname, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
An = Ws.Range("AB2").Value
Cc = Ws.Range("AF2").Value
Body = Ws.Range("AB5").Value
From = Ws.Range("AB4").Value
Subject = Ws.Range("AB3").Value
With OL.CreateItem(0)
.SentOnBehalfOfName = From
.To = An
.Cc = Cc
.Body = Body
.Subject = Subject
.Attachments.Add strDateiname
.Send
End With
Kill strDateiname
Next Ws
Viele Grüße
Dieter

Set Wb = ThisWorkbook For Each Ws In Wb.Worksheets strDateiname = ThisWorkbook.Path & "\" & Ws.Name & ".pdf" Ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strDateiname, _ IncludeDocProperties:=False, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False An = Ws.Range("AB2").Value Cc = Ws.Range("AF2").Value Body = Ws.Range("AB5").Value From = Ws.Range("AB4").Value Subject = Ws.Range("AB3").Value With OL.CreateItem(0) .SentOnBehalfOfName = From .To = An .Cc = Cc .Body = Body .Subject = Subject .Attachments.Add strDateiname .Send End With Kill strDateiname Next Ws

Sub PDFMailVersand() Dim OL As Object Dim IsCreated As Boolean Dim Wb As Workbook Dim aWb As Workbook Dim Ws As Worksheet Dim An As String Dim Cc As String Dim From As String Dim Subject As String Dim Dpfad As String Dim Body As String Dim strDateiname As String Dim clc Set Wb = ThisWorkbook With Application clc = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With On Error Resume Next Set OL = GetObject(, "Outlook.Application") If Err Then Set OL = CreateObject("Outlook.Application") IsCreated = True End If On Error GoTo 0 For Each Ws In Wb.Worksheets Ws.Copy Set Wb = ThisWorkbook strDateiname = ThisWorkbook.Path & "\" & Ws.Name & ".pdf" Ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strDateiname, _ IncludeDocProperties:=False, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False An = Ws.Range("AB2").Value Cc = Ws.Range("AF2").Value Body = Ws.Range("AB5").Value From = Ws.Range("AB4").Value Subject = Ws.Range("AB3").Value With OL.CreateItem(0) .SentOnBehalfOfName = From .To = An .Cc = Cc .Body = Body .Subject = Subject .Attachments.Add strDateiname .Send End With Kill strDateiname Next Ws If IsCreated Then OL.Quit With Application .Calculation = cld .ScreenUpdating = True End With Set OL = Nothing Set Wb = Nothing Set Ws = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Excel-blätter per Makro versenden

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread