textscr.ctl

翻滚文字的 ActiveX 控件

VERSION 5.00
Begin VB.UserControl TextScroller 
   ClientHeight    =   315
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1725
   ScaleHeight     =   21
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   115
   Begin VB.Timer tmrDisplay 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   360
      Top             =   0
   End
End
Attribute VB_Name = "TextScroller"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Public Enum scrollerDirection
    scrollerTopToBottom = 1
    scrollerBottomToTop = 2
End Enum

'Default Property Values:
Const m_def_Text = ""
Const m_def_Distance = 1
Const m_def_Direction = scrollerBottomToTop
'Property Variables:
Dim m_Text As String
Dim m_Distance As Integer
Dim m_Direction As scrollerDirection

'Event Declarations:
' Fires when all of the text has scrolled
' off the control.
Event ScrollingDone()

Private CurY As Single
' Erase the control.
Public Sub Clear()
    Cls
    Text = ""
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=tmrDisplay,tmrDisplay,-1,Interval
Public Property Get Interval() As Long
Attribute Interval.VB_Description = "Returns/sets the number of milliseconds between calls to a Timer control's Timer event."
    Interval = tmrDisplay.Interval
End Property

Public Property Let Interval(ByVal New_Interval As Long)
    tmrDisplay.Interval() = New_Interval
    PropertyChanged "Interval"
End Property

' Move the text a little bit.
Private Sub tmrDisplay_Timer()
    If Not Ambient.UserMode Then Exit Sub
    
    Cls
    CurrentY = CurY
    CurrentX = 0
    Print m_Text

    Select Case m_Direction
        Case scrollerTopToBottom
            CurY = CurY + m_Distance
            If CurY > ScaleHeight Then
                Enabled = False
                RaiseEvent ScrollingDone
            End If
        Case scrollerBottomToTop
            CurY = CurY - m_Distance
            If CurrentY < 0 Then
                Enabled = False
                RaiseEvent ScrollingDone
            End If
    End Select
End Sub
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    m_Direction = m_def_Direction
    m_Distance = m_def_Distance
    Set Font = Ambient.Font
    m_Text = m_def_Text
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    tmrDisplay.Interval = PropBag.ReadProperty("Interval", 0)
    tmrDisplay.Enabled = PropBag.ReadProperty("Enabled", True)
    m_Direction = PropBag.ReadProperty("Direction", m_def_Direction)
    m_Distance = PropBag.ReadProperty("Distance", m_def_Distance)
    UserControl.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
    UserControl.FontUnderline = PropBag.ReadProperty("FontUnderline", 0)
    UserControl.FontTransparent = PropBag.ReadProperty("FontTransparent", True)
    UserControl.FontStrikethru = PropBag.ReadProperty("FontStrikethru", 0)
    UserControl.FontSize = PropBag.ReadProperty("FontSize", 10)
    UserControl.FontName = PropBag.ReadProperty("FontName", "Times New Roman")
    UserControl.FontItalic = PropBag.ReadProperty("FontItalic", 0)
    UserControl.FontBold = PropBag.ReadProperty("FontBold", 0)
    Set Font = PropBag.ReadProperty("Font", Ambient.Font)
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    m_Text = PropBag.ReadProperty("Text", m_def_Text)
End Sub
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Interval", tmrDisplay.Interval, 0)
    Call PropBag.WriteProperty("Enabled", tmrDisplay.Enabled, True)
    Call PropBag.WriteProperty("Direction", m_Direction, m_def_Direction)
    Call PropBag.WriteProperty("Distance", m_Distance, m_def_Distance)
    Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, &H80000012)
    Call PropBag.WriteProperty("FontUnderline", UserControl.FontUnderline, 0)
    Call PropBag.WriteProperty("FontTransparent", UserControl.FontTransparent, True)
    Call PropBag.WriteProperty("FontStrikethru", UserControl.FontStrikethru, 0)
    Call PropBag.WriteProperty("FontSize", UserControl.FontSize, 0)
    Call PropBag.WriteProperty("FontName", UserControl.FontName, "")
    Call PropBag.WriteProperty("FontItalic", UserControl.FontItalic, 0)
    Call PropBag.WriteProperty("FontBold", UserControl.FontBold, 0)
    Call PropBag.WriteProperty("Font", Font, Ambient.Font)
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
    Call PropBag.WriteProperty("Text", m_Text, m_def_Text)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=tmrDisplay,tmrDisplay,-1,Enabled
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
    Enabled = tmrDisplay.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    tmrDisplay.Enabled() = New_Enabled
    PropertyChanged "Enabled"

    If tmrDisplay.Enabled Then
        Select Case m_Direction
            Case scrollerTopToBottom
