Oct 23, 2014, updated at Oct 28, 2014 (UTC)

2205

Excel 2010 Makro Probleme mit komp. Excel 2013, Qualität von PDF und Dateinamen

Hallo Leute...

Brauch dringende eure Unterstützung.
Bin seit kurzem Makro-Anwender und hab mir seit dem alles aus dem Internet heraus gesucht was ich benötige. Bin au ziemlich weit gekommen, nun aber bin ich mit meinen Stichwortsuche am Ende. Folgend mal mein aktueller Code:

Public Sub TabelleAlsPdf()

Dim olApp      As Object
Dim AWS        As String
Dim olOldBody  As String
Dim strAddress As String
Dim i          As Integer

' Rem Pfad für PDF festlegen  
AWS = "H:\XXX\YYY\AB " & Range("M25") & " " & Range("E14") & ".pdf"  

' Bestimmen der E-Mailadresse  
strAddress = Range("O19")  

' Rem Tabelle2 als PDF speichern  
If Dir(AWS) = "" Then  
ThisWorkbook.Sheets("AB TL").ExportAsFixedFormat Type:=xlTypePDF, Filename:=AWS, Quality:=xlQualityStandard, _  
                                                    IncludeDocProperties:=False, IgnorePrintAreas:=False, _
                                                    OpenAfterPublish:=False
Else
   MsgBox "Der verwendete Dateiname ist bereits vorhanden."  
   Exit Sub
End If

Rem Email erstellen
Set olApp = CreateObject("Outlook.Application")  
    With olApp.CreateItem(0)
        Set .SendUsingAccount = .Session.Accounts.Item("info@moebelagentur.ch") ' Sendekonto vorwählen (für jede Emailadresse eine _  
                                                                        eigene Datendatei erforderlich). _
                                                                        "Kontoname" = Name des Kontos (in Anführungszeichen) _  
                                                                        wie er in Outlook angezeigt wird.
              .GetInspector.Display
              olOldBody = .htmlBody
              .To = strAddress
              .Subject = "Auftragsbestätigung " & Range("M25") & " - " & Range("J28")  ' Betreff  
              .htmlBody = "<span style=""font-size:11pt; font-family:'calibri'"">" & _  
                          "Sehr geehrte Damen und Herren<br><br>" & _  
                          "Herzlichen Dank für Ihre Bestellung.<br>" & _  
                          "Im Anhang finden Sie die entsprechende Auftragsbestätigung.<br><br>" & _  
                          "Wir bitten Sie die Auftragsbestätigung zu kontrollieren. Ohne Gegenbericht innert 5 Tagen gilt der Auftrag als genehmigt." & olOldBody ' Body. "<br>" = Zeilenumbruchanweisung  
              .Attachments.Add AWS 'Datei anhängen  
     
    End With

End Sub

Folgende Schwierigkeit gilt es noch zu beheben, bevor ich diesen Einsetzen kann:

1. Der Code ist in dieser Form nicht mit Excel 2013 kompatibel. "Laufzeitfehler" oder "Fehler 400" werden angezeigt. Was muss ich ändern damit dieser auch auf dem neuen Office läuft? (Auf Excel 2010 läuft alles geschmeidig)
Der Computer mit dem Excel 2013 ist zurzeit nicht verfügbar, daher kann ich nichts testen. Aber könnte es helfen wenn ich die Excel Datei mit dem Makro mit 2013 öffne, einmal abspeichere, alles schliessen und wieder öffne?

2. Die Erstellung der PDF's läuft absolut problemlos und das Dokument wird auch richtig im Outlook angefügt. Nur ist das Problem, dass das PDF-Dokument extrem hässlich aussieht von der Qualität. Kennt jemand eine Variante/Möglichkeit wie ich ein schöneres PDF erstellen kann?
Eine Variante die ich noch erforschen konnte, ist der Weg über den PDFCreator. Hatte aber bis anhin kein Erfolg bei der Integration eines Codes der den PDFCreator ansteuert.

3. Beim speichern des PDF's wird gleichzeitig geprüft ob der Dateiname schon vorhanden ist. Gibt es eine möglichkeit, dass der Dateiname automatisch um einen bestimmten Text (z.B. Version 2) erweitert wird, falls es diese Datei schon gibt?
Dazu gibt es (soweit ich weiss) die DIR() funktion. Hab aber nicht geschnallt wo dieser hin muss!

Habt Ihr ideen?
Freue mich auf eure Antworten

Gruss
GmbH

Please also mark the comments that contributed to the solution of the article

Content-Key: 252836

Url: https://administrator.de/contentid/252836

Printed on: April 18, 2024 at 01:04 o'clock

17 Comments

Latest comment

Hallo Aeschli!

Zum Laufzeitfehler kann ich leider nix sagen, da ich kein Outlook nutze?

Den Pdf-Creater kannst Du in etwa so verwenden:

ThisWorkbook.Sheets("AB TL").PrintOut , , 1, , "PDFCreater"

Grüße Dieter

Hi,
also so läuft das auch testweise auf einem Outlook 2013 mit deiner gewünschten Erweiterung (Anhängen einer Nummer falls eine Datei schon existiert.)

Public Sub TabelleAlsPdf()
	Dim olApp      	As Object
	Dim fso  	As Object
	Dim AWS        	As String
	Dim olOldBody  	As String
	Dim strAddress 	As String
	Dim i          	As Integer
        Dim cnt         As integer
	
        'Filesystem-Object erzeugen  
	Set fso = CreateObject("Scripting.FileSystemObject")    
	
	' Rem Pfad für PDF festlegen  
	AWS = "H:\XXX\YYY\AB " & Range("M25") & " " & Range("E14") & ".pdf"  
	
	'Falls Datei schon existiert, hänge Nummer an  
	cnt = 1
	While fso.FileExists(AWS)
		AWS = fso.GetParentFolderName(AWS) & "\" & fso.GetBaseName(AWS) & "(" & cnt & ")." & fso.GetExtensionName(AWS)  
		cnt = cnt + 1
	Wend
	
	' Bestimmen der E-Mailadresse  
	strAddress = Range("O19").Value  
	
	' Rem Tabelle2 als PDF speichern  
	ThisWorkbook.Sheets("AB TL").ExportAsFixedFormat Type:=xlTypePDF, Filename:=AWS, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False  

'Email erstellen  
	Set olApp = CreateObject("Outlook.Application")  
	With olApp.CreateItem(0)
        Set .SendUsingAccount = .Session.Accounts.Item("info@moebelagentur.ch") ' Sendekonto vorwählen  
		olOldBody = .htmlBody
		.To = strAddress
		.Subject = "Auftragsbestätigung " & Range("M25") & " - " & Range("J28")  ' Betreff  
		.htmlBody = "<span style=""font-size:11pt; font-family:'calibri'"">" & _  
		          "Sehr geehrte Damen und Herren<br><br>" & _  
		          "Herzlichen Dank für Ihre Bestellung.<br>" & _  
		          "Im Anhang finden Sie die entsprechende Auftragsbestätigung.<br><br>" & _  
		          "Wir bitten Sie die Auftragsbestätigung zu kontrollieren. Ohne Gegenbericht innert 5 Tagen gilt der Auftrag als genehmigt." & olOldBody ' Body. "<br>" = Zeilenumbruchanweisung  
		.Attachments.Add AWS 'Datei anhängen  
		.Display
    End With
    Set olApp = Nothing
    Set fso = Nothing
End Sub

Zum alternativen PDF-Export siehe den Kommentar von Dieter.

Grüße Uwe

Hallo Dieter, Hallo Uwe

Danke für eure Antworten.
Bin meinem Ziel ein Stück näher. Ich habe dank Dieters Hinweis einen Code gefunden mit dem ich den PDFCreator komplett steuern kann und er mir das gewünschte Ergebnis ausspuckt. Nun aber funktioniert der Part von Uwe leider nicht mehr. Ich versuchte diesen zu integrieren aber der will nicht so recht.
Bei Zeile 47 und 48 ersetzt er die Datei einfach durch die neue. Kennt Ihr den richtigen Befehl der anstelle von "Kill" kommt? Oder eine andere möglichkeit den Dateiname zu erweitern falls dieser schon existiert?

