PrintRotatedText - Display a rotated message

Const LF_FACESIZE = 32

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 As String * LF_FACESIZE
End Type

Private Declare Function SetGraphicsMode Lib "gdi32" (ByVal hdc As Long, _
    ByVal iMode As Long) As Long
Private Declare Function MulDiv Lib "Kernel32" (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
Private Declare Function CreateFontIndirect Lib "gdi32" Alias _
    "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
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 Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (dest As _
    Any, Source As Any, ByVal bytes As Long)

' Print rotated text
' The first argoment can be a form, a picture box, the Printer, and in general
' any VB object that supports the Font and the hDC properties.
' Text is the string to be printed
' Angle is the orientation, in 10th of degrees (default is 90°)
' X and Y are the printing coordinates (omit to use the current coordinates)
'
' Note: you get best results when using TrueType fonts

Sub PrintRotatedText(PB As Object, ByVal Text As String, _
    Optional ByVal Angle As Integer = -900, Optional x As Variant, _
    Optional y As Variant)

    Dim hfont As Long, holdfont As Long
    Dim Font As LOGFONT
   
    Const GM_ADVANCED = 2
    Const LOGPIXELSY = 90
    SetGraphicsMode PB.hdc, GM_ADVANCED
    
    ' Create a Font object, similar to the current font in PB
    ' but with a different orientation
    Font.lfHeight = -MulDiv(PB.FontSize, GetDeviceCaps(PB.hdc, LOGPIXELSY), 72)
    Font.lfWidth = 0
    Font.lfEscapement = Angle
    Font.lfOrientation = Angle
    Font.lfWeight = IIf(PB.FontBold, 700, 400)
    Font.lfItalic = IIf(PB.FontItalic, 1, 0)
    Font.lfUnderline = IIf(PB.FontUnderline, 1, 0)
    Font.lfStrikeOut = IIf(PB.FontStrikethru, 1, 0)
    Font.lfCharSet = 0
    Font.lfOutPrecision = 0
    Font.lfClipPrecision = 0
    Font.lfQuality = 2
    Font.lfPitchAndFamily = 33
    Font.lfFaceName = PB.FontName & vbNullChar
    
    hfont = CreateFontIndirect(Font)
    holdfont = SelectObject(PB.hdc, hfont)
    
    ' Account for X,Y coordinates
    If Not IsMissing(x) Then PB.CurrentX = x
    If Not IsMissing(y) Then PB.CurrentY = y
    
    ' do the printing
    PB.Print Text
    ' reselect the old font
    SelectObject PB.hdc, holdfont 
    ' destroy the font object just created
    DeleteObject hfont
End Sub