'@                CurY = -m_Strings.Count * 1.2 * _
'@                    ScaleY(Font.Size, vbPoints, vbPixels)
CurY = -TextHeight(m_Text)
            Case scrollerBottomToTop
                CurY = ScaleHeight
        End Select
    End If
End Property
Public Property Get Direction() As scrollerDirection
    Direction = m_Direction
End Property

Public Property Let Direction(ByVal New_Direction As scrollerDirection)
    m_Direction = New_Direction
    PropertyChanged "Direction"
End Property

Public Property Get Distance() As Integer
    Distance = m_Distance
End Property

Public Property Let Distance(ByVal New_Distance As Integer)
    m_Distance = New_Distance
    PropertyChanged "Distance"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
    ForeColor = UserControl.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    UserControl.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontUnderline
Public Property Get FontUnderline() As Boolean
Attribute FontUnderline.VB_Description = "Returns/sets underline font styles."
    FontUnderline = UserControl.FontUnderline
End Property

Public Property Let FontUnderline(ByVal New_FontUnderline As Boolean)
    UserControl.FontUnderline() = New_FontUnderline
    PropertyChanged "FontUnderline"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontTransparent
Public Property Get FontTransparent() As Boolean
Attribute FontTransparent.VB_Description = "Returns/sets a value that determines whether background text/graphics on a Form, Printer or PictureBox are displayed."
    FontTransparent = UserControl.FontTransparent
End Property

Public Property Let FontTransparent(ByVal New_FontTransparent As Boolean)
    UserControl.FontTransparent() = New_FontTransparent
    PropertyChanged "FontTransparent"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontStrikethru
Public Property Get FontStrikethru() As Boolean
Attribute FontStrikethru.VB_Description = "Returns/sets strikethrough font styles."
    FontStrikethru = UserControl.FontStrikethru
End Property

Public Property Let FontStrikethru(ByVal New_FontStrikethru As Boolean)
    UserControl.FontStrikethru() = New_FontStrikethru
    PropertyChanged "FontStrikethru"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontSize
Public Property Get FontSize() As Single
Attribute FontSize.VB_Description = "Specifies the size (in points) of the font that appears in each row for the given level."
    FontSize = UserControl.FontSize
End Property

Public Property Let FontSize(ByVal New_FontSize As Single)
    UserControl.FontSize() = New_FontSize
    PropertyChanged "FontSize"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontName
Public Property Get FontName() As String
Attribute FontName.VB_Description = "Specifies the name of the font that appears in each row for the given level."
    FontName = UserControl.FontName
End Property

Public Property Let FontName(ByVal New_FontName As String)
    UserControl.FontName() = New_FontName
    PropertyChanged "FontName"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontItalic
Public Property Get FontItalic() As Boolean
Attribute FontItalic.VB_Description = "Returns/sets italic font styles."
    FontItalic = UserControl.FontItalic
End Property

Public Property Let FontItalic(ByVal New_FontItalic As Boolean)
    UserControl.FontItalic() = New_FontItalic
    PropertyChanged "FontItalic"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,FontBold
Public Property Get FontBold() As Boolean
Attribute FontBold.VB_Description = "Returns/sets bold font styles."
    FontBold = UserControl.FontBold
End Property

Public Property Let FontBold(ByVal New_FontBold As Boolean)
    UserControl.FontBold() = New_FontBold
    PropertyChanged "FontBold"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Font
Public Property Get Font() As Font
Attribute Font.VB_Description = "Returns a Font object."
Attribute Font.VB_UserMemId = -512
    Set Font = UserControl.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set UserControl.Font = New_Font
    PropertyChanged "Font"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
    BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    UserControl.BackColor() = New_BackColor
    PropertyChanged "BackColor"
End Property

Public Property Get Text() As String
    Text = m_Text
End Property

Public Property Let Text(ByVal New_Text As String)
    m_Text = New_Text
    PropertyChanged "Text"
End Property