Attribute VB_Name = "modPrinter"
Option Explicit

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113

Private Const Zoll = 1440
Private Const cm = Zoll / 2.54
Private Const mm = cm / 10


Public Function GetPrinterMarginLeft(ByRef MyPrinter As Printer) As Double
   GetPrinterMarginLeft = Printer.ScaleX(GetDeviceCaps(MyPrinter.hdc, PHYSICALOFFSETX), vbPixels, vbTwips) / mm
End Function


Public Function GetPrinterMarginTop(ByRef MyPrinter As Printer) As Double
   GetPrinterMarginTop = Printer.ScaleY(GetDeviceCaps(MyPrinter.hdc, PHYSICALOFFSETY), vbPixels, vbTwips) / mm
End Function


Public Function GetPrinterMarginRight(ByRef MyPrinter As Printer) As Double
   GetPrinterMarginRight = (MyPrinter.Width - Printer.ScaleWidth) / mm - GetPrinterMarginLeft(MyPrinter)
End Function


Public Function GetPrinterMarginBottom(ByRef MyPrinter As Printer) As Double
   GetPrinterMarginBottom = (MyPrinter.Height - Printer.ScaleHeight) / mm - GetPrinterMarginTop(MyPrinter)
End Function



Public Function PrintText(ByRef PrintDestination As Object, ByVal dblLeft As Double, ByVal dblTop As Double, ByVal strText As String, Optional blnItalic As Boolean = False, Optional blnBold As Boolean = False, Optional blnUnderline As Boolean = False, Optional blnCenterHorizontal As Boolean = False, Optional blnCenterVertical As Boolean = False) As Double

   Dim dblTextWidth As Double
   Dim dblTextHeight As Double
   
   PrintDestination.FontBold = blnBold
   PrintDestination.FontItalic = blnItalic
   PrintDestination.FontUnderline = blnUnderline
   
   dblTextWidth = PrintDestination.TextWidth(strText)
   dblTextHeight = PrintDestination.TextHeight(strText)
   
   If blnCenterHorizontal Then
      PrintDestination.CurrentX = dblLeft - dblTextWidth / 2
   Else
      PrintDestination.CurrentX = dblLeft
   End If
   
   If blnCenterVertical Then
      PrintDestination.CurrentY = dblTop - dblTextHeight / 2
   Else
      PrintDestination.CurrentY = dblTop
   End If
   
   PrintDestination.Print strText
   
   PrintText = dblTextWidth
   
End Function



Public Sub SetLineWidth(ByRef PrintObject As Object, ByVal blnFatLine As Boolean)

   PrintObject.FillStyle = vbFSTransparent
   PrintObject.DrawStyle = vbSolid
   
   If blnFatLine Then
      If TypeOf PrintObject Is PictureBox Then
         PrintObject.DrawWidth = 2
      Else
         PrintObject.DrawWidth = 2 * 12 / PrintObject.TwipsPerPixelX
      End If
   Else
      If TypeOf PrintObject Is PictureBox Then
         PrintObject.DrawWidth = 1
      Else
         PrintObject.DrawWidth = 1 * 12 / PrintObject.TwipsPerPixelX
      End If
   End If
End Sub



Public Sub SetSelectedPrinter(ByRef MyComboBox As ComboBox)
   
   Dim i As Integer
   
   Printer.TrackDefault = False
   For i = 0 To Printers.Count - 1
      If MyComboBox.List(MyComboBox.ListIndex) = Printers(i).DeviceName Then
         Set Printer = Printers(i)
         Exit For
      End If
   Next

End Sub








Public Sub DrawTextWidthFixedWidth(ByRef PrintDestination As Object, ByVal dblLeft As Double, ByVal dblTop As Double, ByVal dblWidth As Double, ByVal strText As String, Optional blnNoBlockSatz As Boolean = False, Optional blnItalic As Boolean = False, Optional blnBold As Boolean = False, Optional blnUnderline As Boolean = False)

   Dim dblTextWidth As Double
   Dim dblTextHeight As Double
   
   Debug.Print "DrawTextWidthFixedWidth", PrintDestination.FontSize
   PrintDestination.FontBold = blnBold
   PrintDestination.FontItalic = blnItalic
   PrintDestination.FontUnderline = blnUnderline
   
   dblTextWidth = PrintDestination.TextWidth(strText)
   dblTextHeight = PrintDestination.TextHeight(strText)

   If blnNoBlockSatz Then
      PrintText PrintDestination, dblLeft, dblTop, strText, blnItalic, blnBold, blnUnderline
      Exit Sub
   End If
   
   Dim dblZoom          As Double
   Dim strTextPart()    As String
   Dim lngLuecken       As Long
   Dim dblDiffLen       As Double
   Dim dblPartLen       As Double
   Dim dblAddPartDiff   As Double
   
   strText = Trim$(strText)
   dblTextWidth = PrintDestination.TextWidth(strText)
   dblDiffLen = dblWidth - dblTextWidth
   strTextPart = Split(strText, " ")
   lngLuecken = UBound(strTextPart)
   dblAddPartDiff = dblDiffLen / lngLuecken
   
   Dim i       As Integer
   
   Dim dblPosLeft    As Double
   Dim dblPosRight   As Double
   
   dblPosLeft = dblLeft
   
   For i = 0 To UBound(strTextPart)
      If i = UBound(strTextPart) Then
         dblPartLen = PrintDestination.TextWidth(strTextPart(i))
         PrintText PrintDestination, dblLeft + dblWidth - dblPartLen, dblTop, strTextPart(i), blnItalic, blnBold, blnUnderline
      Else
         dblPartLen = PrintText(PrintDestination, dblPosLeft, dblTop, strTextPart(i) & " ", blnItalic, blnBold, blnUnderline)
         dblPosLeft = dblPosLeft + dblPartLen
         dblPosLeft = dblPosLeft + dblAddPartDiff
      End If
   Next
   
End Sub

'Sub PrintWrappedText(PrintObject As Object, strText As String, ByVal dblLeft As Double, ByVal dblright As Double, ByVal dblTop As Double, ByRef dblBottom As Double)
'' by Reinhard Henning
'    Dim dblWidth As Double
'    Dim dblY As Double
'
'    Dim intAnzahlZeilen  As Integer
'    Dim i As Integer
'    Dim intAnzahlZeichen As Integer
'    dblY = dblTop
'
'    For i = 1 To Len(strText)
'        ' passt der Text bis hier hin noch in die Zeile ?
'        dblWidth = PrintObject.TextWidth(Left(strText, i + 1))
'        If dblLeft + dblWidth >= dblright Then
'            'nein, also bis zur gemerkten Position
'            PrintObject.CurrentX = dblLeft
'            PrintObject.Print Left(strText, intAnzahlZeichen)
'            strText = Mid(strText, intAnzahlZeichen)
'        Else
'            If InStr(1, Left(strText, i), " ") = 0 Then
'                'noch kein Space an genau aktueller Position
'                intAnzahlZeichen = i
'            ElseIf Mid(strText, i, 1) = " " Then
'                ' ein Space bis zur aktuellen Position
'                ' merke Anzahl der Zeichen, die noch passt
'                intAnzahlZeichen = i
'            End If
'        End If
'    End If
'End Sub


Public Sub PrintTextAligned(PrintObject As Object, strText As String, dblLeft As Double, dblRight As Double, dblTop As Double, Alignment As AlignmentConstants)
Dim varLinie As Variant
    PrintObject.CurrentY = dblTop
    For Each varLinie In Split(strText, vbCrLf)
    Select Case Alignment
        Case vbCenter
            PrintObject.CurrentX = dblLeft + (dblRight - dblLeft - PrintObject.TextWidth(varLinie)) / 2
        Case vbLeftJustify
            PrintObject.CurrentX = dblLeft
        Case vbRightJustify
            PrintObject.CurrentX = dblRight - PrintObject.TextWidth(varLinie)
    End Select
    PrintObject.Print varLinie
    Next
End Sub


 ' Print the text with wrapping.
Public Sub WrapText(ByRef PrintObject As Object, ByVal txt As String, ByVal xmin As Double, ByVal xmax As Double, ByVal ymin As Double, ByRef ymax As Double, ByVal draw_box As Boolean)

Dim x As Double
Dim y As Double
Dim xmargin As Double
Dim ymargin As Double
Dim line_wid As Double
Dim new_line As String
Dim new_word As String

    ' Convert non-printable characters to spaces.
    'NonPrintToSpace txt
    
    ' If we should draw a box, add a small margin.
    If draw_box Then
        xmargin = PrintObject.TextWidth("x") / 2
        'ymargin = PrintObject.ScaleY(PrintObject.Font.Size * 0.5, _
        '    vbPoints, PrintObject.ScaleMode)
            ymargin = PrintObject.TextHeight("X")
            
        xmin = xmin + xmargin
        xmax = xmax - xmargin
        ymin = ymin + ymargin
    End If
    line_wid = xmax - xmin

    ' Start printing.
    PrintObject.CurrentY = ymin
    PrintObject.CurrentX = xmin
    new_word = GetWord(txt)
    Do
        ' Start with the last word examined.
        ' Note that this loop prints at least one
        ' word per line. That is important if the
        ' text contains a word too long to fit on
        ' a line.
        new_line = new_word
        Do
            ' Get the next word.
            new_word = GetWord(txt)
            
            If Left(new_word, 1) = vbLf Or Left(new_word, 1) = vbCr Then
                new_word = Replace(new_word, vbLf, "")
                new_word = Replace(new_word, vbCr, "")
                Exit Do
            End If
            
            If new_word = "" Then Exit Do

            ' See if the new word fits.
            If PrintObject.TextWidth(new_line & " " & new_word) > line_wid Then
                Exit Do
            End If
               
            ' It fits. Add it to the line.
            new_line = Trim(new_line & " " & new_word)
        Loop

        ' Display the line. This moves CurrentX to
        ' zero and CurrentY to the next line.
        
        If PrintObject.CurrentY + ymargin + PrintObject.TextHeight("X") < ymax Then
            PrintObject.Print new_line
        Else
            Exit Sub
        End If
        
        If txt = "" Then
            If new_word <> "" Then
                ' Reset CurrentX to our left margin.
                PrintObject.CurrentX = xmin
                PrintObject.Print new_word
            End If
            Exit Do
        End If

        ' Reset CurrentX to our left margin.
        PrintObject.CurrentX = xmin
    Loop
    
    ' Draw the box if desired.
    If draw_box Then
        xmin = xmin - xmargin
        xmax = xmax + xmargin
        ymin = ymin - ymargin
        PrintObject.Line (xmin, ymin)- _
            (xmax, PrintObject.CurrentY + ymargin), , B
    End If
    
End Sub

' Convert non-printable characters into spaces.
Private Sub NonPrintToSpace(txt As String)
Dim i As Integer
Dim txtlen As Integer
Dim ch As String

    txtlen = Len(txt)
    For i = 1 To txtlen
        ch = Mid$(txt, i, 1)
        If ch < " " Or ch > "~" _
            Then Mid$(txt, i, 1) = " "
    Next i
End Sub

' Return the next word from this string. Remove
' the word from the string.
Private Function GetWord(ByRef txt As String) As String
Dim pos As Integer
    
    txt = Trim$(txt)
    pos = InStr(txt, " ")
    ' Reinhard Henning, erweitert für NewLine
    If InStr(txt, vbCr) > 0 Then
        pos = InStr(txt, vbCr)
    End If
    If InStr(txt, vbLf) > 0 Then
        pos = InStr(txt, vbLf)
    End If
    
    
    If pos < 1 Then
        GetWord = txt
        txt = ""
    Else
        GetWord = Left$(txt, pos - 1)
        GetWord = Replace(GetWord, vbCr, "")
        GetWord = Replace(GetWord, vbLf, "")
        txt = Trim$(Right$(txt, Len(txt) - pos))
    End If
End Function