Public Sub PDF_vom_aktuellen_Blatt()
    ' Erzeugt eine PDF Datei 1:1 vom aktuellen Blatt für Blattgrößem A4 bis A0
    ' Hat das Blatt ein anderen Format, so wird es mit "Best Fit" auf ein A4 Blatt gedruckt.
    
Dim oApp As Application
Set oApp = ThisApplication
    
    ' check document-type
    Select Case oApp.ActiveDocument.DocumentType
    
        Case kDrawingDocumentObject
        
            'Get the active document
            Dim oDrgDoc As DrawingDocument
            Set oDrgDoc = oApp.ActiveDocument
       
            ' Set reference to drawing print manager
            ' DrawingPrintManager has more options than PrintManager
            ' as it's specific to drawing document
            Dim oDrgPrintMgr As DrawingPrintManager
            Set oDrgPrintMgr = oDrgDoc.PrintManager
            ' Set the printer name
            ' comment this line to use default printer or assign another one
            oDrgPrintMgr.Printer = "FreePDF XP"
    
            
            'Set the paper orientation
            On Error Resume Next
            Select Case oDrgDoc.ActiveSheet.Orientation
                Case kLandscapePageOrientation
                    oDrgPrintMgr.Orientation = kLandscapeOrientation
                Case kPortraitPageOrientation
                    oDrgPrintMgr.Orientation = kPortraitOrientation
                Case Else    ' Andere Werte.
                    Debug.Print "ungültige Orientierung"
                    GoTo endeSub
            End Select
       
            ' Set the paper size
            On Error Resume Next
            Select Case oDrgDoc.ActiveSheet.Size
                Case kA4DrawingSheetSize
                    oDrgPrintMgr.PaperSize = kPaperSizeA4
                    oDrgPrintMgr.ScaleMode = kPrintCustomScale
                    oDrgPrintMgr.[Scale] = 1
                Case kA3DrawingSheetSize
                    oDrgPrintMgr.PaperSize = kPaperSizeA3
                    oDrgPrintMgr.ScaleMode = kPrintCustomScale
                    oDrgPrintMgr.[Scale] = 1
                Case kA2DrawingSheetSize
                    oDrgPrintMgr.PaperSize = kPaperSizeA2
                    oDrgPrintMgr.ScaleMode = kPrintCustomScale
                    oDrgPrintMgr.[Scale] = 1
                Case kA1DrawingSheetSize
                    oDrgPrintMgr.PaperSize = kPaperSizeA1
                    oDrgPrintMgr.ScaleMode = kPrintCustomScale
                    oDrgPrintMgr.[Scale] = 1
                Case kA0DrawingSheetSize
                    oDrgPrintMgr.PaperSize = kPaperSizeA0
                    oDrgPrintMgr.ScaleMode = kPrintCustomScale
                    oDrgPrintMgr.[Scale] = 1
                Case Else    ' Andere Werte.
                    'oDrgPrintMgr.PaperSize = kPaperSizeA3
                    'oDrgPrintMgr.ScaleMode = kPrintCustomScale
                    'oDrgPrintMgr.[Scale] = 1
                    oDrgPrintMgr.PaperSize = kPaperSizeA4
                    oDrgPrintMgr.ScaleMode = kPrintBestFitScale
            End Select
            
            
            ' Set the Caption, submit print ans set the caption back
            
            'Dim sOldDisplayName As String
            'Dim sNewDisplayName As String
            
            'sOldDisplayName = oDrgDoc.DisplayName
            'sNewDisplayName = oDrgDoc.DisplayName & ".pdf"
            
            'MsgBox ("old: " & sOldDisplayName & vbCrLf & "new: " & sNewDisplayName)
            
            'oDrgDoc.DisplayName = sNewDisplayName
            
            oDrgPrintMgr.SubmitPrint

            'oDrgDoc.DisplayName = sOldDisplayName
            
            Set oDrgPrintMgr = Nothing
            Set oDrgDoc = Nothing
        
        Case Else
        
            'Get the active document
            Dim oDoc As Document
            Set oDoc = oApp.ActiveDocument
            
            ' Set the background to the srecific one ( and back - later )
            ' Holthausen Winding
            If IPropEintraege.Property_lesen(oDoc, "Company") = "Holthausen Winding" Then
                oApp.ColorSchemes.Item("Taubengrau").Activate
                'oApp.ColorSchemes.Item("Präsentation").Activate
            Else
                oApp.ColorSchemes.Item("Millennium").Activate
            End If

            'GoTo endeSub
            
            ' Set reference to print manager
            Dim oPrintMgr As PrintManager
            Set oPrintMgr = oDoc.PrintManager
            ' Set the printer name
            ' comment this line to use default printer or assign another one
            oPrintMgr.Printer = "FreePDF XP"
    
            
            'Set the paper orientation
            On Error Resume Next
            'gewünschte Orientierung abfragen
            Dim iOrientation As Variant
            iOrientation = MsgBox("Orientierung Querformat ?" & vbCrLf, vbYesNoCancel)
            
            Select Case iOrientation
                Case vbYes
                    oPrintMgr.Orientation = kLandscapeOrientation
                Case vbNo
                    oPrintMgr.Orientation = kPortraitOrientation
                Case Else    ' cancel gerückt
                    GoTo endeSub
            End Select
            
            ' Set the paper size
            oPrintMgr.PaperSize = kPaperSizeA4
            oPrintMgr.ColorMode = kPrintColorPalette
            oPrintMgr.NumberOfCopies = 1
            
            
            ' Fenstergröße anpassen, so daß das Seitenverhältnis zur Blattgröße stimmt und Druck anstoßen
            
            Dim oView As View
            Set oView = oApp.ActiveView
            
            Dim oOldWindowState As WindowsSizeEnum
            oOldWindowState = oView.WindowState
            oView.WindowState = kNormalWindow
            
            Dim iHoehe As Long
            Dim iBreite As Long
            
            If oPrintMgr.Orientation = kLandscapeOrientation Then
                iBreite = oView.Width
                iHoehe = CLng(iBreite * (210# / 297))
                oView.height = iHoehe
                
                Call MsgBox(" Breite " & CStr(oView.Width) & vbCrLf & " Höhe   " & CStr(oView.height), vbOKOnly)
                       
                
            Else
                iBreite = oView.Width
                iHoehe = CLng(iBreite / (210# / 297))
                oView.height = iHoehe
                
                Call MsgBox(" Breite " & CStr(oView.Width) & vbCrLf & " Höhe   " & CStr(oView.height), vbOKOnly)
                
            End If
            
            oPrintMgr.SubmitPrint
            oView.WindowState = oOldWindowState
            
            Set oView = Nothing
            Set oPrintMgr = Nothing
            Set oDoc = Nothing
            
    End Select
       
       
        

endeSub:
  
  oApp.ColorSchemes.Item("Millennium").Activate
  Set oApp = Nothing
  

End Sub