Frage Microsoft Microsoft Office
gelöst Excel 2010 Makro Probleme mit komp. Excel 2013, Qualität von PDF und Dateinamen

23.10.2014, aktualisiert 28.10.2014, 1473 Aufrufe, 17 Kommentare

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 Sub01.
Public Sub TabelleAlsPdf() 
02.
 
03.
Dim olApp      As Object 
04.
Dim AWS        As String 
05.
Dim olOldBody  As String 
06.
Dim strAddress As String 
07.
Dim i          As Integer 
08.
 
09.
' Rem Pfad für PDF festlegen 
10.
AWS = "H:\XXX\YYY\AB " & Range("M25") & " " & Range("E14") & ".pdf" 
11.
 
12.
' Bestimmen der E-Mailadresse 
13.
strAddress = Range("O19") 
14.
 
15.
' Rem Tabelle2 als PDF speichern 
16.
If Dir(AWS) = "" Then 
17.
ThisWorkbook.Sheets("AB TL").ExportAsFixedFormat Type:=xlTypePDF, Filename:=AWS, Quality:=xlQualityStandard, _ 
18.
                                                    IncludeDocProperties:=False, IgnorePrintAreas:=False, _ 
19.
                                                    OpenAfterPublish:=False 
20.
Else 
21.
   MsgBox "Der verwendete Dateiname ist bereits vorhanden." 
22.
   Exit Sub 
23.
End If 
24.
 
25.
Rem Email erstellen 
26.
Set olApp = CreateObject("Outlook.Application") 
27.
    With olApp.CreateItem(0) 
28.
        Set .SendUsingAccount = .Session.Accounts.Item("info@moebelagentur.ch") ' Sendekonto vorwählen (für jede Emailadresse eine _ 
29.
                                                                        eigene Datendatei erforderlich). _ 
30.
                                                                        "Kontoname" = Name des Kontos (in Anführungszeichen) _ 
31.
                                                                        wie er in Outlook angezeigt wird. 
32.
              .GetInspector.Display 
33.
              olOldBody = .htmlBody 
34.
              .To = strAddress 
35.
              .Subject = "Auftragsbestätigung " & Range("M25") & " - " & Range("J28")  ' Betreff 
36.
              .htmlBody = "<span style=""font-size:11pt; font-family:'calibri'"">" & _ 
37.
                          "Sehr geehrte Damen und Herren<br><br>" & _ 
38.
                          "Herzlichen Dank für Ihre Bestellung.<br>" & _ 
39.
                          "Im Anhang finden Sie die entsprechende Auftragsbestätigung.<br><br>" & _ 
40.
                          "Wir bitten Sie die Auftragsbestätigung zu kontrollieren. Ohne Gegenbericht innert 5 Tagen gilt der Auftrag als genehmigt." & olOldBody ' Body. "<br>" = Zeilenumbruchanweisung 
41.
              .Attachments.Add AWS 'Datei anhängen 
42.
      
43.
    End With 
44.
 
45.
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

17 Antworten

LÖSUNG 116301 schreibt am 23.10.2014 um 13:12:38 Uhr
LÖSUNG colinardo schreibt am 23.10.2014 um 13:40:17 Uhr
- LÖSUNG Aeschli schreibt am 24.10.2014 um 10:34:02 Uhr
  - LÖSUNG 116301 schreibt am 24.10.2014 um 11:46:06 Uhr
    - LÖSUNG Aeschli schreibt am 24.10.2014 um 12:41:45 Uhr
      - LÖSUNG 116301 schreibt am 24.10.2014 um 12:53:34 Uhr
        
        LÖSUNG Aeschli schreibt am 24.10.2014 um 13:14:00 Uhr
        
        LÖSUNG colinardo schreibt am 24.10.2014 um 13:29:36 Uhr
        
        LÖSUNG 116301 schreibt am 24.10.2014 um 13:40:54 Uhr
        LÖSUNG Aeschli schreibt am 24.10.2014 um 13:55:41 Uhr
        
        LÖSUNG colinardo schreibt am 24.10.2014 um 14:10:42 Uhr
        
        LÖSUNG Aeschli schreibt am 24.10.2014 um 15:54:03 Uhr
        
        LÖSUNG 116301 schreibt am 24.10.2014 um 16:29:41 Uhr
        
        LÖSUNG Aeschli schreibt am 24.10.2014 um 16:48:15 Uhr
        
        LÖSUNG 116301 schreibt am 24.10.2014 um 17:56:57 Uhr
        
        LÖSUNG Aeschli schreibt am 27.10.2014 um 09:46:43 Uhr
        LÖSUNG Aeschli schreibt am 28.10.2014 um 17:42:09 Uhr

