vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
vb@rchiv Offline-Reader - exklusiv auf der vb@rchiv CD Vol.4  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2019
 
zurück
Rubrik: Drucker   |   VB-Versionen: VB5, VB624.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 OtterBewertung:     [ Jetzt bewerten ]Views:  14.072 
www.tools4vb.deSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 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

Dieser Tipp wurde bereits 14.072 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Aktuelle Diskussion anzeigen (1 Beitrag)

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2019 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel