Display text with various 3D effects

Category:

Forms and Controls

Type:

Controls

Difficulty:

Intermediate

Author: Anonymous

Version Compatibility: Visual Basic 6, Visual Basic 5

More information:

Flat, Raised, Sunken, Etched, Shadow, Outline effects. Change colours (text & background). Align text left, centre, right, top, bottom, middle.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
Option Explicit Enum itBackStyle itBackTransparent = 0 itBackOpaque End Enum Enum itBorderStyle itBorderNone = 0 itBorderSingle End Enum Enum itAlignment itAlignLeftTop = 0 itAlignLeftMiddle itAlignLeftBottom itAlignCentreTop itAlignCentreMiddle itAlignCentreBottom itAlignRightTop itAlignRightMiddle itAlignRightBottom End Enum Enum itAppearanceStyle itAppNone = 0 itFlat itRaised itSunken itShadow itEtched itChisel itEmbossed End Enum Private PixelTwips As Integer Public Event Click() Private mBackColColour As OLE_COLOR Private mBackStyle As itBackStyle Private mAppearance As itAppearanceStyle Private mBorderStyle As itBorderStyle Private mAlignment As itAlignment Private mBackColour As OLE_COLOR Private mBorderColour As OLE_COLOR Private mBorderWidth As Integer Private mText As String Private WithEvents mFont As StdFont

Code:

Public Property Get Text() As String
    Text = mText
End Property
Public Property Let Text(dat As String)
    mText = dat
    PropertyChanged "Text"
    Refresh
End Property

Public Property Let TextColour(dat As OLE_COLOR)
    UserControl.ForeColor = dat
    PropertyChanged "TextColour"
    Refresh
End Property

Public Property Get BackStyle() As itBackStyle
    BackStyle = mBackStyle
End Property
Public Property Let BackStyle(dat As itBackStyle)
    mBackStyle = dat
    PropertyChanged "BackStyle"
    Refresh
End Property

Public Property Get BackColour() As OLE_COLOR
    BackColour = UserControl.BackColor
End Property
Public Property Let BackColour(dat As OLE_COLOR)
    UserControl.BackColor = dat
    PropertyChanged "BackColour"
    Refresh
End Property

Public Property Get BorderStyle() As itBorderStyle
    BorderStyle = mBorderStyle
End Property
Public Property Let BorderStyle(dat As itBorderStyle)
    mBorderStyle = dat
    PropertyChanged "BorderStyle"
    Refresh
End Property

Public Property Get ScaleHeight() As Single
    ScaleHeight = UserControl.ScaleHeight
End Property

Public Property Get ScaleWidth() As Single
    ScaleWidth = UserControl.ScaleWidth
End Property

Public Property Get Alignment() As itAlignment
    Alignment = mAlignment
End Property
Public Property Let Alignment(dat As itAlignment)
    mAlignment = dat
    TextPos Me
    PropertyChanged "Alignment"
    Refresh
End Property

Public Sub TextPos(obj As itBox, Optional Gap As Integer)
Dim HalfWidth As Long
Dim HalfHeight As Long

HalfWidth = obj.TextWidth / 2
    HalfHeight = obj.TextHeight / 2
    Select Case obj.Alignment
        Case itAlignLeftTop
            obj.CurrentX = Gap
            obj.CurrentY = Gap
        Case itAlignLeftMiddle
            obj.CurrentX = Gap
            obj.CurrentY = obj.ScaleHeight / 2 - HalfHeight
        Case itAlignLeftBottom
            obj.CurrentX = Gap
            obj.CurrentY = obj.ScaleHeight - obj.TextHeight - Gap
        Case itAlignCentreTop
            obj.CurrentX = obj.ScaleWidth / 2 - HalfWidth
            obj.CurrentY = Gap
        Case itAlignCentreMiddle
            obj.CurrentX = obj.ScaleWidth / 2 - HalfWidth
            obj.CurrentY = obj.ScaleHeight / 2 - HalfHeight
        Case itAlignCentreBottom
            obj.CurrentX = obj.ScaleWidth / 2 - HalfWidth
            obj.CurrentY = obj.ScaleHeight - obj.TextHeight - Gap
        Case itAlignRightTop
            obj.CurrentX = obj.ScaleWidth - obj.TextWidth - Gap
            obj.CurrentY = Gap
        Case itAlignRightMiddle
            obj.CurrentX = obj.ScaleWidth - obj.TextWidth - Gap
            obj.CurrentY = obj.ScaleHeight / 2 - HalfHeight
        Case itAlignRightBottom
            obj.CurrentX = obj.ScaleWidth - obj.TextWidth - Gap
            obj.CurrentY = obj.ScaleHeight - obj.TextHeight - Gap
    End Select
End Sub

Public Property Get Appearance() As itAppearanceStyle
    Appearance = mAppearance
End Property
Public Property Let Appearance(dat As itAppearanceStyle)
    mAppearance = dat
    SetAppearance
    PropertyChanged "Appearance"
    Refresh
End Property
Public Property Get CurrentX() As Long
    CurrentX = UserControl.CurrentX
End Property
Public Property Let CurrentX(dat As Long)
    UserControl.CurrentX = dat
End Property
Public Property Get CurrentY() As Long
    CurrentY = UserControl.CurrentY
End Property
Public Property Let CurrentY(dat As Long)
    UserControl.CurrentY = dat
End Property
'
Private Sub SetAppearance()

Select Case Appearance
            Case itAppNone
            Case itFlat
                Line (0, 0)-(ScaleWidth - PixelTwips, ScaleHeight - PixelTwips), BorderColour, B
            Case itSunken
                Line (0, 0)-(ScaleWidth - PixelTwips, 0), BorderColour
                Line -(ScaleWidth - PixelTwips, ScaleHeight - PixelTwips), vbWhite
                Line -(0, ScaleHeight - PixelTwips), vbWhite
                Line -(0, 0), BorderColour
            Case itRaised
                Line (0, 0)-(ScaleWidth - PixelTwips, 0), vbWhite
                Line -(ScaleWidth - PixelTwips, ScaleHeight - PixelTwips), BorderColour
                Line -(0, ScaleHeight - PixelTwips), BorderColour
                Line -(0, 0), vbWhite
            Case itEmbossed
                Line (0, 0)-(ScaleWidth - PixelTwips, 0), BorderColour
                Line -(ScaleWidth - PixelTwips, ScaleHeight - PixelTwips), BorderColour
                Line -(0, ScaleHeight - PixelTwips), vbWhite
                Line -(0, 0), vbWhite
                Line (0 + PixelTwips, 0 + PixelTwips)-(ScaleWidth - PixelTwips - PixelTwips, 0 + PixelTwips), vbWhite
                Line -(ScaleWidth - PixelTwips - PixelTwips, ScaleHeight - PixelTwips - PixelTwips), vbWhite
                Line -(0 + PixelTwips, ScaleHeight - PixelTwips - PixelTwips), BorderColour
                Line -(0 + PixelTwips, 0 + PixelTwips), BorderColour
            Case itShadow
                Line (0, 0)-(ScaleWidth - PixelTwips * 7, ScaleHeight - PixelTwips * 7), BorderColour, B
                DrawWidth = 5
                Line (ScaleWidth - PixelTwips * 3, PixelTwips * 6)-(ScaleWidth - PixelTwips * 3, ScaleHeight - PixelTwips * 3), vbApplicationWorkspace
                Line -(PixelTwips * 6, ScaleHeight - PixelTwips * 3), vbApplicationWorkspace
                DrawWidth = 1
            Case itEtched
                Line (0, 0)-(ScaleWidth - PixelTwips, 0), BorderColour
                Line -(ScaleWidth - PixelTwips, ScaleHeight - PixelTwips), vbWhite
                Line -(0, ScaleHeight - PixelTwips), vbWhite
                Line -(0, 0), BorderColour
                Line (0 + PixelTwips, 0 + PixelTwips)-(ScaleWidth - PixelTwips - PixelTwips, 0 + PixelTwips), vbWhite
                Line -(ScaleWidth - PixelTwips - PixelTwips, ScaleHeight - PixelTwips - PixelTwips), BorderColour
                Line -(0 + PixelTwips, ScaleHeight - PixelTwips - PixelTwips), BorderColour
                Line -(0 + PixelTwips, 0 + PixelTwips), vbWhite
            Case itChisel
                Line (0, ScaleHeight - PixelTwips)-(ScaleWidth, ScaleHeight - PixelTwips), vbWhite
                Line (0, ScaleHeight - PixelTwips - PixelTwips)-(ScaleWidth, ScaleHeight - PixelTwips - PixelTwips), BorderColour
   End Select
   ' PrintText
End Sub

Private Sub PrintText()
        TextPos Me
        Print Text
End Sub

Public Property Get BorderColour() As OLE_COLOR
    BorderColour = mBorderColour
End Property
Public Property Let BorderColour(dat As OLE_COLOR)
    mBorderColour = dat
    PropertyChanged "BorderColour"
    Refresh
End Property

Public Property Get BorderWidth() As Integer
    BorderWidth = mBorderWidth
    If BorderWidth > 0 Then DrawWidth = UserControl.DrawWidth
End Property
Public Property Let BorderWidth(dat As Integer)
    If dat > 0 Then UserControl.DrawWidth = dat
    mBorderWidth = dat
    PropertyChanged "BorderWidth"
    Refresh
End Property

Public Property Get TextWidth() As Long
    TextWidth = UserControl.TextWidth(Text)
End Property

Public Property Get TextHeight() As Long
    TextHeight = UserControl.TextHeight(Text)
End Property

Private Sub UserControl_Click()
    RaiseEvent Click
End Sub

Private Sub UserControl_Paint()
    Cls
    PrintText
    If BorderWidth > 0 Then SetAppearance
End Sub

Public Property Get Font() As StdFont
   Set Font = mFont
End Property

Public Property Set Font(mnewFont As StdFont)
   With mFont
      .Bold = mnewFont.Bold
      .Italic = mnewFont.Italic
      .Name = mnewFont.Name
      .Size = mnewFont.Size
      .Strikethrough = mnewFont.Strikethrough
      .Underline = mnewFont.Underline
      .Weight = mnewFont.Weight
   End With
   PropertyChanged "Font"
End Property

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Alignment = PropBag.ReadProperty("Alignment", mAlignment)
    Appearance = PropBag.ReadProperty("Appearance", mAppearance)
    BorderColour = PropBag.ReadProperty("BorderColour", vbBlack)
    BorderWidth = PropBag.ReadProperty("BorderWidth", 1)
    Text = PropBag.ReadProperty("Text", "Text")
    BackColour = PropBag.ReadProperty("BackColour", UserControl.BackColor)
    TextColour = PropBag.ReadProperty("TextColour", UserControl.ForeColor)
    FontBold = PropBag.ReadProperty("FontBold", UserControl.FontBold)
    Font = PropBag.ReadProperty("Font", UserControl.Font)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "Alignment", mAlignment
    PropBag.WriteProperty "Appearance", mAppearance
    PropBag.WriteProperty "BorderColour", BorderColour
    PropBag.WriteProperty "BorderWidth", BorderWidth
    PropBag.WriteProperty "Text", Text
    PropBag.WriteProperty "BackColour", UserControl.BackColor
    PropBag.WriteProperty "TextColour", UserControl.ForeColor
    PropBag.WriteProperty "FontBold", UserControl.FontBold
    PropBag.WriteProperty "Font", UserControl.Font
End Sub

Private Sub UserControl_Initialize()
    PixelTwips = Screen.TwipsPerPixelX

Set mFont = New StdFont
   Set UserControl.Font = mFont

End Sub

Private Sub UserControl_InitProperties()

BorderColour = vbBlack
    Appearance = itFlat
    BorderWidth = 1
End Sub