vb@rchiv · Tipps & Tricks · Text in beliebigem Winkel ausdrucken

Rubrik: Drucker | VB-Versionen: VB5, VB6

24.11.03

Text in beliebigem Winkel ausdrucken Dieser Tipp zeigt, wie sich ein Text in einem beliebigen Winkel ausdrucken lässt - sowohl in einem PictureBox-Control, als auch auf dem Drucker.
Autor: Dieter Otter	Bewertung:	Views: 16.329
www.tools4vb.de	System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Heute möchten wir Ihnen zeigen, wie sich ein Text in einem beliebigen Winkel ausdrucken lässt. Hierbei spielt es keine Rolle, ob der Text in einer PictureBox ausgegeben werden soll oder auf auf dem Drucker.

Die Prozedur PrintRotatedText erwartet folgende Parameter:

oPrinter: Printer-Objekt oder PictureBox-Control
nPosX, nPosY: Ausgabeposition in der eingestellten Maßeinheit
nWinkel: Optional. Winkel (0-360)
nSize: Optional. Schriftgröße in Punkt
bBold, bItalic, bUnderline: Optional. Schrift-Attribute
sFontName: Optional. Schriftname

Werden die optionalen Schrift-Parameter nicht angegeben, werden die aktuellen Einstellungen des Ausgabe-Objektes verwendet.

Option Explicit
 
' benötigte API - Deklaration
Private Declare Function SelectObject Lib "gdi32" ( _
  ByVal hdc As Long, _
  ByVal hObject As Long) As Long
 
Private Declare Function DeleteObject Lib "gdi32" ( _
  ByVal hObject As Long) As Long
 
Private Declare Function TextOut Lib "gdi32" _
  Alias "TextOutA" ( _
  ByVal hdc As Long, _
  ByVal X As Long, _
  ByVal Y As Long, _
  ByVal lpString As String, _
  ByVal nCount As Long) As Long
 
Private Declare Function CreateFontIndirect Lib "gdi32" _
  Alias "CreateFontIndirectA" ( _
  lpLogFont As LOGFONT) As Long
 
Private Declare Function MulDiv Lib "kernel32.dll" ( _
  ByVal nNumber As Long, _
  ByVal nNumerator As Long, _
  ByVal nDenominator As Long) As Long
 
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
  ByVal hdc As Long, _
  ByVal nIndex As Long) As Long
 
' Konstanten
Private Const LF_FACESIZE = 32
Private Const DEFAULT_CHARSET = 1
Private Const ANTIALIASED_QUALITY = 4
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const OUT_TT_PRECIS = 4
Private Const VARIABLE_PITCH = 2
Private Const LOGPIXELSY = 90
 
' FONT-Struktur
Private Type LOGFONT
  lfHeight As Long
  lfWidth As Long
  lfEscapement As Long
  lfOrientation As Long
  lfWeight As Long
  lfItalic As Byte
  lfUnderline As Byte
  lfStrikeOut As Byte
  lfCharSet As Byte
  lfOutPrecision As Byte
  lfClipPrecision As Byte
  lfQuality As Byte
  lfPitchAndFamily As Byte
  lfFaceName(LF_FACESIZE) As Byte
End Type

' Text in beliebigem Winkel ausdrucken
' z.B. auf dem Drucker oder auch in eine PictureBox
Public Sub PrintRotatedText(ByRef oPrinter As Object, _
  ByVal nPosX As Long, _
  ByVal nPosY As Long, _
  ByVal sText As String, _
  Optional ByVal nWinkel As Long = 0, _
  Optional ByVal nSize As Variant, _
  Optional ByVal bBold As Variant, _
  Optional ByVal bItalic As Variant, _
  Optional ByVal bUnderline As Variant, _
  Optional ByVal sFontName As Variant)
 
  Dim hdc As Long
  Dim hFontOld As Long
  Dim nRetVal As Long
  Dim hFont As Long
  Dim oFont As LOGFONT
  Dim i As Integer
 
  ' falls optionale Parameter nicht angegeben,
  ' Standard-Werte verwenden
  With oPrinter.Font
    If IsMissing(nSize) Then nSize = .Size
    If IsMissing(bBold) Then bBold = .Bold
    If IsMissing(bItalic) Then bItalic = .Italic
    If IsMissing(bUnderline) Then bUnderline = .Underline
    If IsMissing(sFontName) Then sFontName = .Name
  End With
 
  ' Position in Pixel umrechnen
  With oPrinter
    hdc = .hdc
    nPosX = .ScaleX(nPosX, .ScaleMode, vbPixels)
    nPosY = .ScaleY(nPosY, .ScaleMode, vbPixels)
  End With
 
  ' Schriftart in Bytearray umwandeln
  Dim abytfontname() As Byte
  abytfontname = StrConv(sFontName & Chr$(0), vbFromUnicode)
 
  ' Neues Font-Objekt erstellen
  With oFont
    .lfHeight = -MulDiv(nSize, GetDeviceCaps(hdc, LOGPIXELSY), 72)
    .lfEscapement = CLng(nWinkel * 10)
    .lfWeight = IIf(bBold, FW_BOLD, FW_NORMAL)
    .lfItalic = Abs(bItalic)
    .lfUnderline = Abs(bUnderline)
    .lfCharSet = DEFAULT_CHARSET
    .lfOutPrecision = OUT_TT_PRECIS
    .lfQuality = ANTIALIASED_QUALITY
    .lfPitchAndFamily = VARIABLE_PITCH
 
    For i = 0 To UBound(abytfontname)
      .lfFaceName(i) = abytfontname(i)
    Next
  End With
  hFont = CreateFontIndirect(oFont)
  hFontOld = SelectObject(hdc, hFont)
 
  ' Text ausgeben
  Call TextOut(hdc, nPosX, nPosY, sText, Len(sText))
 
  ' Ursprüngliche Schrift wiederherstellen
  Call SelectObject(hdc, hFontOld)
 
  ' Objekte zerstören
  Call DeleteObject(hFont)
End Sub

Beispiel für den Aufruf:

' Text im Winkel von 90° in PictureBox anzeigen
PrintRotatedText Picture1, 1000, 5000, "Test", 90

' Text im Winkel von 180° auf Drucker ausgeben
Printer.ScaleMode = vbMillimeters
Printer.Print
PrintRotatedText Printer, 10, 75, "Test", 180
Printer.EndDoc