textanimation.ctl

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

VERSION 5.00
Begin VB.UserControl TextAnimation 
   ClientHeight    =   3795
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4500
   PropertyPages   =   "TextAnimation.ctx":0000
   ScaleHeight     =   3795
   ScaleWidth      =   4500
   ToolboxBitmap   =   "TextAnimation.ctx":001E
   Begin VB.Timer ReDrawTimer 
      Interval        =   20
      Left            =   180
      Top             =   3120
   End
   Begin VB.PictureBox picBackBuffer 
      AutoRedraw      =   -1  'True
      BorderStyle     =   0  'None
      FillColor       =   &H00404040&
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   12
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   2535
      Left            =   1380
      ScaleHeight     =   2535
      ScaleWidth      =   2835
      TabIndex        =   2
      Top             =   960
      Visible         =   0   'False
      Width           =   2835
   End
   Begin VB.PictureBox picBuffer 
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      FillColor       =   &H00404040&
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   12
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   2475
      Left            =   780
      ScaleHeight     =   2475
      ScaleWidth      =   2895
      TabIndex        =   1
      Top             =   540
      Visible         =   0   'False
      Width           =   2895
   End
   Begin VB.PictureBox picOut 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00004000&
      BorderStyle     =   0  'None
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   11.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   2535
      Left            =   240
      ScaleHeight     =   2535
      ScaleWidth      =   2895
      TabIndex        =   0
      Top             =   180
      Width           =   2895
   End
End
Attribute VB_Name = "TextAnimation"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
Option Explicit

Private Declare Function BitBlt Lib "gdi32" ( _
   ByVal hdcDest As Long, ByVal XDest As Long, _
   ByVal YDest As Long, ByVal nWidth As Long, _
   ByVal nHeight As Long, ByVal hDCSrc As Long, _
   ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) _
   As Long
Private Const SRCCOPY = &HCC0020

Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const LF_FACESIZE = 32
Private Const LOGPIXELSX = 88    '  Logical pixels/inch in X
Private Const LOGPIXELSY = 90    '  Logical pixels/inch in Y
Private Const ANTIALIASED_QUALITY = 4 ' Ensure font edges are smoothed if system is set to smooth font edges
Private 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) As Byte
End Type
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) 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
Private 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 Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long

Private Type TextMessage
    MessageID As String
    MessageText As String
    MessageFontName As String
    MessageFontColorStart As OLE_COLOR
    MessageFontColorEnd As OLE_COLOR
    MessageFontSizeStart As Integer
    MessageFontSizeEnd As Integer
    MessageLeftStart As Integer
    MessageLeftEnd As Integer
    MessageTopStart As Integer
    MessageTopEnd As Integer
    MessageFontRotationStart As Integer
    MessageFontRotationEnd As Integer
    MessageIntervalStart As Long
    MessageIntervalCount As Long
End Type

Private m_messages() As TextMessage

Public Enum SPBorderStyle
    [None] = 0
    [Fixed Single] = 1
End Enum

Dim m_counter As Long
Const m_def_counter = 0
Dim m_counterMax As Long
Const m_def_counterMax = 600
Dim m_backcolorStart As OLE_COLOR
Const m_def_backcolorStart = 8388607  'RGB(255, 255, 127)
Dim m_backcolorEnd As OLE_COLOR
Const m_def_backcolorEnd = 16744319   'RGB(127, 127, 255)
Dim m_Border As Integer
Const m_def_Border = [None]
Dim m_Enabled As Boolean
Const m_def_Enabled = True
Dim m_Speed As Integer
Const m_def_Speed = 20

Event BeforeDraw(PictureBuffer As PictureBox)
Event AfterDraw(PictureBuffer As PictureBox)
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single, messages() As String)
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single, messages() As String)
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single, messages() As String)