116301 (Level 1)

LÖSUNG 23.10.2014 um 13:12 Uhr

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"01.
ThisWorkbook.Sheets("AB TL").PrintOut , , 1, , "PDFCreater"

Grüße Dieter

colinardo (Level 5) - Jetzt verbinden

LÖSUNG 23.10.2014, aktualisiert um 14:01 Uhr

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 Sub01.
Public Sub TabelleAlsPdf() 
02.
	Dim olApp      	As Object 
03.
	Dim fso  	As Object 
04.
	Dim AWS        	As String 
05.
	Dim olOldBody  	As String 
06.
	Dim strAddress 	As String 
07.
	Dim i          	As Integer 
08.
        Dim cnt         As integer 
09.
	 
10.
        'Filesystem-Object erzeugen 
11.
	Set fso = CreateObject("Scripting.FileSystemObject")   
12.
	 
13.
	' Rem Pfad für PDF festlegen 
14.
	AWS = "H:\XXX\YYY\AB " & Range("M25") & " " & Range("E14") & ".pdf" 
15.
	 
16.
	'Falls Datei schon existiert, hänge Nummer an 
17.
	cnt = 1 
18.
	While fso.FileExists(AWS) 
19.
		AWS = fso.GetParentFolderName(AWS) & "\" & fso.GetBaseName(AWS) & "(" & cnt & ")." & fso.GetExtensionName(AWS) 
20.
		cnt = cnt + 1 
21.
	Wend 
22.
	 
23.
	' Bestimmen der E-Mailadresse 
24.
	strAddress = Range("O19").Value 
25.
	 
26.
	' Rem Tabelle2 als PDF speichern 
27.
	ThisWorkbook.Sheets("AB TL").ExportAsFixedFormat Type:=xlTypePDF, Filename:=AWS, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False 
28.
 
29.
'Email erstellen 
30.
	Set olApp = CreateObject("Outlook.Application") 
31.
	With olApp.CreateItem(0) 
32.
        Set .SendUsingAccount = .Session.Accounts.Item("info@moebelagentur.ch") ' Sendekonto vorwählen 
33.
		olOldBody = .htmlBody 
34.
		.To = strAddress 
35.
		.Subject = "Auftragsbestätigung " & Range("M25") & " - " & Range("J28")  ' Betreff 
36.
		.htmlBody = "<span style=""font-size:11pt; font-family:'calibri'"">" & _ 
37.
		          "Sehr geehrte Damen und Herren<br><br>" & _ 
38.
		          "Herzlichen Dank für Ihre Bestellung.<br>" & _ 
39.
		          "Im Anhang finden Sie die entsprechende Auftragsbestätigung.<br><br>" & _ 
40.
		          "Wir bitten Sie die Auftragsbestätigung zu kontrollieren. Ohne Gegenbericht innert 5 Tagen gilt der Auftrag als genehmigt." & olOldBody ' Body. "<br>" = Zeilenumbruchanweisung 
41.
		.Attachments.Add AWS 'Datei anhängen 
42.
		.Display 
43.
    End With 
44.
    Set olApp = Nothing 
45.
    Set fso = Nothing 
46.
End Sub

Zum alternativen PDF-Export siehe den Kommentar von Dieter.

Grüße Uwe

Aeschli (Level 1) - Jetzt verbinden

LÖSUNG 24.10.2014 um 10:34 Uhr

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
01.
Public Sub TabelleAlsPdf() 
02.
 
03.
Dim olApp      As Object 
04.
Dim fso        As Object 
05.
Dim s(1)       As String 
06.
Dim olOldBody  As String 
07.
Dim strAddress As String 
08.
Dim i          As Integer 
09.
Dim sPDFName   As String 
10.
Dim sPDFPath   As String 
11.
Dim bRestart   As Boolean 
12.
Dim pdfjob     As PDFCreator.clsPDFCreator 
13.
 
14.
    'Filesystem-Object erzeugen 
15.
    Set fso = CreateObject("Scripting.FileSystemObject") 
16.
 
17.
    ' Bestimmen der E-Mailadresse 
18.
    strAddress = Range("O19") 
19.
 
20.
    '/// Change the output file name here! /// 
21.
    sPDFName = "AB " & Range("M25") & " " & Range("E14") & ".pdf" 
22.
    sPDFPath = "H:\XXX\YYY\" 
23.
 
24.
    'Check if PDFCreator is already running and attempt to kill the process if so 
25.
    Do 
26.
        bRestart = False 
27.
        Set pdfjob = New PDFCreator.clsPDFCreator 
28.
        If pdfjob.cStart("/NoProcessingAtStartup") = False Then 
29.
            'PDF Creator is already running.  Kill the existing process 
30.
            Shell "taskkill /f /im PDFCreator.exe", vbHide 
31.
            DoEvents 
32.
            Set pdfjob = Nothing 
33.
            bRestart = True 
34.
        End If 
35.
    Loop Until bRestart = False 
36.
 
37.
    'Assign settings for PDF job 
38.
    With pdfjob 
39.
        .cOption("UseAutosave") = 1 
40.
        .cOption("UseAutosaveDirectory") = 1 
41.
        .cOption("AutosaveDirectory") = sPDFPath 
42.
        .cOption("AutosaveFilename") = sPDFName 
43.
        .cOption("AutosaveFormat") = 0    ' 0 = PDF 
44.
        .cClearCache 
45.
    End With 
46.
 
47.
    'Delete the PDF if it already exists 
48.
    If Dir(sPDFPath & sPDFName) = sPDFName Then Kill (sPDFPath & sPDFName) 
49.
     
50.
    'Print the document to PDF 
51.
    ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator" 
52.
 
53.
    'Wait until the print job has entered the print queue 
54.
    Do Until pdfjob.cCountOfPrintjobs = 1 
55.
        DoEvents 
56.
    Loop 
57.
    pdfjob.cPrinterStop = False 
58.
 
59.
    'Wait until the file shows up before closing PDF Creator 
60.
    Do 
61.
        DoEvents 
62.
    Loop Until Dir(sPDFPath & sPDFName) = sPDFName 
63.
 
64.
Cleanup: 
65.
    'Release objects and terminate PDFCreator 
66.
    Set pdfjob = Nothing 
67.
    Shell "taskkill /f /im PDFCreator.exe", vbHide 
68.
    On Error GoTo 0 
69.
    Application.ScreenUpdating = True 
70.
 
71.
Rem Email erstellen 
72.
Set olApp = CreateObject("Outlook.Application") 
73.
    With olApp.CreateItem(0) 
74.
        Set .SendUsingAccount = .Session.Accounts.Item("XXX@XXX.ch") ' Sendekonto vorwählen (für jede Emailadresse eine _ 
75.
                                                                        eigene Datendatei erforderlich). _ 
76.
                                                                        "Kontoname" = Name des Kontos (in Anführungszeichen) _ 
77.
                                                                        wie er in Outlook angezeigt wird. 
78.
              .GetInspector.Display 
79.
              olOldBody = .htmlBody 
80.
              .To = strAddress 
81.
              .Subject = "Auftragsbestätigung " & Range("M25") & " - " & Range("J28")  ' Betreff 
82.
              .htmlBody = "<span style=""font-size:11pt; font-family:'calibri'"">" & _ 
83.
                          "Sehr geehrte Damen und Herren<br><br>" & _ 
84.
                          "Herzlichen Dank für Ihre Bestellung.<br>" & _ 
