Makro - pdf erstellen, speichern senden und drucke
30.11.2015 22:25:42
Roland
Bin neu hier und habe ein Problem mit einem Excel Makro in Office 2010.
Grundsätzlich habe ich keine Erfahrung mit VBA, aber habe mir mittels google, diversen foren und etwas kreativität eine Excel Bestellvorlage gebastelt, die mittels Makro ein pdf erstellt, und dieses dann nach Outlook zum Versenden übergibt. (mit bestimmten Mailadressen, text, signatur usw...)
Das ganze Makro läuft unter Office 2013 einwandfrei, aber wir würden dass in der Arbeit unter Office 2010 32bit SP2 benötigen, und da hängt sich Excel nach dem Erstellen des ersten pdfs auf..., und zwar so das es flackert und nur mehr mittels Taskmanager und Prozess beenden geschlossen werden kann.
hier die Datei zum testen....
https://www.herber.de/bbs/user/101911.zip
hier der code:
Bitte nicht auslachen, hab ich ohne Vorkenntnisse zusammengestoppelt :)
wäre über eine hilfe sehr dankbar
lg Roland
Sub PDFMailencurrent()
Dim xlName As String
Dim xlName1 As String
Dim xlPfad As String
Dim xlOpenAfterPublish As Boolean
Dim Frage As String
Rem pdf nach erstellen öffnen
xlOpenAfterPublish = True
With ActiveWorkbook
Rem PDF-File erstellen, unter TEMP speichern
On Error GoTo Datei_offen
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\Windows\Temp\BESTELLUNG_temp. _
pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=IIf( _
xlOpenAfterPublish, True, False)
GoTo Datei_richitg
Datei_offen:
Datei_offen = MsgBox("Schließen Sie die temporäre pdf Datei (Bestellung_temp.pdf) und _
wiederholen Sie den Vorgang", vbOKOnly + vbCritical, "Temporäre Datei offen")
Exit Sub
Datei_richitg:
Frage = MsgBox("Bitte die pdf Datei auf Richtigkeit überprüfen. " & vbCrLf & " Klicken Sie OK _
um die Datei zu senden", 1 + 32, "Bist du dir sicher?")
If Frage = 1 Then GoTo Mailen
Exit Sub
End With
Mailen:
xlOpenAfterPublish = False
Rem Datei wurde als pdf per mail versendet, mit genauer Uhrzeit und Datum
Range("Sendebestätigung").Formula = "Diese Datei wurde am" & Format(Now, "_yyyy mm dd_hh-mm_") & _
"als pdf per Mail versendet"
Rem Dateiname aus Zelle auslesen Variante 1
xlName = Format(Now, "_yyyy mm dd_hh-mm_") & Format((Range("ProjPos")), "0000") & "_" & Range(" _
KOPF") & "_" & Range("PosBez") & "_" & Range("Lieferant").Value
Rem Dateiname aus Zelle auslesen Variante 2
xlName1 = ActiveWorkbook.Name & "_BESTELLUNG" & Format(Now, "_yyyy mm dd_hh-mm_")
With ActiveWorkbook
Rem PDF-File erstellen, in Dateipfad speichern
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & xlName, Quality:= _
xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish: _
=IIf(xlOpenAfterPublish, True, False)
Rem PDF-File erstellen, im in Zelle A2 angegebenen Pfad und unter in A1 angegebenen Namen _
speichern
Rem .ExportAsFixedFormat Type:=xlTypePDF, Filename:=xlName, Quality:=xlQualityStandard, _
rem IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Dim Mailadresse As String, Betreff As String
Dim olApp As Object
Set olApp = CreateObject("Outlook.Application")
Mailadresse = Range("Mailadresse")
Betreff = Range("KOPF") & " " & Range("Proj") & " " & Range("ProjNr") & " Pos " & Format(( _
Range("ProjPos")), "0000") & " " & Range("PosBez").Value
With olApp.CreateItem(0)
.To = Mailadresse
.Subject = Betreff
On Error Resume Next
.Attachments.Add ThisWorkbook.Path & "\" & xlName & ".pdf"
On Error Resume Next
.Attachments.Add ThisWorkbook.Path & "\" & Range("ANHANG1")
On Error Resume Next
.Attachments.Add ThisWorkbook.Path & "\" & Range("ANHANG2")
On Error Resume Next
.Attachments.Add ThisWorkbook.Path & "\" & Range("ANHANG3")
On Error Resume Next
.Attachments.Add ThisWorkbook.Path & "\" & Range("ANHANG4")
On Error Resume Next
.Attachments.Add ThisWorkbook.Path & "\" & Range("ANHANG5")
On Error Resume Next
.Attachments.Add ThisWorkbook.Path & "\" & Range("ANHANG6")
On Error Resume Next
.Attachments.Add ThisWorkbook.Path & "\" & Range("ANHANG7")
.Display
.htmlbody = "
" & "Sehr geehrte Damen und Herren!" & "
" & "" & "
" & "In der _
Anlage erhalten Sie eine Bestellung zu BV " & Range("Proj") & " " & Range("ProjNr") & " Pos " & Format((Range("ProjPos")), "0000") & " " & Range("PosBez") & "." & "
" & "" & "
" & "Mit der Bitte um weitere Bearbeitung!" & .htmlbody
Rem .send
End With
Set olApp = Nothing
Rem Boolean-Variable ausschalten
xlOpenAfterPublish = False
fertig = MsgBox("Die Bestellung wurde an Outlook übergeben und versendet", vbOKOnly + _
vbInformation, "Bestellung erfolgreich abgeschlossen!")
fertig = MsgBox("Speichern 1x Drucken und schließen?", 1 + 32, "Speichern und schließen?")
If fertig = 32 Then GoTo habenfertig
Call Drucken
.Close savechanges:=True
habenfertig:
End With
End Sub
Sub Drucken()
Dim sDruckerAktuell As String
sDruckerAktuell = Application.ActivePrinter 'Aktuellen Drucker merken
Application.ActivePrinter = "PDFCreator" 'gewünschten Drucker setzen
ActiveSheet.PrintOut Copies:=2, Collate:=True 'Drucken
Application.ActivePrinter = sDruckerAktuell 'Drucker wieder auf gemerkten Drucker setzen
End Sub
Anzeige