AW: PaperSize = xlPaperUser
10.07.2011 13:22:05
fcs
Hallo Tim,
die Möglichkeiten hängen von den Fähigkeiten der zur Verfügung stehenden Drucker ab.
Ggf. kann man sich aber auch einen entsprechenden Drucker einrichten, dessen Ausgabe in eine Datei umgeleitet wird, z.B. einen Postscript-Drucker oder Kopierer/Drucker.
Die Funktion "Als PDF-Speichern" in Office 2007 und neuer greift scheinbar auf die Einstellungen des aktuell eingerichteten Druckers zurück, um die PDF-Datei zu speichern.
Der Wert, der unter VBA für die Papiergröße einzugeben ist, ist abhängig vom Drucker. Ich hab mal mit "FreePDF" und "Xerox Document Centre 420 PS" experimentiert.
Da ich keinen Weg kenne via VBA direkt auf die Einstellungsdialoge zuzugreifen, hab ich für FreePDF einen eigenen Drucker eingerichtet und die Eigenschaften für die benutzerdefinierte Papiergröße angepasst.
Für den Xerox hab ich die Benutzerdefinierte Papiergröße 1 entsprechend geändert.
Nachfolgend 2 Beispiel für die beiden Drucker. Ob das Merken und erneute Setzen des momentan aktiven Druckers relevant ist muss du selber entscheiden.
Gruß
Franz
'Erstellt unter Windows Vista, Office 2007
Sub Speichern_PDF_Var1()
' Speichern_PDF Makro
Dim sActivePrinter, sFileName As String, vPaperSize, iUSB As Integer
On Error GoTo Fehler
'Name der PDF-Datei festlegen
With ActiveWorkbook
If InStrRev(.Name, ".xls") = 0 Then
'Datei wurde noch nicht gespeichert
sFileName = .Name & Format(Now, " YYYYMMDD hhmmss") & ".pdf"
Else
sFileName = Left(.Name, InStrRev(.Name, ".") - 1) & _
Format(Now, "YYYYMMDD hhmmss") & ".pdf"
End If
sFileName = "C:\Users\Public\Test\" & sFileName
End With
'Aktiven Drucker merken
sActivePrinter = Application.ActivePrinter
vPaperSize = ActiveSheet.PageSetup.PaperSize
'Zähler für Druckerport, dieser ändert sich gelegentlich, deshalb wird in einer _
Schleife hochgezählt bis kein Fehler mehr auftritt.
iUSB = 0
Drucker_Setzen:
iUSB = iUSB + 1
'"FreePDF - FreePDF_216_303" ist der FreePDF-Drucker, dessen Standardeigenschaften _
auf das gewünschte Sonderformat eingestellt wurden.
Application.ActivePrinter = "FreePDF - FreePDF_216_303 auf Ne" & Format(iUSB, "00") & ":"
With ActiveSheet.PageSetup
.PaperSize = 32767 'Wert wurde per Makrorecorder ermittelt. _
216*303 mm - Hochformat lange Seite zuerst für FreePDF
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
sFileName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
Application.ActivePrinter = sActivePrinter
With ActiveSheet.PageSetup
.PaperSize = vPaperSize
End With
Fehler:
With Err
Select Case .Number
Case 0 'Ales OK
Case 1004 'Index-Fehler in Liste
Resume Drucker_Setzen
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Sub Speichern_PDF_Var2()
' Speichern_PDF Makro
Dim sActivePrinter, vPaperSize, sFileName As String, iUSB As Integer
On Error GoTo Fehler
'Name der PDF-Datei festlegen
With ActiveWorkbook
If InStrRev(.Name, ".xls") = 0 Then
'Datei wurde noch nicht gespeichert
sFileName = .Name & Format(Now, " YYYYMMDD hhmmss") & ".pdf"
Else
sFileName = Left(.Name, InStrRev(.Name, ".") - 1) & Format(Now, "YYYYMMDD hhmmss") _
& ".pdf"
End If
sFileName = "C:\Users\Public\Test\" & sFileName
End With
'Aktiven Drucker merken
sActivePrinter = Application.ActivePrinter
vPaperSize = ActiveSheet.PageSetup.PaperSize
Application.ActivePrinter = "Xerox Document Centre 420 PS auf FILE:"
With ActiveSheet.PageSetup
.PaperSize = 24000 'Benutzerdefinierte Größe 1 - per Makrorecorder ermittelt
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
sFileName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
Exit Sub
Application.ActivePrinter = sActivePrinter
With ActiveSheet.PageSetup
.PaperSize = vPaperSize
End With
Fehler:
With Err
Select Case .Number
Case 0 'Ales OK
Case 9999 'Dummy-Fehler
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub