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.332 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. |
sevZIP40 Pro DLL Zippen und Unzippen wie die Profis! Mit nur wenigen Zeilen Code statten Sie Ihre Anwendungen ab sofort mit schnellen Zip- und Unzip-Funktionen aus. Hierbei lassen sich entweder einzelnen Dateien oder auch gesamte Ordner zippen bzw. entpacken. 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 Access-Tools Vol.1 Über 400 MByte Inhalt Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB |
||||||||||||||||
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. |