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.321 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
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. |
Neu! sevCommand 4.0 Professionelle Schaltflächen im modernen Design! Mit nur wenigen Mausklicks statten auch Sie Ihre Anwendungen ab sofort mit grafischen Schaltflächen im modernen Look & Feel aus (WinXP, Office, Vista oder auch Windows 8), inkl. große Symbolbibliothek. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 TOP Entwickler-Paket TOP-Preis!! Mit der Developer CD erhalten Sie insgesamt 24 Entwickler- komponenten und Windows-DLLs. Die Einzelkomponenten haben einen Gesamtwert von 1605.50 EUR... |
||||||||||||||||
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. |