346 lines
10 KiB
VB.net
346 lines
10 KiB
VB.net
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
|
|
|
|
|
|
|
|
|