Makro - pdf erstellen, speichern senden und drucke

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
Bild

Betrifft: Makro - pdf erstellen, speichern senden und drucke
von: Roland
Geschrieben am: 30.11.2015 22:25:42

Hallo beisammen!
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

Bild

Betrifft: AW: Makro - pdf erstellen, speichern senden und drucke
von: mumpel
Geschrieben am: 01.12.2015 03:46:34
Hallo!
Welches PDF-Programm setzt ihr zum Lesen der PDF-Datei ein?
Grß, René

Bild

Betrifft: AW: Makro - pdf erstellen, speichern senden und drucke
von: mumpel
Geschrieben am: 01.12.2015 06:02:57
Ich habe den Code mal etwas angepasst. Vielleicht funktioniert der ja besser.

Sub PDFMailencurrent()

 Dim olApp             As Object
 Dim objWMI            As Object
 Dim Anwendung         As Object
 Dim lngAttachCount    As Long
 Dim xlName            As String
 Dim xlName1           As String
 Dim xlPfad            As String
 Dim olOldBody         As String
 Dim sDruckerAktuell   As String

Rem Adobe Reader schließen 
  On Error Resume Next

   Set objWMI = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("select * " & _
                          "from win32_process where name='" & _
                          "AcroRd32.exe" & "' ")
       For Each Anwendung In objWMI
                Anwendung.Terminate
       Next
  On Error GoTo 0
 Rem pdf nach erstellen öffnen 


 Rem PDF-File erstellen, unter TEMP speichern 

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                Filename:="C:\Windows\Temp\BESTELLUNG_temp.pdf", _
                                Quality:=xlQualityStandard, _
                                IncludeDocProperties:=True, _
                                IgnorePrintAreas:=False, _
                                OpenAfterPublish:=True


    If MsgBox("Bitte die pdf Datei auf Richtigkeit überprüfen. " & _
              vbCrLf & " Klicken Sie OK " & _
              "um die Datei zu senden", 36, _
              "Bist du dir sicher?") = vbNo Then Exit Sub



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_")
           


 Rem PDF-File erstellen, in Dateipfad speichern 
 ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _
                                    Filename:=ThisWorkbook.Path & _
                                              "\" & xlName, _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False



     Set olApp = CreateObject("Outlook.Application")

     With olApp.CreateItem(0)
         .GetInspector.Display
         olOldBody = .htmlBody
         .To = Range("Mailadresse").Value
         .Subject = Range("KOPF") & " " & _
                    Range("Proj") & " " & _
                    Range("ProjNr") & _
                    " Pos " & Format(( _
                    Range("ProjPos")), "0000") & _
                    " " & Range("PosBez").Value
    
         .Attachments.Add ThisWorkbook.Path & "\" & xlName & ".pdf"
         
         On Error Resume Next
         For lngAttachCount = 1 To 7
            .Attachments.Add ThisWorkbook.Path & "\" & _
                             Range("ANHANG" & lngAttachCount).Value
         Next lngAttachCount
         On Error GoTo 0
         
         .htmlBody = "" & olOldBody
         '.send 

     End With


    If MsgBox("Die Bestellung wurde an Outlook übergeben und versendet" & _
               vbCrLf & vbCrLf & _
              "Soll jetzt gedruckt und gespeichert werden?", 36, _
              "Bestellung erfolgreich abgeschlossen!") = vbNo Then Exit Sub

 
  Rem Aktuellen Drucker merken 
  sDruckerAktuell = Application.ActivePrinter

  Rem Aktives Tabellenblatt drucken 
  ActiveSheet.PrintOut Copies:=2, Collate:=True, ActivePrinter:="PDFCreator"
 
  Rem Drucker wieder auf gemerkten Drucker setzen 
  Application.ActivePrinter = sDruckerAktuell

  Rem Aktive Datei schließen.Änderungen speichern 
  ActiveWorkbook.Close savechanges:=True

End Sub

VBA/HTML - CodeConverter für Office-Foren, komplett in VBA geschrieben von Lukas Mosimann. Projektbetreuung durch RMH Software & Media

Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0



Bild

Betrifft: Nachtrag
von: mumpel
Geschrieben am: 01.12.2015 06:06:05
Ersetze mal "Range("Sendebestätigung").Formula" durch "Range("Sendebestätigung").Value".

Bild

Betrifft: AW: Nachtrag
von: Roland
Geschrieben am: 01.12.2015 11:18:12
Hallo mumpel!
Danke für den Code, hab aber den gleichen fehler....
wenn ich einen Process Recorder laufen lasse, dann kommen immer wieder folgende prozesse: siehe unten
kennt sich da jemand aus was das sein kann? Wir haben allerdings vor ca. einem Jahr alle PCs neu aufgesetzt, und so ein Problem haben wir manchmal auch wenn wir aus dem Excel ganz normal das aktuelle Tabellenblatt als text senden. Da tritt der fehler auf, sobald man auf senden klickt. Und die Probleme gab es allerdings auch vor dem neu Aufsetzen (Office und Windwos 7 64bit Versionen sind gleich geblieben)
07:20:52,2161228 EXCEL.EXE 4780 RegCloseKey HKCU SUCCESS
07:20:52,2179981 EXCEL.EXE 4780 RegOpenKey HKCU SUCCESS Desired Access: Read
07:20:52,2180197 EXCEL.EXE 4780 RegQueryKey HKCU SUCCESS Query: HandleTags, HandleTags: 0x0
07:20:52,2180343 EXCEL.EXE 4780 RegOpenKey HKCU\Software\Microsoft\Windows NT\CurrentVersion\windows SUCCESS Desired Access: Read
07:20:52,2180483 EXCEL.EXE 4780 RegSetInfoKey HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows SUCCESS KeySetInformationClass: KeySetHandleTagsInformation, Length: 0
07:20:52,2180699 EXCEL.EXE 4780 RegQueryKey HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows SUCCESS Query: HandleTags, HandleTags: 0x400
07:20:52,2180839 EXCEL.EXE 4780 RegOpenKey HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows\SessionDefaultDevices\S-1-5-5-0-688431 NAME NOT FOUND Desired Access: Read
07:20:52,2180964 EXCEL.EXE 4780 RegQueryValue HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows\Device SUCCESS Type: REG_SZ, Length: 80, Data: \\rime-print\KOPIERER-EG,winspool,Ne12:
07:20:52,2181193 EXCEL.EXE 4780 RegCloseKey HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows SUCCESS
07:20:52,2181324 EXCEL.EXE 4780 RegCloseKey HKCU SUCCESS
07:20:52,2181572 EXCEL.EXE 4780 RegOpenKey HKCU SUCCESS Desired Access: Read
07:20:52,2181720 EXCEL.EXE 4780 RegQueryKey HKCU SUCCESS Query: HandleTags, HandleTags: 0x0
07:20:52,2181840 EXCEL.EXE 4780 RegOpenKey HKCU\Software\Microsoft\Windows NT\CurrentVersion\windows SUCCESS Desired Access: Read
07:20:52,2181951 EXCEL.EXE 4780 RegSetInfoKey HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows SUCCESS KeySetInformationClass: KeySetHandleTagsInformation, Length: 0
07:20:52,2182273 EXCEL.EXE 4780 RegQueryKey HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows SUCCESS Query: HandleTags, HandleTags: 0x400
07:20:52,2182467 EXCEL.EXE 4780 RegOpenKey HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows\SessionDefaultDevices\S-1-5-5-0-688431 NAME NOT FOUND Desired Access: Read
07:20:52,2182612 EXCEL.EXE 4780 RegQueryValue HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows\Device SUCCESS Type: REG_SZ, Length: 80, Data: \\rime-print\KOPIERER-EG,winspool,Ne12:
07:20:52,2182906 EXCEL.EXE 4780 RegCloseKey HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows SUCCESS

Bild

Betrifft: AW: Nachtrag
von: Roland
Geschrieben am: 01.12.2015 11:22:51
so jetzt hab ich noch was probiert, aber das verstehe ich nicht:
wenn ich die erste Message Box aus dem Makro entferne:
If MsgBox("Bitte die pdf Datei auf Richtigkeit überprüfen. " & _
vbCrLf & " Klicken Sie OK " & _
"um die Datei zu senden", 36, _
"Bist du dir sicher?") = vbNo Then Exit Sub
dann läuft das Makro durch....
und wir haben Adobe Acrobat reader

Bild

Betrifft: AW: Nachtrag
von: mumpel
Geschrieben am: 01.12.2015 11:34:16
Merkwürdig. Schon mal versucht die PDF-Datei zu schließen bevor die MsgBox bestätigt wird?

Bild

Betrifft: AW: Nachtrag
von: Roland
Geschrieben am: 01.12.2015 16:09:44
so, jetzt wird es noch komischer
wenn ich die Schaltfläche "aktuelles Tabellenblatt per Mail senden" herauslösche, und das makro über entwicklertools - makros ausführe funktioniert es.
wenn ich aus der zwischenablage aber irgend eine grafik in die tabelle einfüge, oder wieder eine neue schaltfläche erstelle hängt sich excel beim Makro Ausführen wieder auf
mittlerweile hab ich es auf 6 verschiedenen pcs mit jeweils office 2010 versucht, und bei 2 davon hat es funktioniert....
virenscanner habe ich auch schon komplett deaktiviert.... hilft nicht

Bild

Betrifft: AW: Nachtrag
von: Roland
Geschrieben am: 01.12.2015 12:08:02
es kommt die temporäre pdf Datei, und die Message box kommt dann nicht mehr...
da hängt dann alles.
Aber das komische ist, wenn ich die datei öffne, dann in VBA diese Message box herauslösche, das makro ausführe, danach die messagebox wieder einfüge dann funktionierts.
Sobald ich dann die Datei schließe und wieder öffne, wieder gleiches problem...

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Makro - pdf erstellen, speichern senden und drucke"