Private Sub RedrawTimer_Timer()
On Error Resume Next
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 l As Long
Dim j As Long
Dim tLF As LOGFONT
Dim hFnt As Long
Dim hFntOld As Long
Dim lR As Long
Dim iChar As Integer

    m_counter = m_counter + 1
    If Counter > CounterMax Then Counter = 0
    l = BitBlt(picBuffer.hdc, 0, picBuffer.ScaleTop, picBuffer.ScaleWidth, picBuffer.ScaleHeight, picBackBuffer.hdc, 0, 0, SRCCOPY)
    RaiseEvent BeforeDraw(picBuffer)
    For j = 0 To MessageCount
      If m_messages(j).MessageIntervalStart <= m_counter And m_messages(j).MessageIntervalStart + m_messages(j).MessageIntervalCount > m_counter Then
        ' The text color
        RedFrom = m_messages(j).MessageFontColorStart And RGB(255, 0, 0)
        GreenFrom = (m_messages(j).MessageFontColorStart And RGB(0, 255, 0)) / 256
        BlueFrom = (m_messages(j).MessageFontColorStart And RGB(0, 0, 255)) / 65536
        RedTo = m_messages(j).MessageFontColorEnd And RGB(255, 0, 0)
        GreenTo = (m_messages(j).MessageFontColorEnd And RGB(0, 255, 0)) / 256
        BlueTo = (m_messages(j).MessageFontColorEnd And RGB(0, 0, 255)) / 65536
        picBuffer.ForeColor = RGB(RedFrom - (RedFrom - RedTo) * (m_counter - m_messages(j).MessageIntervalStart) / m_messages(j).MessageIntervalCount, GreenFrom - (GreenFrom - GreenTo) * (m_counter - m_messages(j).MessageIntervalStart) / m_messages(j).MessageIntervalCount, BlueFrom - (BlueFrom - BlueTo) * (m_counter - m_messages(j).MessageIntervalStart) / m_messages(j).MessageIntervalCount)
        ' The text size
        tLF.lfHeight = MulDiv((m_messages(j).MessageFontSizeStart - (m_messages(j).MessageFontSizeStart - m_messages(j).MessageFontSizeEnd) * (m_counter - m_messages(j).MessageIntervalStart) / m_messages(j).MessageIntervalCount), (GetDeviceCaps(picBuffer.hdc, LOGPIXELSY)), 72)
        ' The rotation of the font
        tLF.lfEscapement = m_messages(j).MessageFontRotationStart - (m_messages(j).MessageFontRotationStart - m_messages(j).MessageFontRotationEnd) * (m_counter - m_messages(j).MessageIntervalStart) / m_messages(j).MessageIntervalCount
        
        ' The text font
        For iChar = 1 To Len(m_messages(j).MessageFontName)
            tLF.lfFaceName(iChar - 1) = CByte(Asc(Mid$(m_messages(j).MessageFontName, iChar, 1)))
        Next iChar
        ' Other font properties (for now default)
        tLF.lfItalic = picBuffer.Font.Italic
        If (picBuffer.Font.Bold) Then
            tLF.lfWeight = FW_BOLD
        Else
            tLF.lfWeight = FW_NORMAL
        End If
        tLF.lfUnderline = picBuffer.Font.Underline
        tLF.lfStrikeOut = picBuffer.Font.Strikethrough
        tLF.lfCharSet = picBuffer.Font.Charset
        tLF.lfQuality = ANTIALIASED_QUALITY
        ' Print the text at the right location
        hFnt = CreateFontIndirect(tLF)
        If (hFnt <> 0) Then
          hFntOld = SelectObject(picBuffer.hdc, hFnt)
          lR = TextOut(picBuffer.hdc, m_messages(j).MessageLeftStart - (m_messages(j).MessageLeftStart - m_messages(j).MessageLeftEnd) * (m_counter - m_messages(j).MessageIntervalStart) / m_messages(j).MessageIntervalCount, m_messages(j).MessageTopStart - (m_messages(j).MessageTopStart - m_messages(j).MessageTopEnd) * (m_counter - m_messages(j).MessageIntervalStart) / m_messages(j).MessageIntervalCount, m_messages(j).MessageText, lstrlen(m_messages(j).MessageText))
          SelectObject picBuffer.hdc, hFntOld
          DeleteObject hFnt
        End If
      End If
    Next j
    RaiseEvent AfterDraw(picBuffer)
    l = BitBlt(picOut.hdc, 0, picOut.ScaleTop, picOut.ScaleWidth, picOut.ScaleHeight, picBuffer.hdc, 0, 0, SRCCOPY)
    picOut.Refresh

End Sub


Private Sub picOut_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim messages() As String
  BuildAray x / Screen.TwipsPerPixelX, y / Screen.TwipsPerPixelY, messages
  RaiseEvent MouseDown(Button, Shift, x / Screen.TwipsPerPixelX, y / Screen.TwipsPerPixelY, messages)
End Sub

Private Sub picOut_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim messages() As String
'  BuildAray x / Screen.TwipsPerPixelX, y / Screen.TwipsPerPixelY, messages
'  RaiseEvent MouseMove(Button, Shift, x / Screen.TwipsPerPixelX, y / Screen.TwipsPerPixelY, messages)
End Sub

Private Sub picOut_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim messages() As String
  BuildAray x / Screen.TwipsPerPixelX, y / Screen.TwipsPerPixelY, messages
  RaiseEvent MouseUp(Button, Shift, x / Screen.TwipsPerPixelX, y / Screen.TwipsPerPixelY, messages)
End Sub

Private Sub BuildAray(x As Single, y As Single, messages() As String)
Dim j As Integer
Dim t As Integer

  For j = 0 To MessageCount
    If m_messages(j).MessageIntervalStart <= m_counter And m_messages(j).MessageIntervalStart + m_messages(j).MessageIntervalCount > m_counter Then
      t = m_messages(j).MessageLeftStart - (m_messages(j).MessageLeftStart - m_messages(j).MessageLeftEnd) * (m_counter - m_messages(j).MessageIntervalStart) / m_messages(j).MessageIntervalCount
      If x >= t And x <= t + MessageWidth(j) Then
        t = m_messages(j).MessageTopStart - (m_messages(j).MessageTopStart - m_messages(j).MessageTopEnd) * (m_counter - m_messages(j).MessageIntervalStart) / m_messages(j).MessageIntervalCount
        If y >= t And y <= t + MessageHeight(j) Then
          On Error Resume Next
          ReDim Preserve messages(UBound(messages) + 1) As String
          If Err.Number = 9 Then ReDim Preserve messages(0)
          On Error GoTo 0
          messages(UBound(messages)) = MessageID(j)
        End If
      End If
    End If
  Next j
  
End Sub