85.
                          "Im Anhang finden Sie die entsprechende Auftragsbestätigung.<br><br>" & _ 
86.
                          "Wir bitten Sie die Auftragsbestätigung zu kontrollieren. Ohne Gegenbericht innert 5 Tagen gilt der Auftrag als genehmigt." & olOldBody ' Body. "<br>" = Zeilenumbruchanweisung 
87.
              .Attachments.Add (sPDFPath & sPDFName) 'Datei anhängen 
88.
              .Display 
89.
    End With 
90.
    Set olApp = Nothing 
91.
    Set fso = Nothing 
92.
End Sub 
93.
 

Gruss Aeschli

116301 (Level 1)

LÖSUNG 24.10.2014, aktualisiert um 16:56 Uhr

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 Sub01.
Public Sub PrintToPdfCreater() 
02.
    Dim oPdf_Creater As Object, sPdf_Path As String, sPdf_Name As String 
03.
 
04.
    sPdf_Path = "H:\XXX\YYY\" 
05.
    sPdf_Name = "AB " & Range("M25") & " " & Range("E14")  'ohne ".pdf" 
06.
 
07.
    Set oPdf_Creater = CreateObject("PDFCreator.clsPDFCreator") 
08.
 
09.
    If oPdf_Creater.cStart("/NoProcessingAtStartup") = False Then 
10.
        MsgBox "Initialisierung von PDFCreator fehlgeschlagen!", vbExclamation, "Fehler" 
11.
        Exit Sub 
12.
    End If 
13.
 
14.
    With oPdf_Creater 
15.
        .cOption("UseAutosave") = 1 
16.
        .cOption("UseAutosaveDirectory") = 1 
17.
        .cOption("AutosaveDirectory") = sPdf_Path 
18.
        .cOption("AutosaveFilename") = sPdf_Name 
19.
        .cOption("AutosaveFormat") = 0 
20.
        .cClearCache 
21.
    End With 
22.
 
23.
    ThisWorkbook.Sheets("AB TL").PrintOut Copies:=1, "PDFCreator auf Ne04:"   'Genaue Bezeichnung ermitteln 
24.
  
25.
    With oPdf_Creater 
26.
        Do Until .cCountOfPrintjobs = 1:  Loop 
27.
       .cCombineAll 
28.
       .cPrinterStop = False 
29.
        Do Until .cCountOfPrintjobs = 0:  Loop 
30.
       .cClose 
31.
    End With 
32.
 
33.
    Set oPdf_Creater = Nothing 
34.
 
35.
    sPdf_Path = sPdf_Path & sPdf_Name & ".pdf" 
36.
     
37.
    'Ab hier Uwe's Outlook-Code 
38.
 
39.
End Sub

Grüße Dieter

Aeschli (Level 1) - Jetzt verbinden

LÖSUNG 24.10.2014 um 12:41 Uhr

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

116301 (Level 1)

LÖSUNG 24.10.2014, aktualisiert um 13:09 Uhr

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...

Aeschli (Level 1) - Jetzt verbinden

LÖSUNG 24.10.2014, aktualisiert um 13:17 Uhr

"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!

colinardo (Level 5) - Jetzt verbinden

LÖSUNG 24.10.2014, aktualisiert um 13:42 Uhr

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
	Wend01.
      'Filesystem-Object erzeugen 
02.
	Set fso = CreateObject("Scripting.FileSystemObject")   
03.
	 
04.
	' Rem Pfad für PDF festlegen 
05.
	AWS = "H:\XXX\YYY\AB " & Range("M25") & " " & Range("E14") & ".pdf" 
06.
	 
07.
	'Falls Datei schon existiert, hänge Nummer an 
08.
	cnt = 1 
09.
	While fso.FileExists(AWS) 
10.
		AWS = fso.GetParentFolderName(AWS) & "\" & fso.GetBaseName(AWS) & "(" & cnt & ")." & fso.GetExtensionName(AWS) 
11.
		cnt = cnt + 1 
12.
	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 !

116301 (Level 1)

LÖSUNG 24.10.2014, aktualisiert um 13:42 Uhr

Hallo zusammen!

OK, dass hab ich dann komplett übersehen und nur den Druckvorgang berücksichtigt, der bei mir auch einwandfrei funktioniert...

Grüße Dieter

Aeschli (Level 1) - Jetzt verbinden

LÖSUNG 24.10.2014 um 13:55 Uhr

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
> 01.
>       'Filesystem-Object erzeugen 
02.
> 	Set fso = CreateObject("Scripting.FileSystemObject")   
03.
> 	 
04.
> 	' Rem Pfad für PDF festlegen 
05.
> 	AWS = "H:\XXX\YYY\AB " & Range("M25") & " " & Range("E14") & 
06.
> ".pdf" 
07.
> 	 
08.
> 	'Falls Datei schon existiert, hänge Nummer an 
09.
> 	cnt = 1 
10.
> 	While fso.FileExists(AWS) 
11.
> 		AWS = fso.GetParentFolderName(AWS) & "\" & fso.GetBaseName(AWS) & "(" & cnt & 
12.
> ")." & fso.GetExtensionName(AWS) 
13.
> 		cnt = cnt + 1 
14.
> 	Wend 
15.
> 

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?

colinardo (Level 5) - Jetzt verbinden

LÖSUNG 24.10.2014, aktualisiert um 14:11 Uhr

Hast du eine Idee wie ich diesen integrieren kann?

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

Aeschli (Level 1) - Jetzt verbinden

LÖSUNG 24.10.2014 um 15:54 Uhr

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!

116301 (Level 1)

LÖSUNG 24.10.2014, aktualisiert um 16:43 Uhr

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:"01.
 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

Aeschli (Level 1) - Jetzt verbinden

LÖSUNG 24.10.2014 um 16:48 Uhr

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....

116301 (Level 1)

LÖSUNG 24.10.2014, aktualisiert 28.10.2014

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 Function01.
Option Explicit 
02.
 
03.
Public Sub SendPdfMail() 
04.
    Dim oFso As Object, oPdf_Creater As Object, olApp As Object 
05.
    Dim sPdf_Path As String, sPdf_Name As String, sFileName As String, olOldBody As String 
06.
    Dim sDefaultPrinter As String, iCount As Integer 
07.
     
08.
    Set oPdf_Creater = CreateObject("PDFCreator.clsPDFCreator") 
09.
     
10.
    If oPdf_Creater.cStart("/NoProcessingAtStartup") = False Then 
11.
        Set oPdf_Creater = Nothing 
12.
        MsgBox "Initialisierung von PDFCreator fehlgeschlagen!", vbExclamation, "Fehler" 
13.
        Exit Sub 
14.
    End If 
15.
 
16.
    sDefaultPrinter = Application.ActivePrinter 
17.
     
18.
    If SetPdfPrinter = False Then 
19.
        Set oPdf_Creater = Nothing 
20.
        MsgBox "PDFCreator nicht gefunden!", vbExclamation, "Fehler" 
21.
        Exit Sub 
22.
    End If 
23.
     
24.
    sPdf_Path = "H:\XXX\YYY\" 
25.
    sPdf_Name = "AB " & Range("M25").Value & " " & Range("E14").Value 
26.
     
27.
    With CreateObject("Scripting.FileSystemObject") 
28.
        sFileName = sPdf_Path & sPdf_Name & ".pdf" 
29.
         
30.
        While .FileExists(sFileName) 
31.
            iCount = iCount + 1 
32.
            sFileName = sPdf_Path & sPdf_Name & "_" & iCount & ".pdf" 
33.
        Wend 
34.
        sPdf_Name = .GetBaseName(sFileName) 
35.
    End With 
36.
     
37.
    With oPdf_Creater 
38.
        .cOption("UseAutosave") = 1 
39.
        .cOption("UseAutosaveDirectory") = 1 
40.
        .cOption("AutosaveDirectory") = sPdf_Path 
41.
        .cOption("AutosaveFilename") = sPdf_Name 
42.
        .cOption("AutosaveFormat") = 0 
43.
        .cClearCache 
44.
    End With 
45.
 
46.
    ActiveSheet.PrintOut Copies:=1 
47.
    Application.ActivePrinter = sDefaultPrinter 
48.
 
49.
    With oPdf_Creater 
50.
        Do Until .cCountOfPrintjobs = 1:  Loop 
51.
       .cCombineAll 
52.
       .cPrinterStop = False 
53.
        Do Until .cCountOfPrintjobs = 0:  Loop 
54.
       .cClose 
55.
    End With 
56.
 
57.
    Set oPdf_Creater = Nothing 
58.
    Set olApp = CreateObject("Outlook.Application") 
59.
 
60.
    With olApp.CreateItem(0) 
61.
        Set .SendUsingAccount = .Session.Accounts.Item("info@moebelagentur.ch") ' Sendekonto vorwählen 
62.
        olOldBody = .htmlBody 
63.
        .To = Range("O19").Value 
64.
        .Subject = "Auftragsbestätigung " & Range("M25") & " - " & Range("J28")  ' Betreff 
65.
        .htmlBody = "<span style=""font-size:11pt; font-family:'calibri'"">" & _ 
66.
                  "Sehr geehrte Damen und Herren<br><br>" & _ 
67.
                  "Herzlichen Dank für Ihre Bestellung.<br>" & _ 
68.
                  "Im Anhang finden Sie die entsprechende Auftragsbestätigung.<br><br>" & _ 
69.
                  "Wir bitten Sie die Auftragsbestätigung zu kontrollieren. Ohne Gegenbericht " & ´_ 
70.
                  "innerhalb von 5 Tagen gilt der Auftrag als genehmigt." & olOldBody 
71.
                  'Body. "<br>" = Zeilenumbruchanweisung 
72.
        .Attachments.Add sFileName 
73.
        .Display 
74.
    End With 
75.
    Set olApp = Nothing 
76.
End Sub 
77.
 
78.
Private Function SetPdfPrinter() As Boolean 
79.
    Dim sPrinter As String, i As Integer 
80.
     
81.
    On Error Resume Next 
82.
    With Application 
83.
        For i = 0 To 9 
84.
            sPrinter = "PDFCreator auf Ne0" & i & ":" 
85.
           .ActivePrinter = sPrinter 
86.
            If .ActivePrinter = sPrinter Then 
87.
                SetPdfPrinter = True:  Exit For 
88.
            End If 
89.
        Next 
90.
    End With 
91.
    On Error GoTo 0 
92.
End Function

Grüße Dieter

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

Aeschli (Level 1) - Jetzt verbinden

LÖSUNG 27.10.2014 um 09:46 Uhr

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

Aeschli (Level 1) - Jetzt verbinden

LÖSUNG 28.10.2014 um 17:42 Uhr

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
> 01.
> Option Explicit 
02.
>  
03.
> Public Sub SendPdfMail() 
04.
>     Dim oFso As Object, oPdf_Creater As Object, olApp As Object 
05.
>     Dim sPdf_Path As String, sPdf_Name As String, sFileName As String, olOldBody As String 
06.
>     Dim sDefaultPrinter As String, iCount As Integer 
07.
>      
08.
>     Set oPdf_Creater = CreateObject("PDFCreator.clsPDFCreator") 
09.
>      
10.
>     If oPdf_Creater.cStart("/NoProcessingAtStartup") = False Then 
11.
>         Set oPdf_Creater = Nothing 
12.
>         MsgBox "Initialisierung von PDFCreator fehlgeschlagen!", vbExclamation, "Fehler" 
13.
>         Exit Sub 
14.
>     End If 
15.
>  
16.
>     sDefaultPrinter = Application.ActivePrinter 
17.
>      
18.
>     If SetPdfPrinter = False Then 
19.
>         Set oPdf_Creater = Nothing 
20.
>         MsgBox "PDFCreator nicht gefunden!", vbExclamation, "Fehler" 
21.
>         Exit Sub 
22.
>     End If 
23.
>      
24.
>     sPdf_Path = "H:\XXX\YYY\" 
25.
>     sPdf_Name = "AB " & Range("M25").Value & " " & Range("E14").Value 
26.
>      
27.
>     With CreateObject("Scripting.FileSystemObject") 
28.
>         sFileName = sPdf_Path & sPdf_Name & ".pdf" 
29.
>          
30.
>         While .FileExists(sFileName) 
31.
>             iCount = iCount + 1 
32.
>             sFileName = sPdf_Path & sPdf_Name & "_" & iCount & ".pdf" 
33.
>         Wend 
34.
>         sPdf_Name = .GetBaseName(sFileName) 
35.
>     End With 
36.
>      
37.
>     With oPdf_Creater 
38.
>         .cOption("UseAutosave") = 1 
39.
>         .cOption("UseAutosaveDirectory") = 1 
40.
>         .cOption("AutosaveDirectory") = sPdf_Path 
41.
>         .cOption("AutosaveFilename") = sPdf_Name 
42.
>         .cOption("AutosaveFormat") = 0 
43.
>         .cClearCache 
44.
>     End With 
45.
>  
46.
>     ActiveSheet.PrintOut Copies:=1 
47.
>     Application.ActivePrinter = sDefaultPrinter 
48.
>  
49.
>     With oPdf_Creater 
50.
>         Do Until .cCountOfPrintjobs = 1:  Loop 
51.
>        .cCombineAll 
52.
>        .cPrinterStop = False 
53.
>         Do Until .cCountOfPrintjobs = 0:  Loop 
54.
>        .cClose 
55.
>     End With 
56.
>  
57.
>     Set oPdf_Creater = Nothing 
58.
>     Set olApp = CreateObject("Outlook.Application") 
59.
>  
60.
>     With olApp.CreateItem(0) 
61.
>         Set .SendUsingAccount = .Session.Accounts.Item("info@moebelagentur.ch") ' Sendekonto vorwählen 
62.
>         olOldBody = .htmlBody 
63.
>         .To = Range("O19").Value 
64.
>         .Subject = "Auftragsbestätigung " & Range("M25") & " - " & 
65.
> Range("J28")  ' Betreff 
66.
>         .htmlBody = "<span style=""font-size:11pt; font-family:'calibri'"">" & 
67.
> _ 
68.
>                   "Sehr geehrte Damen und Herren<br><br>" & _ 
69.
>                   "Herzlichen Dank für Ihre Bestellung.<br>" & _ 
70.
>                   "Im Anhang finden Sie die entsprechende Auftragsbestätigung.<br><br>" & _ 
71.
>                   "Wir bitten Sie die Auftragsbestätigung zu kontrollieren. Ohne Gegenbericht " & ´_ 
72.
>                   "innerhalb von 5 Tagen gilt der Auftrag als genehmigt." & olOldBody 
73.
>                   'Body. "<br>" = Zeilenumbruchanweisung 
74.
>         .Attachments.Add sFileName 
75.
>         .Display 
76.
>     End With 
77.
>     Set olApp = Nothing 
78.
> End Sub 
79.
>  
80.
> Private Function SetPdfPrinter() As Boolean 
81.
>     Dim sPrinter As String, i As Integer 
82.
>      
83.
>     On Error Resume Next 
84.
>     With Application 
85.
>         For i = 0 To 9 
86.
>             sPrinter = "PDFCreator auf Ne0" & i & ":" 
87.
>            .ActivePrinter = sPrinter 
88.
>             If .ActivePrinter = sPrinter Then 
89.
>                 SetPdfPrinter = True:  Exit For 
90.
>             End If 
91.
>         Next 
92.
>     End With 
93.
>     On Error GoTo 0 
94.
> End Function 
95.
> 

Grüße Dieter

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

Geiler Scheiss! 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!

Frage Microsoft Microsoft Office

Ähnliche Inhalte

Excel Makro PDF erstellen

Frage von Chrigi83Microsoft Office1 Kommentar

Hallo zusammen Hab ein kleines Projekt in dem ich gerne ein PDF aus einem Excel drucken möchte mit dem ...

Excel 2013 Makro wieder rückgängig machen

Frage von ischbindebaetmaenVB for Applications4 Kommentare

Hallo Leude, ich habe in einer Exeltabelle ein Makro aufgezeichnet und einige Formatierungen vorgenommen. Dummerweise funktioniert jetzt der Reimport ...

Excel Makro

Frage von maloh1984Microsoft Office4 Kommentare

Hallo Habe ein Problem, ein Kunde der hat Excellisten mit Makro die lassen sich öffnen aber die Buttons reagieren ...

Excel-Makro

gelöst Frage von yuki13Microsoft Office7 Kommentare

Hallo Zusammen!! :-) Ich bin nicht so fit in Excel Makros und wollte mich hier erkundigen, ob mir jemand ...

Neue Wissensbeiträge

IoT-Gefahr: Smartes Aquarium leckt!

Information von Lochkartenstanzer vor 2 TagenHumor (lol)3 Kommentare

Moin, Die IoT-Manie hat weitere Opfer gefunden. Ein Casino-Leck durch ein smartes Aquarium: Allerdings haben sie kein Wasser, sondern ...

Alte Fritzbox 7270 mit VPN und SIP-Telefonie hinter O2 Homebox 6641 als "Modem"

Erfahrungsbericht von the-buccaneer vor 2 TagenRouter & Routing3 Kommentare

Nun war es soweit: Auch O2 hat mich mit VOIP zwangsbeglückt. Heute am Privatanschluss, in 2 Wochen ist das ...

Ungepatchte Remote Code Execution-Lücke in LG NAS

Information von kgborn vor 3 TagenSicherheit

Nutzt wer LG NAS-Einheiten? In den NAS-Einheiten der LG Network Storage-Einheiten gibt es eine sehr unschöne Schwachstelle, die einen ...

Neue Version KB4099950 NIC Einstellungen gehen verloren

Information von sabines vor 3 TagenWindows Update2 Kommentare

Es ist eine neue Version des KB4099950 verfügbar, die das Problem mit den verlorenen Netzwerkeinstellungen lösen soll. Das Datum ...

