Windowless Vertical Label control

LabelVert.ctl

VERSION 5.00
Begin VB.UserControl LabelVert 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   BackStyle       =   0  'Transparent
   CanGetFocus     =   0   'False
   ClientHeight    =   3372
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4980
   ClipBehavior    =   0  'None
   ClipControls    =   0   'False
   BeginProperty Font 
      Name            =   "Segoe UI"
      Size            =   9.6
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   HasDC           =   0   'False
   HitBehavior     =   0  'None
   ScaleHeight     =   281
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   415
   ToolboxBitmap   =   "LabelVert.ctx":0000
   Windowless      =   -1  'True
End
Attribute VB_Name = "LabelVert"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'
' Inspired with initial rotation ideas Written by Nir Sofer - http://nirsoft.mirrorz.com
' Transformed into a UserControl by Elroy Sullivan, PhD.
'
Option Explicit
'
Public Enum LabelVertDirectionEnum
    LabelVertUp
    LabelVertDown
End Enum
#If False Then  ' IntelliSense fix.
    Dim LabelVertUp, LabelVertDown
#End If
'
Private Type LOGFONT
    lfHeight            As Long
    lfWidth             As Long
    lfEscapement        As Long ' The angle, in tenths of degrees, between the escapement vector and the x-axis of the device. The escapement vector is parallel to the base line of a row of text. When the graphics mode is set to GM_COMPATIBLE, lfEscapement specifies both the escapement and orientation. You should set lfEscapement and lfOrientation to the same value.
    lfOrientation       As Long ' The angle, in tenths of degrees, between each character's base line and the x-axis of the device.
    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(1 To 32) As Byte
End Type
'
Private Declare Function TextOutW Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As Long, ByVal nCount As Long) As Long
Private Declare Function CreateFontIndirectA Lib "gdi32" (lpLogFont As LOGFONT) As Long
Private Declare Function GetObjectA Lib "gdi32" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hDC As Long, ByVal uObjectType As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) 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
'
Event Click()
Event DblClick()
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'
Dim msCaption       As String
Dim miAlignment     As AlignmentConstants
Dim miDirection     As LabelVertDirectionEnum
Dim miForeColor     As OLE_COLOR
Dim miBackColor     As OLE_COLOR
'

' ******************************************************************************
' Events we'll acknowledge.
' ******************************************************************************

Private Sub UserControl_Click()
    RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub UserControl_HitTest(X As Single, Y As Single, HitResult As Integer)
    HitResult = vbHitResultHit
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

' ******************************************************************************
' Properties (other than those handled by the form, or other container).
' ******************************************************************************

Public Property Get Direction() As LabelVertDirectionEnum
    Direction = miDirection
End Property

Public Property Let Direction(prop As LabelVertDirectionEnum)
    miDirection = prop
    UserControl.Refresh
    PropertyChanged "Direction"
End Property

Public Property Get Alignment() As AlignmentConstants
    Alignment = miAlignment
End Property

Public Property Let Alignment(prop As AlignmentConstants)
    miAlignment = prop
    UserControl.Refresh
    PropertyChanged "Alignment"
End Property

Public Property Get Caption() As String
Attribute Caption.VB_UserMemId = 0
Attribute Caption.VB_MemberFlags = "200"
    Caption = msCaption
End Property

Public Property Let Caption(ByVal s As String)
    msCaption = s
    UserControl.Refresh
    PropertyChanged "Caption"
End Property

Public Property Get CaptionUnicode() As String          ' Now we mess with the Unicode caption.
    If RunTime Then
        CaptionUnicode = msCaption                      ' Just for runtime.
    Else
        CaptionUnicode = "(Unicode, runtime only)"      ' Just show this in the Properties Window.
    End If
End Property

Public Property Let CaptionUnicode(ByVal s As String)
    ' For this particular control, this is actually the same as the above Caption during runtime.
    If Not RunTime Then Exit Property                   ' Only allowed in runtime, not from Properties Window.
    msCaption = s
    UserControl.Refresh
    PropertyChanged "Caption"
End Property

Public Property Get Font() As Font
    Set Font = UserControl.Font
End Property

Public Property Set Font(prop As Font)
    ' Be SURE font is a TrueType font or it can't be rotated.
    Set UserControl.Font = prop
    UserControl.Refresh
    PropertyChanged "Font"
End Property

Public Property Get ForeColor() As OLE_COLOR
    ForeColor = miForeColor
End Property

Public Property Let ForeColor(prop As OLE_COLOR)
    miForeColor = prop
    UserControl.Refresh
    PropertyChanged "ForeColor"
End Property

