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:
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 16.118 mal aufgerufen.
Anzeige
![]() ![]() ![]() (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. |
sevWizard für VB5/6 ![]() Professionelle Assistenten im Handumdrehen Erstellen Sie eigene Assistenten (Wizards) im Look & Feel von Windows 2000/XP - mit allem Komfort und zwar in Windeseile :-) Tipp des Monats ![]() Dieter Otter Fensterstatus einer Anwendung abfragen Dieser Tipp zeigt, wie sich feststellen lässt, ob eine (Fremd-)Anwendung minimiert, maximiert oder normal angezeigt wird. vb@rchiv CD Vol.6 ![]() ![]() Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! Online-Update-Funktion Entwickler-Vollversionen u.v.m. |
||||||||||||||||
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. |