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 15.858 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. |
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 Tipp des Monats ![]() Dieter Otter PopUp-Menü wird nicht angezeigt :-( In diesem Tipp verraten wir Ihnen, wie Sie Probleme mit PopUp-Menüs umgehen können, wenn diese unter bestimmten Umständen einfach nicht angezeigt werden. sevAniGif (VB/VBA) ![]() Anzeigen von animierten GIF-Dateien Ab sofort lassen sich auch unter VB6 und VBA (Access ab Version 2000) animierte GIF-Grafiken anzeigen und abspielen, die entweder lokal auf dem System oder auf einem Webserver gespeichert sind. |
||||||||||||||||
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. |