Hier mal mein aktueller Code (Quelle des Codes: http://www.excelguru.ca/content.php?161-Printing-Worksheets-To-A-PDF-Fi ..):

Public Sub TabelleAlsPdf()

Dim olApp      As Object
Dim fso        As Object
Dim s(1)       As String
Dim olOldBody  As String
Dim strAddress As String
Dim i          As Integer
Dim sPDFName   As String
Dim sPDFPath   As String
Dim bRestart   As Boolean
Dim pdfjob     As PDFCreator.clsPDFCreator

    'Filesystem-Object erzeugen  
    Set fso = CreateObject("Scripting.FileSystemObject")  

    ' Bestimmen der E-Mailadresse  
    strAddress = Range("O19")  

    '/// Change the output file name here! ///  
    sPDFName = "AB " & Range("M25") & " " & Range("E14") & ".pdf"  
    sPDFPath = "H:\XXX\YYY\"  

    'Check if PDFCreator is already running and attempt to kill the process if so  
    Do
        bRestart = False
        Set pdfjob = New PDFCreator.clsPDFCreator
        If pdfjob.cStart("/NoProcessingAtStartup") = False Then  
            'PDF Creator is already running.  Kill the existing process  
            Shell "taskkill /f /im PDFCreator.exe", vbHide  
            DoEvents
            Set pdfjob = Nothing
            bRestart = True
        End If
    Loop Until bRestart = False

    'Assign settings for PDF job  
    With pdfjob
        .cOption("UseAutosave") = 1  
        .cOption("UseAutosaveDirectory") = 1  
        .cOption("AutosaveDirectory") = sPDFPath  
        .cOption("AutosaveFilename") = sPDFName  
        .cOption("AutosaveFormat") = 0    ' 0 = PDF  
        .cClearCache
    End With

    'Delete the PDF if it already exists  
    If Dir(sPDFPath & sPDFName) = sPDFName Then Kill (sPDFPath & sPDFName)
    
    'Print the document to PDF  
    ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"  

    'Wait until the print job has entered the print queue  
    Do Until pdfjob.cCountOfPrintjobs = 1
        DoEvents
    Loop
    pdfjob.cPrinterStop = False

    'Wait until the file shows up before closing PDF Creator  
    Do
        DoEvents
    Loop Until Dir(sPDFPath & sPDFName) = sPDFName

Cleanup:
    'Release objects and terminate PDFCreator  
    Set pdfjob = Nothing
    Shell "taskkill /f /im PDFCreator.exe", vbHide  
    On Error GoTo 0
    Application.ScreenUpdating = True

Rem Email erstellen
Set olApp = CreateObject("Outlook.Application")  
    With olApp.CreateItem(0)
        Set .SendUsingAccount = .Session.Accounts.Item("XXX@XXX.ch") ' Sendekonto vorwählen (für jede Emailadresse eine _  
                                                                        eigene Datendatei erforderlich). _
                                                                        "Kontoname" = Name des Kontos (in Anführungszeichen) _  
                                                                        wie er in Outlook angezeigt wird.
              .GetInspector.Display
              olOldBody = .htmlBody
              .To = strAddress
              .Subject = "Auftragsbestätigung " & Range("M25") & " - " & Range("J28")  ' Betreff  
              .htmlBody = "<span style=""font-size:11pt; font-family:'calibri'"">" & _  
                          "Sehr geehrte Damen und Herren<br><br>" & _  
                          "Herzlichen Dank für Ihre Bestellung.<br>" & _  
                          "Im Anhang finden Sie die entsprechende Auftragsbestätigung.<br><br>" & _  
                          "Wir bitten Sie die Auftragsbestätigung zu kontrollieren. Ohne Gegenbericht innert 5 Tagen gilt der Auftrag als genehmigt." & olOldBody ' Body. "<br>" = Zeilenumbruchanweisung  
              .Attachments.Add (sPDFPath & sPDFName) 'Datei anhängen  
              .Display
    End With
    Set olApp = Nothing
    Set fso = Nothing
End Sub

Gruss Aeschli

Hallo Aeschli!

So sollte es funktionieren:

Public Sub PrintToPdfCreater()
    Dim oPdf_Creater As Object, sPdf_Path As String, sPdf_Name As String

    sPdf_Path = "H:\XXX\YYY\"  
    sPdf_Name = "AB " & Range("M25") & " " & Range("E14")  'ohne ".pdf"  

    Set oPdf_Creater = CreateObject("PDFCreator.clsPDFCreator")  

    If oPdf_Creater.cStart("/NoProcessingAtStartup") = False Then  
        MsgBox "Initialisierung von PDFCreator fehlgeschlagen!", vbExclamation, "Fehler"  
        Exit Sub
    End If

    With oPdf_Creater
        .cOption("UseAutosave") = 1  
        .cOption("UseAutosaveDirectory") = 1  
        .cOption("AutosaveDirectory") = sPdf_Path  
        .cOption("AutosaveFilename") = sPdf_Name  
        .cOption("AutosaveFormat") = 0  
        .cClearCache
    End With

    ThisWorkbook.Sheets("AB TL").PrintOut Copies:=1, "PDFCreator auf Ne04:"   'Genaue Bezeichnung ermitteln  
 
    With oPdf_Creater
        Do Until .cCountOfPrintjobs = 1:  Loop
       .cCombineAll
       .cPrinterStop = False
        Do Until .cCountOfPrintjobs = 0:  Loop
       .cClose
    End With

    Set oPdf_Creater = Nothing

    sPdf_Path = sPdf_Path & sPdf_Name & ".pdf"  
    
    'Ab hier Uwe's Outlook-Code  

End Sub

Grüße Dieter

Hi Dieter

Danke für den Code. Leider hängt er in einem Loop fest, welcher verursacht das der PDFCreator immer wieder gestartet wird, nachdem ich ihn manuell geschlossen habe. Dazu kommt das der Papier drucker sich auch noch meldet und das Worksheet ausdruckt - Sorry, leider tut es nicht das was es soll!
Was ich aber in deinem Code nicht sehe, wo genau prüft er den Dateiname und hängt dann nach bedarf automatisch ein Zahl oder ähnliches an?

Gruss Aeschli

Hallo Aeschli!

Ich vermute mal, dass der Druckauftrag nicht an den Pdf-Creater gesendet wird. Sie mal unter <Geräte und Drucker>, ob der Pdf-Creater dort auch als "PdfCreater" drinnen steht?

Grüße Dieter

PS.

Was ich aber in deinem Code nicht sehe, wo genau prüft er den Dateiname und hängt dann nach bedarf automatisch ein Zahl oder ähnliches an?

Wenn vorhanden, dann wird die Datei einfach überschrieben...

"PDFCreator" steht bei mir und <Geräte und Drucker>! Das sollte also stimmen...
Bei meinem Kommentar von Heute 10.24 Uhr, steht der Code bei dem alles einwandfrei funktioniert, bis auf die Dateinamens änderung. Ich hab einfach noch keinen Code gefunden der das Problem löst -.-'

PS.

Was ich aber in deinem Code nicht sehe, wo genau prüft er den Dateiname und hängt dann nach bedarf automatisch ein Zahl oder ähnliches an?

Wenn vorhanden, dann wird die Datei einfach überschrieben...face-wink

Es geht mir ja genau darum, dass wenn die Datei schon vorhanden ist, der Name am schluss mit einem "Version 2" versehen wird. Damit die alte Datei nicht überschrieben wird!

Zitat von @Aeschli:
Es geht mir ja genau darum, dass wenn die Datei schon vorhanden ist, der Name am schluss mit einem "Version 2" versehen
wird. Damit die alte Datei nicht überschrieben wird!

das macht mein Code aber bereits zuverlässig mit den folgenden Zeilen aus meinem obigen Code!!

      'Filesystem-Object erzeugen  
	Set fso = CreateObject("Scripting.FileSystemObject")    
	
	' Rem Pfad für PDF festlegen  
	AWS = "H:\XXX\YYY\AB " & Range("M25") & " " & Range("E14") & ".pdf"  
	
	'Falls Datei schon existiert, hänge Nummer an  
	cnt = 1
	While fso.FileExists(AWS)
		AWS = fso.GetParentFolderName(AWS) & "\" & fso.GetBaseName(AWS) & "(" & cnt & ")." & fso.GetExtensionName(AWS)  
		cnt = cnt + 1
	Wend

sollte der Pfad schon existieren ändert es die Zahl hinten dran solange bis der Dateipfad nicht existiert und somit frei ist ... geht einwandfrei, ich poste hier ja keine Sachen die in nicht getestet hätte

Hallo zusammen!

OK, dass hab ich dann komplett übersehen und nur den Druckvorgang berücksichtigt

, der bei mir auch einwandfrei funktioniert...

Grüße Dieter

Zitat von @colinardo:

> Zitat von @Aeschli:
> Es geht mir ja genau darum, dass wenn die Datei schon vorhanden ist, der Name am schluss mit einem "Version 2"
versehen
> wird. Damit die alte Datei nicht überschrieben wird!
das macht mein Code aber bereits zuverlässig mit den folgenden Zeilen aus meinem obigen Code!!

>       'Filesystem-Object erzeugen  
> 	Set fso = CreateObject("Scripting.FileSystemObject")    
> 	
> 	' Rem Pfad für PDF festlegen  
> 	AWS = "H:\XXX\YYY\AB " & Range("M25") & " " & Range("E14") &  
> ".pdf"  
> 	
> 	'Falls Datei schon existiert, hänge Nummer an  
> 	cnt = 1
> 	While fso.FileExists(AWS)
> 		AWS = fso.GetParentFolderName(AWS) & "\" & fso.GetBaseName(AWS) & "(" & cnt &  
> ")." & fso.GetExtensionName(AWS)  
> 		cnt = cnt + 1
> 	Wend
> 

sollte der Pfad schon existieren ändert es die Zahl hinten dran solange bis der Dateipfad nicht existiert und somit frei ist
... geht einwandfrei, ich poste hier ja keine Sachen die in nicht getestet hätte

Geb ich dir recht... Passt alles wunderbar. Aber leider nur mit dem alten Code! Da ich gestern den Code geändert habe um den PDFCreator anzusteuer und zu managen, will deine Variante nicht mehr so richtig. Mein aktueller Code findest du in meinem Kommentar von heute morgen 10.34 Uhr.
Hast du eine Idee wie ich diesen integrieren kann?

Hast du eine Idee wie ich diesen integrieren kann?

bin noch unterwegs, schaue da heut Abend mal drauf... oder der Dieter vertritt mich

Zitat von @colinardo:

> Hast du eine Idee wie ich diesen integrieren kann?
bin noch unterwegs, schaue da heut Abend mal drauf... oder der Dieter vertritt mich

Super! Vielen dank... Hab leider nacher weiteren Google-Aktivitäten immer noch nicht die passende Lösung!

Hallo Aeschli!

So, habe jetzt mal mit Win7 und Excel 2013 getestet und festgestellt, dass 'ActivePrinter' in PrintOut etwas anders funktioniert. Hier muss die vollständige Bezeichnung angegeben werden z.B. "PDFCreator auf Ne04:" (Code oben entsprechend geändert):

 ThisWorkbook.Sheets("AB TL").PrintOut Copies:=1, ActivePrinter = "PDFCreator auf Ne04:"  

Wobei Du aber die genaue Printerbezeichnung vom PdfCreater ermitteln musst, indem Du erstmal den PdfCreater als Excel-Default auswählst und dann mit 'Printer = Application.ActivePrinter' die vollständige Bezeichnung ausliest.

Schreibe eine kleine Test-Sub zum Auslesen der Printerbezeichnung.

Wenn die Printerbezeichnung stimmt, dann erübrigen sich die Taskkills vom Pdf-Creater, weil er dann ordnungsgemäß geöffnet und geschlossen wird...

Uwe's Outlook-Funktion sollte dann auch gehen?

Grüße Dieter

Alles was Excel/Outlook 2013 betriff erst nächste Woche testen, da ich die betreffende Maschine nicht habe zurzeit. Werde dann aber gern deinem Rat folgen.

Möchte aber bei Möglichkeit das Problem mit dem Dateiname bis dahin hingekriegt haben. Ich möchte dann 2013 testen, wenn der Code auf 2010 fertig ist. Sonst hab ich 2 Baustellen....

Hallo zusammen!

bin noch unterwegs, schaue da heut Abend mal drauf... oder der Dieter vertritt mich

OK, ich versuchs mal

Mit Dateiüberprüfung und gegebenenfalls eine fortlaufende Zahl anhängen:

Option Explicit

Public Sub SendPdfMail()
    Dim oFso As Object, oPdf_Creater As Object, olApp As Object
    Dim sPdf_Path As String, sPdf_Name As String, sFileName As String, olOldBody As String
    Dim sDefaultPrinter As String, iCount As Integer
    
    Set oPdf_Creater = CreateObject("PDFCreator.clsPDFCreator")  
    
    If oPdf_Creater.cStart("/NoProcessingAtStartup") = False Then  
        Set oPdf_Creater = Nothing
        MsgBox "Initialisierung von PDFCreator fehlgeschlagen!", vbExclamation, "Fehler"  
        Exit Sub
    End If

    sDefaultPrinter = Application.ActivePrinter
    
    If SetPdfPrinter = False Then
        Set oPdf_Creater = Nothing
        MsgBox "PDFCreator nicht gefunden!", vbExclamation, "Fehler"  
        Exit Sub
    End If
    
    sPdf_Path = "H:\XXX\YYY\"  
    sPdf_Name = "AB " & Range("M25").Value & " " & Range("E14").Value  
    
    With CreateObject("Scripting.FileSystemObject")  
        sFileName = sPdf_Path & sPdf_Name & ".pdf"  
        
        While .FileExists(sFileName)
            iCount = iCount + 1
            sFileName = sPdf_Path & sPdf_Name & "_" & iCount & ".pdf"  
        Wend
        sPdf_Name = .GetBaseName(sFileName)
    End With
    
    With oPdf_Creater
        .cOption("UseAutosave") = 1  
        .cOption("UseAutosaveDirectory") = 1  
        .cOption("AutosaveDirectory") = sPdf_Path  
        .cOption("AutosaveFilename") = sPdf_Name  
        .cOption("AutosaveFormat") = 0  
        .cClearCache
    End With

    ActiveSheet.PrintOut Copies:=1
    Application.ActivePrinter = sDefaultPrinter

    With oPdf_Creater
        Do Until .cCountOfPrintjobs = 1:  Loop
       .cCombineAll
       .cPrinterStop = False
        Do Until .cCountOfPrintjobs = 0:  Loop
       .cClose
    End With

    Set oPdf_Creater = Nothing
    Set olApp = CreateObject("Outlook.Application")  

    With olApp.CreateItem(0)
        Set .SendUsingAccount = .Session.Accounts.Item("info@moebelagentur.ch") ' Sendekonto vorwählen  
        olOldBody = .htmlBody
        .To = Range("O19").Value  
        .Subject = "Auftragsbestätigung " & Range("M25") & " - " & Range("J28")  ' Betreff  
        .htmlBody = "<span style=""font-size:11pt; font-family:'calibri'"">" & _  
                  "Sehr geehrte Damen und Herren<br><br>" & _  
                  "Herzlichen Dank für Ihre Bestellung.<br>" & _  
                  "Im Anhang finden Sie die entsprechende Auftragsbestätigung.<br><br>" & _  
                  "Wir bitten Sie die Auftragsbestätigung zu kontrollieren. Ohne Gegenbericht " & ´_  
                  "innerhalb von 5 Tagen gilt der Auftrag als genehmigt." & olOldBody  
                  'Body. "<br>" = Zeilenumbruchanweisung  
        .Attachments.Add sFileName
        .Display
    End With
    Set olApp = Nothing
End Sub

Private Function SetPdfPrinter() As Boolean
    Dim sPrinter As String, i As Integer
    
    On Error Resume Next
    With Application
        For i = 0 To 9
            sPrinter = "PDFCreator auf Ne0" & i & ":"  
           .ActivePrinter = sPrinter
            If .ActivePrinter = sPrinter Then
                SetPdfPrinter = True:  Exit For
            End If
        Next
    End With
    On Error GoTo 0
End Function

Grüße Dieter

[edit] Code noch ein weing erweitert, sodass PdfCreater nun auch automatisch erkannt/gesetzt wird... [/edit]

Hallo Leute

Vielen Dank für den Code Dieter!
Habe morgen wieder Zeit diesen zu testen. Melde mich dann wieder....

Guten Wochenstart wünsch ich euch!

Gruss Aeschli

Zitat von @116301:

Hallo zusammen!

> bin noch unterwegs, schaue da heut Abend mal drauf... oder der Dieter vertritt mich

OK, ich versuchs mal

Mit Dateiüberprüfung und gegebenenfalls eine fortlaufende Zahl anhängen:

> Option Explicit
> 
> Public Sub SendPdfMail()
>     Dim oFso As Object, oPdf_Creater As Object, olApp As Object
>     Dim sPdf_Path As String, sPdf_Name As String, sFileName As String, olOldBody As String
>     Dim sDefaultPrinter As String, iCount As Integer
>     
>     Set oPdf_Creater = CreateObject("PDFCreator.clsPDFCreator")  
>     
>     If oPdf_Creater.cStart("/NoProcessingAtStartup") = False Then  
>         Set oPdf_Creater = Nothing
>         MsgBox "Initialisierung von PDFCreator fehlgeschlagen!", vbExclamation, "Fehler"  
>         Exit Sub
>     End If
> 
>     sDefaultPrinter = Application.ActivePrinter
>     
>     If SetPdfPrinter = False Then
>         Set oPdf_Creater = Nothing
>         MsgBox "PDFCreator nicht gefunden!", vbExclamation, "Fehler"  
>         Exit Sub
>     End If
>     
>     sPdf_Path = "H:\XXX\YYY\"  
>     sPdf_Name = "AB " & Range("M25").Value & " " & Range("E14").Value  
>     
>     With CreateObject("Scripting.FileSystemObject")  
>         sFileName = sPdf_Path & sPdf_Name & ".pdf"  
>         
>         While .FileExists(sFileName)
>             iCount = iCount + 1
>             sFileName = sPdf_Path & sPdf_Name & "_" & iCount & ".pdf"  
>         Wend
>         sPdf_Name = .GetBaseName(sFileName)
>     End With
>     
>     With oPdf_Creater
>         .cOption("UseAutosave") = 1  
>         .cOption("UseAutosaveDirectory") = 1  
>         .cOption("AutosaveDirectory") = sPdf_Path  
>         .cOption("AutosaveFilename") = sPdf_Name  
>         .cOption("AutosaveFormat") = 0  
>         .cClearCache
>     End With
> 
>     ActiveSheet.PrintOut Copies:=1
>     Application.ActivePrinter = sDefaultPrinter
> 
>     With oPdf_Creater
>         Do Until .cCountOfPrintjobs = 1:  Loop
>        .cCombineAll
>        .cPrinterStop = False
>         Do Until .cCountOfPrintjobs = 0:  Loop
>        .cClose
>     End With
> 
>     Set oPdf_Creater = Nothing
>     Set olApp = CreateObject("Outlook.Application")  
> 
>     With olApp.CreateItem(0)
>         Set .SendUsingAccount = .Session.Accounts.Item("info@moebelagentur.ch") ' Sendekonto vorwählen  
>         olOldBody = .htmlBody
>         .To = Range("O19").Value  
>         .Subject = "Auftragsbestätigung " & Range("M25") & " - " &  
> Range("J28")  ' Betreff  
>         .htmlBody = "<span style=""font-size:11pt; font-family:'calibri'"">" &  
> _
>                   "Sehr geehrte Damen und Herren<br><br>" & _  
>                   "Herzlichen Dank für Ihre Bestellung.<br>" & _  
>                   "Im Anhang finden Sie die entsprechende Auftragsbestätigung.<br><br>" & _  
>                   "Wir bitten Sie die Auftragsbestätigung zu kontrollieren. Ohne Gegenbericht " & ´_  
>                   "innerhalb von 5 Tagen gilt der Auftrag als genehmigt." & olOldBody  
>                   'Body. "<br>" = Zeilenumbruchanweisung  
>         .Attachments.Add sFileName
>         .Display
>     End With
>     Set olApp = Nothing
> End Sub
> 
> Private Function SetPdfPrinter() As Boolean
>     Dim sPrinter As String, i As Integer
>     
>     On Error Resume Next
>     With Application
>         For i = 0 To 9
>             sPrinter = "PDFCreator auf Ne0" & i & ":"  
>            .ActivePrinter = sPrinter
>             If .ActivePrinter = sPrinter Then
>                 SetPdfPrinter = True:  Exit For
>             End If
>         Next
>     End With
>     On Error GoTo 0
> End Function
> 

Grüße Dieter

[edit] Code noch ein weing erweitert, sodass PdfCreater nun auch automatisch erkannt/gesetzt wird... [/edit]

Geiler ###! Funktioniert tadellos *Freu* Danke euch viel mals.

Läuft also mit dem Code von Dieter (Alias: Eintagsfliege) nun auf 2010 sowie auf 2013!
Eine kleine Änderung auf Zeile 62. habe ich noch gemacht:
.GetInspector.Display 'Damit wird die standartisierte Signatur automatisch eingefügt

Nochmals vielen Dank!

German solved Question Microsoft Office Microsoft

Hotly discussed

How to set up and configure a Linux GRE tunnelAlexWisha - 3 Comments

End of Support dates for Office 2016, 2019 Apps und Productivity ServersDani - 1 Comment