Public Property Get BackColor() As OLE_COLOR
    BackColor = miBackColor
End Property

Public Property Let BackColor(prop As OLE_COLOR)
    miBackColor = prop
    UserControl.Refresh
    PropertyChanged "BackColor"
End Property

' ******************************************************************************
' Other support procedures.
' ******************************************************************************

Private Function RunTime() As Boolean
    ' ie., Not DesignTime.
    '
    RunTime = True
    ' Under certain circumstances, when in Runtime, the following will error.
    On Error Resume Next
        RunTime = UserControl.Ambient.UserMode
    On Error GoTo 0
End Function

Private Sub UserControl_InitProperties()
    msCaption = UserControl.Ambient.DisplayName
    miDirection = LabelVertDown
    miAlignment = vbLeftJustify
    miForeColor = vbBlack
    miBackColor = vbWhite
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    miDirection = PropBag.ReadProperty("Direction", LabelVertUp)
    miAlignment = PropBag.ReadProperty("Alignment", vbLeftJustify)
    msCaption = PropBag.ReadProperty("Caption", vbNullString)
    Set UserControl.Font = PropBag.ReadProperty("Font", UserControl.Font)
    miForeColor = PropBag.ReadProperty("ForeColor", vbBlack)
    miBackColor = PropBag.ReadProperty("BackColor", vbWhite)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "Direction", miDirection, LabelVertUp
    PropBag.WriteProperty "Alignment", miAlignment, vbLeftJustify
    PropBag.WriteProperty "Caption", msCaption, vbNullString
    PropBag.WriteProperty "Font", UserControl.Font
    PropBag.WriteProperty "ForeColor", miForeColor, vbBlack
    PropBag.WriteProperty "BackColor", miBackColor, vbWhite
End Sub

Private Sub UserControl_Resize()
    UserControl.Refresh
End Sub

Private Sub UserControl_Paint()
    Const OBJ_FONT      As Long = 6&
    Dim iAngleX10       As Long         ' Angle (degrees) times 10.
    Dim X               As Long
    Dim Y               As Long
    Dim hFont           As Long
    Dim hNewFont        As Long
    Dim hOldFont        As Long
    Dim lf              As LOGFONT
    '
    ' We must make sure the UC stays set at ScaleMode = vbPixels.
    If miDirection = LabelVertUp Then   ' Up.
        iAngleX10 = 900&                ' Degrees x 10.
        X = UserControl.ScaleWidth / 2& - UserControl.TextHeight(msCaption) / 2& - 3&
        Select Case miAlignment
        Case vbLeftJustify:     Y = UserControl.ScaleHeight
        Case vbRightJustify:    Y = UserControl.TextWidth(msCaption)
        Case Else:              Y = UserControl.ScaleHeight / 2& + UserControl.TextWidth(msCaption) / 2&    ' vbCenter
        End Select
    Else                                ' Down.
        iAngleX10 = 2700&               ' Degrees x 10.
        X = UserControl.ScaleWidth / 2& + UserControl.TextHeight(msCaption) / 2& + 2&
        Select Case miAlignment
        Case vbLeftJustify:     Y = 0&
        Case vbRightJustify:    Y = UserControl.ScaleHeight - UserControl.TextWidth(msCaption)
        Case Else:              Y = UserControl.ScaleHeight / 2& - UserControl.TextWidth(msCaption) / 2&    ' vbCenter
        End Select
    End If
    '
'    UserControl.BackColor = miBackColor                                 ' Make sure we've got the correct BackColor.
'    UserControl.Cls                                                     ' Delete any prior drawn text.
    '
    SetTextColor UserControl.hDC, miForeColor                           ' Set our drawing color.
    '
    hFont = GetCurrentObject(UserControl.hDC, OBJ_FONT)                 ' Get the current HFONT handle.
    GetObjectA hFont, Len(lf), lf                                       ' Retrieve the LOGFONT structure from the font handle.
    lf.lfEscapement = iAngleX10                                         ' Change the font Angle (degrees).
    lf.lfOrientation = lf.lfEscapement                                  ' Should be same as lfEscapement.
    hNewFont = CreateFontIndirectA(lf)                                  ' Create a new font.
    hOldFont = SelectObject(UserControl.hDC, hNewFont)                  ' Select the font into the DC.
    '
    TextOutW UserControl.hDC, X, Y, StrPtr(msCaption), Len(msCaption)   ' Draw the text (unicode).
    '
    SelectObject UserControl.hDC, hOldFont                              ' Select back the previous font.
    DeleteObject hNewFont                                               ' Destroy the font object.
    '
'    UserControl.Picture = UserControl.Image     ' Tried this, but no cigar.
End Sub