Heiß diskutierte Inhalte

VLAN - Offene Fragen

Frage von KnettenbrechNetzwerkgrundlagen16 Kommentare

Hallo zusammen, ich befasse mich derzeit mit dem Thema VLAN. Hierzu habe ich schon einige Guides gelesen, einschließlich des ...

Netzwerkmanagment im Haus mit Switch, Panel und pfsense

gelöst Frage von CorraggiounoNetzwerkmanagement16 Kommentare

hi zusammen, wir sind gerade dabei das ganze Haus bzw. die einzelnen Zimmer mit netzwerkdosen zu versorgen. Vom Keller ...

Empfehlung: Android Ortungsapp

gelöst Frage von certifiedit.netGoogle Android13 Kommentare

Guten Morgen, grundsätzlich vorweg, ich wollte mich eben schlau machen, bzgl einer Ortungsapp, welche Androidbasiert einem anderen Androidsmartphone mitteilt, ...

Server 2008 r2 vmware terminalserver

Frage von MasterCVmware12 Kommentare

Guten Abend zusammen, ich hoffe , dass einer von euch mir weiterhelfen kann ,bei meinem kack Problem ! Ist ...

Frage Microsoft Microsoft Office gelöst Excel 2010 Makro Probleme mit komp. Excel 2013, Qualität von PDF und Dateinamen

23.10.2014, aktualisiert 28.10.2014, 1473 Aufrufe, 17 Kommentare

Excel 2013 Makro wieder rückgängig machen

Excel Makro

Excel-Makro

Alte Fritzbox 7270 mit VPN und SIP-Telefonie hinter O2 Homebox 6641 als "Modem"

Ungepatchte Remote Code Execution-Lücke in LG NAS

Neue Version KB4099950 NIC Einstellungen gehen verloren

Frage Microsoft Microsoft Office
gelöst Excel 2010 Makro Probleme mit komp. Excel 2013, Qualität von PDF und Dateinamen