module1.bas

100个vb编程实例,什么都有

Attribute VB_Name = "Module1"
Option Explicit

Public Const AW_HOR_POSITIVE = &H1
Public Const AW_HOR_NEGATIVE = &H2
Public Const AW_VER_POSITIVE = &H4
Public Const AW_VER_NEGATIVE = &H8
Public Const AW_CENTER = &H10
Public Const AW_HIDE = &H10000
Public Const AW_ACTIVATE = &H20000
Public Const AW_SLIDE = &H40000
Public Const AW_BLEND = &H80000
Public Declare Function AnimateWindow Lib "user32" _
    (ByVal hWnd As Long, _
    ByVal dwTime As Long, ByVal dwFlags As Long) As Long

Public Const WM_PRINTCLIENT = &H318

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)

Public Declare Function GetWindowLong Lib "user32" Alias _
    "GetWindowLongA" (ByVal hWnd As Long, _
    ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias _
    "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = (-4)

Public Declare Function GetProp Lib "user32" Alias "GetPropA" _
    (ByVal hWnd As Long, ByVal lpString As String) As Long
Public Declare Function SetProp Lib "user32" Alias "SetPropA" _
    (ByVal hWnd As Long, ByVal lpString As String, _
    ByVal hData As Long) As Long
Public Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _
    (ByVal hWnd As Long, ByVal lpString As String) As Long

Public Declare Function CallWindowProc Lib "user32" Alias _
    "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
    ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long

Public Declare Function OleTranslateColor _
    Lib "oleaut32.dll" _
    (ByVal lOleColor As Long, _
    ByVal lHPalette As Long, _
    lColorRef As Long) As Long


Public Function TranslateColor(inCol As Long) As Long

    Dim retCol As Long
    OleTranslateColor inCol, 0&, retCol
    TranslateColor = retCol
End Function

Public Function AnimWndProc(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

    Dim lProc As Long
    Dim lPtr As Long
    Dim frm As frmAnim

    lProc = GetProp(hWnd, "ExAnimWndProc")
    lPtr = GetProp(hWnd, "ExAnimWndPtr")

    'Catch the WM_PRINTCLIENT message so the form
    'won't look like garbage when it appears.
    If wMsg = WM_PRINTCLIENT Then
        CopyMemory frm, lPtr, 4
        frm.PrintClient wParam, lParam
        CopyMemory frm, 0&, 4
    End If

    AnimWndProc = CallWindowProc(lProc, hWnd, wMsg, wParam, lParam)

End Function

Public Sub SubclassAnim(frm As frmAnim)

    Dim l As Long

    If GetProp(frm.hWnd, "ExAnimWndProc") <> 0 Then
        'Already subclassed
        Exit Sub
    End If

    l = GetWindowLong(frm.hWnd, GWL_WNDPROC)
    SetProp frm.hWnd, "ExAnimWndProc", l
    SetProp frm.hWnd, "ExAnimWndPtr", ObjPtr(frm)

    SetWindowLong frm.hWnd, GWL_WNDPROC, AddressOf AnimWndProc

End Sub

Public Sub UnSubclassAnim(frm As frmAnim)

    Dim l As Long

    l = GetProp(frm.hWnd, "ExAnimWndProc")
    If l = 0 Then
        'Isn't subclassed anyway
        Exit Sub
    End If

    SetWindowLong frm.hWnd, GWL_WNDPROC, l
    RemoveProp frm.hWnd, "ExAnimWndProc"
    RemoveProp frm.hWnd, "ExAnimWndPtr"

End Sub