346 lines
10 KiB
QBasic
346 lines
10 KiB
QBasic
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
|
||
|
||
|
||
|
||
|