' ----------------------------------------' The Rotator class module'' A class for printing rotated text to a ' Form, PictureBox or the Printer'' Author: Timm Dickel ([email protected])'' ----------------------------------------' Usage:'     Dim rotTest As New Rotator'     Set rotTest.Device = Printer'     ' set all font attributes as required, e.g.'     Printer.Font.Size = 12 '     'Label strings at a variety of angles'     For nA = 0 To 359 Step 15'        rotTest.Angle = nA'        rotTest.PrintText Space(10) & Printer.Font.Name & Str(nA)'     Next'     Printer.EndDoc'' ----------------------------------------Option Explicit'API constantsPrivate Const LF_FACESIZE = 32Private Const LOGPIXELSY = 90Private 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 - 1) As ByteEnd TypePrivate Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _    ByVal hObject As Long) As LongPrivate Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As _    LongPrivate Declare Function CreateFontIndirect Lib "gdi32" Alias _    "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPrivate 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 LongPrivate Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _    ByVal nIndex As Long) As Long'Module-level private variablesPrivate mobjDevice As ObjectPrivate mfSX1 As SinglePrivate mfSY1 As SinglePrivate mfXRatio As SinglePrivate mfYRatio As SinglePrivate lfFont As LOGFONTPrivate mnAngle As Integer'~~~AngleProperty Let Angle(nAngle As Integer)    mnAngle = nAngleEnd PropertyProperty Get Angle() As Integer    Angle = mnAngleEnd Property'~~~PrintTextPublic Sub PrintText(sText As String)    Dim lFont As Long    Dim lOldFont As Long    Dim lRes As Long    Dim byBuf() As Byte    Dim nI As Integer    Dim sFontName As String    Dim mobjDevicehdc As Long    Dim mobjDeviceCurrentX As Single    Dim mobjDeviceCurrentY As Single        mobjDevicehdc = mobjDevice.hdc    mobjDeviceCurrentX = mobjDevice.CurrentX    mobjDeviceCurrentY = mobjDevice.CurrentY        'Prepare font name, decoding from Unicode    sFontName = mobjDevice.Font.Name    byBuf = StrConv(sFontName & Chr$(0), vbFromUnicode)    For nI = 0 To UBound(byBuf)        lfFont.lfFaceName(nI) = byBuf(nI)    Next nI        'Convert known font size to required units    lfFont.lfHeight = mobjDevice.Font.Size * GetDeviceCaps(mobjDevicehdc, _        LOGPIXELSY)  72        'Set Italic or not    If mobjDevice.Font.Italic = True Then        lfFont.lfItalic = 1    Else        lfFont.lfItalic = 0    End If    'Set Underline or not    If mobjDevice.Font.Underline = True Then        lfFont.lfUnderline = 1    Else        lfFont.lfUnderline = 0    End If    'Set Strikethrough or not    If mobjDevice.Font.Strikethrough = True Then        lfFont.lfStrikeOut = 1    Else        lfFont.lfStrikeOut = 0    End If    'Set Bold or not (use font's weight)    lfFont.lfWeight = mobjDevice.Font.Weight    'Set font rotation angle    lfFont.lfEscapement = CLng(mnAngle * 10#)    lfFont.lfOrientation = lfFont.lfEscapement        'Build temporary new font and output the string    lFont = CreateFontIndirect(lfFont)    lOldFont = SelectObject(mobjDevicehdc, lFont)    lRes = TextOut(mobjDevicehdc, XtoP(mobjDeviceCurrentX), _        YtoP(mobjDeviceCurrentY), sText, Len(sText))    lFont = SelectObject(mobjDevicehdc, lOldFont)    DeleteObject lFontEnd Sub'~~~DeviceProperty Set Device(objDevice As Object)    Dim fSX2 As Single    Dim fSY2 As Single    Dim fPX2 As Single    Dim fPY2 As Single    Dim nScaleMode As Integer    Set mobjDevice = objDevice    With mobjDevice        'Grab current scaling parameters        nScaleMode = .ScaleMode        mfSX1 = .ScaleLeft        mfSY1 = .ScaleTop        fSX2 = mfSX1 + .ScaleWidth        fSY2 = mfSY1 + .ScaleHeight        'Temporarily set pixels mode       .ScaleMode = vbPixels    '   .ScaleMode = vbMillimeters       'Grab pixel scaling parameters        fPX2 = .ScaleWidth        fPY2 = .ScaleHeight        'Reset user's original scale        If nScaleMode = 0 Then            mobjDevice.Scale (mfSX1, mfSY1)-(fSX2, fSY2)        Else            mobjDevice.ScaleMode = nScaleMode        End If        'Calculate scaling ratios just once        mfXRatio = fPX2 / (fSX2 - mfSX1)        mfYRatio = fPY2 / (fSY2 - mfSY1)    End WithEnd Property'Scales X value to pixel locationPrivate Function XtoP(fX As Single) As Long    XtoP = (fX - mfSX1) * mfXRatioEnd Function'Scales Y value to pixel locationPrivate Function YtoP(fY As Single) As Long    YtoP = (fY - mfSY1) * mfYRatioEnd Function