Tuesday, June 26, 2012

VB6 Animasi: Menggunakan Fungsi API AnimateWindow

VB6 AnimateWindow - Dengan menggunakan fungsi API AnimateWindow, kita dapat membuat efek-efek animasi yang sangat halus. Fungsi API AnimateWindow sendiri tidak bisa digunakan begitu saja, tetapi ia membutuhkan bantuan fungsi API yang lain untuk melakukan SubClassing guna memproses Message WM_PRINT atau WM_PRINTCLIENT agar form yang sedang melakukan animasi terefresh dengan baik, dengan demikian form akan ditampilkan secara sempurna dan terhindar dari warna hitam yang menutupi keseluruhan form tersebut.

Modul AnimateWindow di bawah ini diperoleh dari situs Eduardo A. Morcillo. Nah, pada akhirnya untuk mempermudah penggunaan saya tambahkan beberapa baris Enum Animation, seperti di bawah ini:

Public Enum Animation
'// ACTIVATE
    ACTIVATE_SLIDE_FROM_TOP = (AW_ACTIVATE Or AW_SLIDE Or AW_VER_POSITIVE)
    ACTIVATE_SLIDE_FROM_BOTTOM = (AW_ACTIVATE Or AW_SLIDE Or AW_VER_NEGATIVE)
    ACTIVATE_SLIDE_FROM_LEFT = (AW_ACTIVATE Or AW_SLIDE Or AW_HOR_POSITIVE)
    ACTIVATE_SLIDE_FROM_RIGHT = (AW_ACTIVATE Or AW_SLIDE Or AW_HOR_NEGATIVE)
    ACTIVATE_SLIDE_EXPAND_FROM_TOP_LEFT = (AW_ACTIVATE Or AW_SLIDE Or AW_HOR_POSITIVE Or AW_VER_POSITIVE)
    ACTIVATE_SLIDE_EXPAND_FROM_BOTTOM_RIGHT = (AW_ACTIVATE Or AW_SLIDE Or AW_HOR_NEGATIVE Or AW_VER_NEGATIVE)
    ACTIVATE_SLIDE_EXPAND_FROM_TOP_RIGHT = (AW_ACTIVATE Or AW_SLIDE Or AW_HOR_NEGATIVE Or AW_VER_POSITIVE)
    ACTIVATE_SLIDE_EXPAND_FROM_BOTTOM_LEFT = (AW_ACTIVATE Or AW_SLIDE Or AW_HOR_POSITIVE Or AW_VER_NEGATIVE)
    ACTIVATE_SLIDE_EXPAND_FROM_CENTER = (AW_ACTIVATE Or AW_SLIDE Or AW_CENTER)
    ACTIVATE_SLIDE_FADE_TRANSITION = (AW_ACTIVATE Or AW_BLEND)
'// DEACTIVATE
    DEACTIVATE_SLIDE_FADE_TRANSITION = (AW_HIDE Or AW_BLEND)
    DEACTIVATE_SLIDE_TO_TOP = (AW_HIDE Or AW_SLIDE Or AW_VER_NEGATIVE)
    DEACTIVATE_SLIDE_TO_BOTTOM = (AW_HIDE Or AW_SLIDE Or AW_VER_POSITIVE)
    DEACTIVATE_SLIDE_TO_LEFT = (AW_HIDE Or AW_SLIDE Or AW_HOR_NEGATIVE)
    DEACTIVATE_SLIDE_TO_RIGHT = (AW_HIDE Or AW_SLIDE Or AW_HOR_POSITIVE)
    DEACTIVATE_SLIDE_SHRINK_TO_TOP_LEFT = (AW_HIDE Or AW_SLIDE Or AW_HOR_NEGATIVE Or AW_VER_NEGATIVE)
    DEACTIVATE_SLIDE_SHRINK_TO_BOTTOM_RIGHT = (AW_HIDE Or AW_SLIDE Or AW_HOR_POSITIVE Or AW_VER_POSITIVE)
    DEACTIVATE_SLIDE_SHRINK_TO_TOP_RIGHT = (AW_HIDE Or AW_SLIDE Or AW_HOR_POSITIVE Or AW_VER_NEGATIVE)
    DEACTIVATE_SLIDE_SHRINK_TO_BOTTOM_LEFT = (AW_HIDE Or AW_SLIDE Or AW_HOR_NEGATIVE Or AW_VER_POSITIVE)
    DEACTIVATE_SLIDE_SHRINK_TO_CENTER = (AW_HIDE Or AW_SLIDE Or AW_CENTER)
