AW: Excel Datei automatisch speichern und versenden
26.06.2013 08:51:16
Klaus
Hi Tobias,
hatta!
Deine Erklärungstexte natürlich aus der Datei löschen, sonst kommen die mit ins PDF.
Ich habe mir jetzt nicht die Mühe gemacht, alle Spalten / Zeilen zu dynamisieren. Wenn du Zeilen oder Spalten verschiebst oder Blätter umbenennst, musst du im Code entsprechend ändern.
Im Code die Zeile (ganz oben)
Const MyPath As String = "C:\TestTmp\"
anpassen, bevor du ihn das erste mal startest!
Grüße,
Klaus M.vdT.
Option Explicit
'Hier den Pfad anpassen, unter dem du die PDFs speichern willst!
Const MyPath As String = "C:\TestTmp\"
'Hier angeben, ob du die PDFs speichern (True) oder nach versand löschen (False) willst!
Const KeepPDF As Boolean = True
'Definition der Mail-Inhalte
Const MailSubject As String = "Zusammenfassung von / für " '+Anwender 1 usw
Const MailText1 As String = "Hallo " '+Anwender
Const MailText2 As String = ", (br) hier ist deine Zusammenfassung!" 'HTML-Tags im Text nutzen! _
Sub EachUserOnce()
Dim sUserName As String
Dim sUserMail As String
Dim sUserText As String
Dim LastRow As Long
Dim r As Range
With Sheets("Hilfstabelle")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).row
For Each r In .Range(.Cells(1, 1), .Cells(LastRow, 1))
sUserName = r.Value
sUserMail = r.Offset(0, 1).Value
sUserText = MailText1 & sUserName & MailText2
Sheets("Email").Range("A2").Value = sUserName
Call SendSheetOutlook(MailSubject & sUserName, sUserMail, "", sUserText, sUserName)
Next r
End With
End Sub
'Makro to send Excel-Sheet directly with outlook
'April 2013 by Klaus M.vdT.
'MODIFIED June 2013: Send pdf, not xlsx!
'original Code by mumpel / www.herber.de / 11.04.2013 11:23:25
'https://www.herber.de/forum/messages/1308295.html
Private Sub SendSheetOutlook(sSubject As String, sTo As String, sCC As String, sText As String, _
sUser As String)
Dim olApp As Object
Dim AWS As String
Dim olOldBody As String
'define temporary Path and Filename
AWS = MyPath & "\" & Format(Date, "YYYYMMDD") & "_" & Format(Time, "hhmmss") & " _
_Zusammenfassung_" & sUser
'export File as PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=AWS, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
AWS = AWS & ".pdf"
'Make Email
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.GetInspector.Display
olOldBody = .htmlBody
.To = sTo
.cc = sCC
.Subject = sSubject
.htmlBody = sText & olOldBody
.Attachments.Add AWS
End With
'remove TEMP file
If Not KeepPDF Then Kill AWS
End Sub