fchrspace.frm

来自「很好的教程原代码！」· FRM 代码 · 共 251 行

VERSION 5.00
Begin VB.Form frmTextEffect 
   AutoRedraw      =   -1  'True
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Text Effect Demonstration"
   ClientHeight    =   2085
   ClientLeft      =   5115
   ClientTop       =   2745
   ClientWidth     =   6585
   BeginProperty Font 
      Name            =   "Arial"
      Size            =   18
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "fChrSpace.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2085
   ScaleWidth      =   6585
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton cmdOK 
      Caption         =   "OK"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   5220
      TabIndex        =   0
      Top             =   1620
      Width           =   1275
   End
End
Attribute VB_Name = "frmTextEffect"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private m_bDoEffect As Boolean

Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function SetTextCharacterExtra Lib "gdi32" _
    (ByVal hdc As Long, _
    ByVal nCharExtra As Long) _
    As Long

Private Declare Function OffsetRect Lib "user32" _
    (lpRect As RECT, _
    ByVal x As Long, _
    ByVal y As Long) _
    As Long

Private Declare Function SetTextColor Lib "gdi32" _
    (ByVal hdc As Long, _
    ByVal crColor As Long) _
    As Long
    
Private Declare Function FillRect Lib "user32" _
    (ByVal hdc As Long, _
    lpRect As RECT, _
    ByVal hBrush As Long) _
    As Long

Private Declare Function CreateSolidBrush Lib "gdi32" _
    (ByVal crColor As Long) _
    As Long

Private Declare Function DeleteObject Lib "gdi32" _
    (ByVal hObject As Long) _
    As Long

Private Declare Function GetSysColor Lib "user32" _
    (ByVal nIndex 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 DrawText Lib "user32" Alias "DrawTextA" _
    (ByVal hdc As Long, _
    ByVal lpStr As String, _
    ByVal nCount As Long, _
    lpRect As RECT, _
    ByVal wFormat As Long) _
    As Long

Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" _
    (ByVal OLE_COLOR As Long, _
    ByVal HPALETTE As Long, _
    pccolorref As Long) _
    As Long

Private Const COLOR_BTNFACE = 15
Private Const DT_BOTTOM = &H8
Private Const DT_CALCRECT = &H400
Private Const DT_CENTER = &H1
Private Const DT_CHARSTREAM = 4
Private Const DT_DISPFILE = 6
Private Const DT_EXPANDTABS = &H40
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_INTERNAL = &H1000
Private Const DT_LEFT = &H0
Private Const DT_METAFILE = 5
Private Const DT_NOCLIP = &H100
Private Const DT_NOPREFIX = &H800
Private Const DT_PLOTTER = 0
Private Const DT_RASCAMERA = 3
Private Const DT_RASDISPLAY = 1
Private Const DT_RASPRINTER = 2
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TABSTOP = &H80
Private Const DT_TOP = &H0
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10
Private Const CLR_INVALID = -1

Private Type RECT
    left As Long
    tOp As Long
    Right As Long
    Bottom As Long
End Type

Private Sub TextEffect( _
        ByVal sText As String, _
        ByVal lX As Long, ByVal lY As Long, _
        Optional ByVal bLoop As Boolean = False, _
        Optional ByVal lStartSpacing As Long = 128, _
        Optional ByVal lEndSpacing As Long = -1, _
        Optional ByVal oColor As OLE_COLOR = vbWindowText _
        )
Dim i As Long
Dim x As Long
Dim lLen As Long
Dim lHDC As Long
Dim hBrush As Long
Static tR As RECT
Dim iDir As Long
Dim bNotFirstTime As Boolean
Dim lTime As Long
Dim lIter As Long
Dim bSlowDown As Boolean
Dim lCOlor As Long
Dim bDoIt As Boolean


    iDir = -1
    i = lStartSpacing
    tR.left = lX: tR.tOp = lY: tR.Right = lX: tR.Bottom = lY
    OleTranslateColor oColor, 0, lCOlor

    hBrush = CreateSolidBrush(GetSysColor(COLOR_BTNFACE))
    lLen = Len(sText)
    lHDC = Me.hdc
    SetTextColor lHDC, lCOlor
    bDoIt = True
    
    Do While m_bDoEffect And bDoIt
        lTime = timeGetTime
        If (i < -3) And Not (bLoop) And Not (bSlowDown) Then
            bSlowDown = True
            iDir = 1
            lIter = (i + 4)
        End If
        If (i > 128) Then iDir = -1
        If Not (bLoop) And iDir = 1 Then
            If (i = lEndSpacing) Then
                ' Stop
                bDoIt = False
            Else
                lIter = lIter - 1
                If (lIter <= 0) Then
                    i = i + iDir
                    lIter = (i + 4)
                End If
            End If
        Else
            i = i + iDir
        End If
        FillRect lHDC, tR, hBrush
        x = 32 - (i * lLen)
        SetTextCharacterExtra lHDC, i
        DrawText lHDC, sText, lLen, tR, DT_CALCRECT
        tR.Right = tR.Right + 4
        If (tR.Right > Me.ScaleWidth \ Screen.TwipsPerPixelX) Then tR.Right = Me.ScaleWidth \ Screen.TwipsPerPixelX
        DrawText lHDC, sText, lLen, tR, DT_LEFT
        Me.Refresh
        Do
            DoEvents
        Loop While (timeGetTime - lTime) < 20
    Loop
    DeleteObject hBrush

End Sub

Private Sub cmdOK_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    Me.Show
    Me.Refresh
    If Not (m_bDoEffect) Then
        Me.Cls
        Me.Font.Size = 26
        m_bDoEffect = True
        Me.Font.Name = "楷体_GB2312"
        TextEffect "Winodws API编程          ", 30, 10, , 128, -2, RGB(&H80, 0, 0)
        If m_bDoEffect Then
            Me.Font.Size = 14
            TextEffect "http://www.tup.tsinghua.edu.cn", 36, 52, , 128, , vb3DShadow
        End If
        If m_bDoEffect Then
            Me.Font.Name = "Tahoma"
            Me.Font.Size = 9
            Me.Font.Bold = False
            TextEffect "Email : [e-mail]  ", 49, 86, , 128, 3
        End If
        If m_bDoEffect Then
            TextEffect "", 49, 100, , 128, 2
        End If
        m_bDoEffect = False
    Else
        m_bDoEffect = False
    End If

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    m_bDoEffect = False
End Sub