End Enum
Adapun modul lengkapnya adalah sebagai berikut: 
Option Explicit

Const GWL_WNDPROC = (-4)

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Const PROP_PREVPROC = "PrevProc"
Const PROP_FORM = "FormObject"

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

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal DestL As Long)

Const WM_PRINTCLIENT = &H318

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function apiOleTranslateColor Lib "oleaut32" Alias "OleTranslateColor" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long

Enum AnimateWindowFlags
    AW_HOR_POSITIVE = &H1
    AW_HOR_NEGATIVE = &H2
    AW_VER_POSITIVE = &H4
    AW_VER_NEGATIVE = &H8
    AW_CENTER = &H10
    AW_HIDE = &H10000
    AW_ACTIVATE = &H20000
    AW_SLIDE = &H40000
    AW_BLEND = &H80000
End Enum

Private Declare Function apiAnimateWindow Lib "user32" Alias "AnimateWindow" (ByVal hWnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal Mul As Long, ByVal Nom As Long, ByVal Den As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC 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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private 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 Enum Animation
'// ACTIVATE
    ACTIVATE_SLIDE_FROM_TOP = (AW_ACTIVATE Or AW_SLIDE Or AW_VER_POSITIVE)
    ACTIVATE_SLIDE_FROM_BOTTOM = (AW_ACTIVATE Or AW_SLIDE Or AW_VER_NEGATIVE)
    ACTIVATE_SLIDE_FROM_LEFT = (AW_ACTIVATE Or AW_SLIDE Or AW_HOR_POSITIVE)
    ACTIVATE_SLIDE_FROM_RIGHT = (AW_ACTIVATE Or AW_SLIDE Or AW_HOR_NEGATIVE)
    ACTIVATE_SLIDE_EXPAND_FROM_TOP_LEFT = (AW_ACTIVATE Or AW_SLIDE Or AW_HOR_POSITIVE Or AW_VER_POSITIVE)
    ACTIVATE_SLIDE_EXPAND_FROM_BOTTOM_RIGHT = (AW_ACTIVATE Or AW_SLIDE Or AW_HOR_NEGATIVE Or AW_VER_NEGATIVE)
    ACTIVATE_SLIDE_EXPAND_FROM_TOP_RIGHT = (AW_ACTIVATE Or AW_SLIDE Or AW_HOR_NEGATIVE Or AW_VER_POSITIVE)
    ACTIVATE_SLIDE_EXPAND_FROM_BOTTOM_LEFT = (AW_ACTIVATE Or AW_SLIDE Or AW_HOR_POSITIVE Or AW_VER_NEGATIVE)
    ACTIVATE_SLIDE_EXPAND_FROM_CENTER = (AW_ACTIVATE Or AW_SLIDE Or AW_CENTER)
    ACTIVATE_SLIDE_FADE_TRANSITION = (AW_ACTIVATE Or AW_BLEND)
'// DEACTIVATE
    DEACTIVATE_SLIDE_FADE_TRANSITION = (AW_HIDE Or AW_BLEND)
    DEACTIVATE_SLIDE_TO_TOP = (AW_HIDE Or AW_SLIDE Or AW_VER_NEGATIVE)
    DEACTIVATE_SLIDE_TO_BOTTOM = (AW_HIDE Or AW_SLIDE Or AW_VER_POSITIVE)
    DEACTIVATE_SLIDE_TO_LEFT = (AW_HIDE Or AW_SLIDE Or AW_HOR_NEGATIVE)
    DEACTIVATE_SLIDE_TO_RIGHT = (AW_HIDE Or AW_SLIDE Or AW_HOR_POSITIVE)
    DEACTIVATE_SLIDE_SHRINK_TO_TOP_LEFT = (AW_HIDE Or AW_SLIDE Or AW_HOR_NEGATIVE Or AW_VER_NEGATIVE)
    DEACTIVATE_SLIDE_SHRINK_TO_BOTTOM_RIGHT = (AW_HIDE Or AW_SLIDE Or AW_HOR_POSITIVE Or AW_VER_POSITIVE)
    DEACTIVATE_SLIDE_SHRINK_TO_TOP_RIGHT = (AW_HIDE Or AW_SLIDE Or AW_HOR_POSITIVE Or AW_VER_NEGATIVE)
    DEACTIVATE_SLIDE_SHRINK_TO_BOTTOM_LEFT = (AW_HIDE Or AW_SLIDE Or AW_HOR_NEGATIVE Or AW_VER_POSITIVE)
    DEACTIVATE_SLIDE_SHRINK_TO_CENTER = (AW_HIDE Or AW_SLIDE Or AW_CENTER)
End Enum

Function AnimateWindow(ByVal Form As Object, ByVal dwTime As Long, ByVal dwFlags As Animation)
    Dim ctl As Control

    SetProp Form.hWnd, PROP_PREVPROC, GetWindowLong(Form.hWnd, GWL_WNDPROC)
    SetProp Form.hWnd, PROP_FORM, ObjPtr(Form)
    Dim i As Integer
    SetWindowLong Form.hWnd, GWL_WNDPROC, AddressOf AnimateWinProc
    apiAnimateWindow Form.hWnd, dwTime, dwFlags
    SetWindowLong Form.hWnd, GWL_WNDPROC, GetProp(Form.hWnd, PROP_PREVPROC)
    RemoveProp Form.hWnd, PROP_FORM
    RemoveProp Form.hWnd, PROP_PREVPROC
    Form.Refresh
    For Each ctl In Form.Controls
        ctl.Visible = Not ctl.Visible
        ctl.Visible = Not ctl.Visible
    Next
End Function

Private Function AnimateWinProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    Dim lPrevProc As Long
    Dim lForm As Long
    Dim oForm As Form

    lPrevProc = GetProp(hWnd, PROP_PREVPROC)

    lForm = GetProp(hWnd, PROP_FORM)
    MoveMemory oForm, lForm, 4&
    
    Select Case Msg
        Case WM_PRINTCLIENT
            Dim tRect As RECT
            Dim hBr As Long
            GetClientRect hWnd, tRect
            hBr = CreateSolidBrush(OleTranslateColor(oForm.BackColor))
            FillRect wParam, tRect, hBr
            DeleteObject hBr

            If Not oForm.Picture Is Nothing Then
                Dim lScrDC As Long
                Dim lMemDC As Long
                Dim lPrevBMP As Long
                lScrDC = GetDC(0&)
                lMemDC = CreateCompatibleDC(lScrDC)
                ReleaseDC 0, lScrDC
                lPrevBMP = SelectObject(lMemDC, oForm.Picture.Handle)
                BitBlt wParam, 0, 0, HM2Pix(oForm.Picture.Width), HM2Pix(oForm.Picture.Height), lMemDC, 0, 0, vbSrcCopy
                SelectObject lMemDC, lPrevBMP
                DeleteDC lMemDC
            End If
    End Select

    MoveMemory oForm, 0&, 4&
    AnimateWinProc = CallWindowProc(lPrevProc, hWnd, Msg, wParam, lParam)

End Function

Private Function HM2Pix(ByVal Value As Long) As Long
    HM2Pix = MulDiv(Value, 1440, 2540) / Screen.TwipsPerPixelX
End Function

Private Function OleTranslateColor(ByVal Clr As Long) As Long
    apiOleTranslateColor Clr, 0, OleTranslateColor
End Function

Public Function AnimationX(frm As Object, lTime As Long, eMode As Animation)
    AnimateWindow frm, lTime, eMode
End Function
Simpanlah kode diatas pada sebuah module. Adapun contoh penggunaannya adalah sebagai berikut: 
Private Sub Form_Load()
    AnimateWindow Me, 300, ACTIVATE_SLIDE_EXPAND_FROM_CENTER
End Sub

Private Sub Form_Unload(Cancel As Integer)
    AnimateWindow Me, 300, DEACTIVATE_SLIDE_SHRINK_TO_CENTER
End Sub
Harap diingat, flags yang diawali dengan ACTIVATE untuk memulai dan flags yang diakhiri dengan DEACTIVATE untuk mengakhiri. Akhirnya saya jadi teringat beberapa software yang menggunakan efek animasi seperti ini, diantaranya adalah Mufid (software kamus) yang menggunakan efek slide kemudian SpeedComander (software utility) yang menggunakan efek center.
Posted by at
Labels: