textanimation.ctl

vb编程的一个文本动画程序 可以实现动画文字

Private Function GradientBackground(picBox As PictureBox)
Dim RedFrom As Integer
Dim GreenFrom As Integer
Dim BlueFrom As Integer
Dim RedTo As Integer
Dim GreenTo As Integer
Dim BlueTo As Integer
Dim rgncnt As Integer
Dim iheight As Long

  RedFrom = m_backcolorStart And RGB(255, 0, 0)
  GreenFrom = (m_backcolorStart And RGB(0, 255, 0)) / 256
  BlueFrom = (m_backcolorStart And RGB(0, 0, 255)) / 65536
  RedTo = m_backcolorEnd And RGB(255, 0, 0)
  GreenTo = (m_backcolorEnd And RGB(0, 255, 0)) / 256
  BlueTo = (m_backcolorEnd And RGB(0, 0, 255)) / 65536
    
  For rgncnt = 1 To 256
    picBox.Line (-1, rgncnt * (Int(picBox.ScaleHeight / 256) + 1))-(picBox.ScaleWidth, rgncnt * (Int(picBox.ScaleHeight / 256) + 1) + (Int(picBox.ScaleHeight / 256) + 1)), RGB(RedTo - ((RedTo - RedFrom) * (rgncnt / 256)), GreenTo - ((GreenTo - GreenFrom) * (rgncnt / 256)), BlueTo - ((BlueTo - BlueFrom) * (rgncnt / 256))), BF
  Next rgncnt
    
End Function



'---------------------------------------------------------------------------
' Usercontrol events
'---------------------------------------------------------------------------

Private Sub UserControl_Initialize()
Dim iLine As Integer
Dim x As Variant
    
    UserControl.ScaleMode = vbPixels
    
    picBuffer.ScaleMode = vbPixels
    picBuffer.ForeColor = vbWhite
    picBuffer.BackColor = vbBlack
    picBuffer.AutoRedraw = True
    picBuffer.Visible = False
    ReDrawTimer.Enabled = True
    
    On Error Resume Next
    x = UserControl.Parent
    If Err.Number = 398 Then
      ' We are in design mode
      AddMessage "design1", "Edwin", "Arial", vbBlue, vbYellow, 24, 24, 100, 100, 100, 100, 0, 360, , 0, 300
      AddMessage "design2", "Vermeer", "Arial", vbBlue, vbGreen, 1, 100, 100, 0, 0, 170, 0, 0, , 0, 300
      AddMessage "design3", "Edwin", "Arial", vbYellow, vbBlue, 24, 24, 100, 100, 100, 100, 0, 360, , 300, 300
      AddMessage "design4", "Vermeer", "Arial", vbGreen, vbBlue, 100, 1, 0, 100, 170, 0, 0, 0, , 300, 300
      AddMessage "design5", "If you speak dutch, then please visit my homepage at www.beursmonitor.com", "Brush Script MT", vbGreen, vbWhite, 32, 32, 300, -900, 0, 0, 0, 0, , 0, 600
    End If
    
End Sub


Private Sub UserControl_Show()
    
    GradientBackground picBackBuffer

End Sub



Private Sub UserControl_Resize()
    
    picBackBuffer.Left = 0
    picBackBuffer.Top = 0
    picBackBuffer.Height = UserControl.ScaleHeight
    picBackBuffer.Width = UserControl.ScaleWidth
    
    picOut.Left = 0
    picOut.Top = 0
    picOut.Height = UserControl.ScaleHeight
    picOut.Width = UserControl.ScaleWidth

    picBuffer.Left = 0
    picBuffer.Top = 0
    picBuffer.Height = UserControl.ScaleHeight
    picBuffer.Width = UserControl.ScaleWidth
      
    GradientBackground picBackBuffer
    
End Sub



'---------------------------------------------------------------------------
' Executing Methods
'---------------------------------------------------------------------------

Public Sub AddMessage( _
       ByVal MessageID As String, _
       Optional ByVal MessageText As String, _
       Optional ByVal MessageFontName As String, _
       Optional ByVal MessageFontColorStart As OLE_COLOR, _
       Optional ByVal MessageFontColorEnd As OLE_COLOR, _
       Optional ByVal MessageFontSizeStart As Integer, _
       Optional ByVal MessageFontSizeEnd As Integer, _
       Optional ByVal MessageLeftStart As Integer, _
       Optional ByVal MessageLeftEnd As Integer, _
       Optional ByVal MessageTopStart As Integer, _
       Optional ByVal MessageTopEnd As Integer, _
       Optional ByVal MessageFontRotationStart As Integer, _
       Optional ByVal MessageFontRotationEnd As Integer, _
       Optional ByVal BeforeMessageID As Variant, _
       Optional ByVal MessageIntervalStart As Long = 0, _
       Optional ByVal MessageIntervalCount As Long = 0 _
       )

