CodeItBetter Programming Another VB Programming Blog

'Graphics - How to Draw Rotated Text directly on Screen

Option Explicit
 
'Add a Text Box and a Command Button to your form.

Private Declare Function GetDC Lib "user32" (ByVal hwnd 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 Const TRANSPARENT = 1
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor& Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long)
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT)
Const LF_FACESIZE = 32
Const OUT_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const DEFAULT_CHARSET = 1
Const FF_DONTCARE = 0
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
 
Private Sub Command1_Click()
    Dim ldc As Long
    ldc = GetDC(0)
    DrawWithFont ldc, Text1.text
End Sub
 
Private Sub DrawWithFont(ldc As Long, sMessage As String)
    Dim FontToUse As Long
    Dim lf As LOGFONT
    Dim dl&, x%, ByteArrayLimit&, oldhdc&
    Dim TempByteArray() As Byte
    With lf
        'height of the text
        .lfHeight = 90
        'width of the text
        .lfWidth = 90
        'rotation angle
        .lfEscapement = 600
        'thickness of the text
        .lfWeight = 400
        .lfOutPrecision = OUT_DEFAULT_PRECIS
        .lfClipPrecision = OUT_DEFAULT_PRECIS
        .lfQuality = DEFAULT_QUALITY
        .lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
        .lfCharSet = DEFAULT_CHARSET
    End With
    TempByteArray = StrConv("Arial" & Chr$(0), vbFromUnicode)
    ByteArrayLimit = UBound(TempByteArray)
    For x% = 0 To ByteArrayLimit
        lf.lfFaceName(x%) = TempByteArray(x%)
    Next x%
    FontToUse = CreateFontIndirect(lf)
    If FontToUse = 0 Then Exit Sub
    oldhdc = SelectObject(ldc, FontToUse)
    SetTextColor ldc, vbRed
    SetBkMode ldc, TRANSPARENT
    TextOut ldc, 300, 600, sMessage, Len(sMessage)
    oldhdc = SelectObject(ldc, FontToUse)
    SelectObject ldc, oldhdc
End Sub