Sub Form_Print(localname As Form)
  Const IDOK = 1  ' OK button pressed
 
  On Error GoTo Form_Print_Fehler
  If MsgHardcopy() = IDOK Then
    If (Forms.Count - 1) > 1 Then
       If localname.WindowState = vbMinimized Then
         localname.WindowState = vbNormal
         DoEvents
       End If
      ' The ScaleMode must be set to pixels for the CaptureWindow
      ' routine to print correctly.
      Printer.ScaleMode = vbPixels
      ' Change MousePointer to an hourglass.
      Screen.MousePointer = vbHourglass
      ' Initialize the printer.
      Printer.Print ""
      ' Copy the image of the form to the printer.
      PrintPictureToFitPage Printer, CaptureWindow(localname.hwnd, 0, 0, _
        localname.ScaleX(localname.Width, vbTwips, vbPixels), _
        localname.ScaleY(localname.Height, vbTwips, vbPixels))
      Printer.EndDoc
      Screen.MousePointer = vbDefault
    End If
  End If
  Exit Sub
 
Form_Print_Fehler:
  Error_Log "Form_Print", Err, Erl
End Sub
 
Public Sub PrintPictureToFitPage(Prn As Printer, pic As Picture)
  Const vbHiMetric As Integer = 8
  Dim ret As Integer
  Dim Pcnt As Integer, I As Integer
  Dim PicRatio As Double, PrnWidth As Double
  Dim PrnHeight As Double, PrnRatio As Double
  Dim PrnPicWidth As Double, PrnPicHeight As Double
  Dim Zeile As String
 
  On Error GoTo PrintPicture_Fehler
  ' The following is an example of mixing text with bitmap.
  Pcnt = Prn.FontCount - 1
  For I = 0 To Pcnt ' Determine number of fonts.
    If Prn.Fonts(I) = "Courier" Then Printer.FontName = "Courier"
    If Prn.Fonts(I) = "Arial" Then
      Prn.FontName = "Arial"
      I = Prn.FontCount
    End If
    If Prn.Fonts(I) = "Helv" Then
      Prn.FontName = "Helv"
      I = Prn.FontCount
    End If
  Next I
  Prn.FontSize = 24
  Prn.FontBold = True
  If Prn.FontName = "Courier" Then
    Prn.Print "Hardcopy" 
  End If
  Prn.FontSize = 12
  Prn.FontBold = False
  Prn.Print Date & Space$(4) & Left$(Time$, 5)
 
  ' Calculate device independent Width-to-Height ratio for picture.
  PicRatio = pic.Width / pic.Height
 
  ' Calculate the dimentions of the printable area in HiMetric.
  PrnWidth = Prn.ScaleX(Prn.ScaleWidth, Prn.ScaleMode, vbHiMetric) * 1.6
  PrnHeight = Prn.ScaleY(Prn.ScaleHeight, Prn.ScaleMode, vbHiMetric) * 1.6
 
  ' Calculate device independent Width to Height ratio for printer.
  PrnRatio = PrnWidth / PrnHeight
 
  ' Scale the output to the printable area.
  If PicRatio >= PrnRatio Then
    ' Scale picture to fit full width of printable area.
    PrnPicWidth = Prn.ScaleX(Prn.Width, vbHiMetric, Prn.ScaleMode) * 1.6
    PrnPicHeight = Prn.ScaleY(Prn.Width / PicRatio, vbHiMetric, Prn.ScaleMode) _
      * 1.6
  Else
    ' Scale picture to fit full height of printable area.
    PrnPicHeight = Prn.ScaleY(Prn.Height, vbHiMetric, Prn.ScaleMode)
    PrnPicWidth = Prn.ScaleX(Prn.Height * PicRatio, vbHiMetric, Prn.ScaleMode)
  End If
 
  ' Print the picture using the PaintPicture method.
  Prn.PaintPicture pic, 0, 450, PrnPicWidth, PrnPicHeight
  Exit Sub
 
PrintPicture_Fehler:
  Select Case Err
    Case 480:
      MsgBox "Fehler 480: beim Ausdruck der Maske aufgetreten.", 48, "Hardcopy"
    Case 482:
      If MsgBox("Fehler 482: Drucker nicht bereit.", 5, "Hardcopy") = 4 Then
        Resume
      Else
        Screen.MousePointer = vbDefault     ' Voreinstellung
      End If
    Case Else:
      Error_Log "PrintPicture", Err
  End Select
End Sub

Private Sub CSCmdDrucken_Click()
  Form_Print ActiveForm
  Text1.SetFocus
End Sub