Dim iM As Long
Dim i As Long


   If IsMissing(MessageText) Then MessageText = "Edwin Vermeer"
   If IsMissing(MessageFontName) Then MessageFontName = "Ariel"
   If IsMissing(MessageFontColorStart) Then MessageFontColorStart = vbBlue
   If IsMissing(MessageFontColorEnd) Then MessageFontColorEnd = vbWhite
   If IsMissing(MessageFontSizeStart) Then MessageFontSizeStart = 8
   If IsMissing(MessageFontSizeEnd) Then MessageFontSizeEnd = 16
   If IsMissing(MessageLeftStart) Then MessageLeftStart = picBuffer.ScaleWidth
   If IsMissing(MessageLeftEnd) Then MessageLeftEnd = 0
   If IsMissing(MessageTopStart) Then MessageTopStart = picBuffer.ScaleHeight
   If IsMissing(MessageTopEnd) Then MessageTopEnd = 0
   If IsMissing(MessageFontRotationStart) Then MessageFontRotationStart = 0
   If IsMissing(MessageFontRotationEnd) Then MessageFontRotationEnd = 0
   If IsMissing(MessageIntervalStart) Then MessageIntervalStart = 0
   If IsMissing(MessageIntervalCount) Then MessageIntervalCount = CounterMax
   
   ReDim Preserve m_messages(0 To MessageCount + 1) As TextMessage
   If Not (IsMissing(BeforeMessageID)) Then
      iM = MessageIndex(BeforeMessageID)
      If (iM > -1) Then ' insert
         For i = MessageCount To iM + 1 Step -1
            LSet m_messages(i) = m_messages(i - 1)
         Next i
      End If
    Else
      iM = MessageCount
    End If
    With m_messages(iM)
       .MessageID = MessageID
       .MessageText = MessageText
       .MessageFontName = MessageFontName
       .MessageFontColorStart = MessageFontColorStart
       .MessageFontColorEnd = MessageFontColorEnd
       .MessageFontSizeStart = MessageFontSizeStart
       .MessageFontSizeEnd = MessageFontSizeEnd
       .MessageLeftStart = MessageLeftStart
       .MessageLeftEnd = MessageLeftEnd
       .MessageTopStart = MessageTopStart
       .MessageTopEnd = MessageTopEnd
       .MessageFontRotationStart = MessageFontRotationStart * 10
       .MessageFontRotationEnd = MessageFontRotationEnd * 10
       .MessageIntervalStart = MessageIntervalStart
       .MessageIntervalCount = MessageIntervalCount
    End With

End Sub


Public Sub RemoveMessage(ByVal MessageID As Variant)
Dim iM As Integer
Dim i As Long
   
   iM = MessageIndex(MessageID)
   If (iM > -1) Then
      If MessageCount > 0 Then
         For i = iM To MessageCount - 1
             LSet m_messages(i) = m_messages(i + 1)
         Next i
         ReDim Preserve m_messages(0 To MessageCount - 1) As TextMessage
      End If
   End If
   
End Sub

Public Sub RemoveAllMessages()
  ReDim m_messages(0) As TextMessage
End Sub

'---------------------------------------------------------------------------
' Getting and Setting the properties
'---------------------------------------------------------------------------
Private Sub UserControl_InitProperties()

    m_backcolorStart = m_def_backcolorStart
    m_backcolorEnd = m_def_backcolorEnd
    m_Border = m_def_Border
    m_Enabled = m_def_Enabled
    m_counter = m_def_counter
    m_counterMax = m_def_counterMax
    m_Speed = m_def_Speed
    
End Sub


Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    m_backcolorStart = PropBag.ReadProperty("BackColorStart", m_def_backcolorStart)
    m_backcolorEnd = PropBag.ReadProperty("BackColorEnd", m_def_backcolorEnd)
    m_Border = PropBag.ReadProperty("Border", m_def_Border)
    m_Enabled = PropBag.ReadProperty("Enabled", m_def_Enabled)
    m_counter = PropBag.ReadProperty("Counter", m_def_counter)
    m_counterMax = PropBag.ReadProperty("CounterMax", m_def_counterMax)
    m_Speed = PropBag.ReadProperty("Speed", m_def_Speed)

End Sub


Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("BackColor", m_backcolorStart, m_def_backcolorStart)
    Call PropBag.WriteProperty("BackColor", m_backcolorEnd, m_def_backcolorEnd)
    Call PropBag.WriteProperty("Border", m_Border, m_def_Border)
    Call PropBag.WriteProperty("Enabled", m_Enabled, m_def_Enabled)
    Call PropBag.WriteProperty("Counter", m_counter, m_def_counter)
    Call PropBag.WriteProperty("CounterMax", m_counterMax, m_def_counterMax)
    Call PropBag.WriteProperty("Speed", m_Speed, m_def_Speed)

End Sub


' .Counter
Public Property Get Counter() As Long
Attribute Counter.VB_ProcData.VB_Invoke_Property = "General"
    Counter = m_counter
End Property
Public Property Let Counter(ByVal New_Counter As Long)
    m_counter = New_Counter
    PropertyChanged "Counter"
End Property


' .CounterMax
Public Property Get CounterMax() As Long
Attribute CounterMax.VB_ProcData.VB_Invoke_Property = "General"
    CounterMax = m_counterMax
End Property
Public Property Let CounterMax(ByVal New_CounterMax As Long)
    m_counterMax = New_CounterMax
    PropertyChanged "CounterMax"
End Property


' .BackColorStart
Public Property Get BackColorStart() As OLE_COLOR
    BackColorStart = m_backcolorStart
End Property
Public Property Let BackColorStart(ByVal New_BackColorStart As OLE_COLOR)
    m_backcolorStart = New_BackColorStart
    PropertyChanged "BackColorStart"
    UserControl_Resize
End Property


' .BackColorEnd
Public Property Get BackColorEnd() As OLE_COLOR
    BackColorEnd = m_backcolorEnd
End Property
Public Property Let BackColorEnd(ByVal New_BackColorEnd As OLE_COLOR)
    m_backcolorEnd = New_BackColorEnd
    PropertyChanged "BackColorEnd"
    UserControl_Resize
End Property


' . Border
Public Property Get Border() As SPBorderStyle
    Border = m_Border
End Property
Public Property Let Border(ByVal New_Border As SPBorderStyle)
    m_Border = New_Border
    PropertyChanged "Border"
    UserControl.BorderStyle = m_Border
End Property


' .Enabled
Public Property Get Enabled() As Boolean