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.

READ MORE - VB6 Animasi: Menggunakan Fungsi API AnimateWindow

VB6 Animasi: Animasi Melayang Ala Google Talk

Mengenai animasi melayang pada saat tampil dan sembunyi di systray ala Google Talk menggunakan VB6.

Const IDANI_OPEN = &H1
Const IDANI_CLOSE = &H2
Const IDANI_CAPTION = &H3

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

Private Declare Function SetRect Lib "User32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function DrawAnimatedRects Lib "User32" (ByVal hwnd As Long, ByVal idAni As Long, lprcFrom As RECT, lprcTo As RECT) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Public Sub ShowMinimzeToSysTray(ByVal hwnd As Long)
    Dim rSource As RECT, rDest As RECT
    GetWindowRect hwnd, rSource
    GetWindowRect FindWindowEx(FindWindow("Shell_TrayWnd", vbNullString), 0, "TrayNotifyWnd", vbNullString), rDest
    Call DrawAnimatedRects(hwnd, IDANI_CLOSE Or IDANI_CAPTION, rSource, rDest)
End Sub

Public Sub ShowRestoreFromSysTray(ByVal hwnd As Long)
    Dim rSource As RECT, rDest As RECT
    GetWindowRect FindWindowEx(FindWindow("Shell_TrayWnd", vbNullString), 0, "TrayNotifyWnd", vbNullString), rSource
    GetWindowRect hwnd, rDest
    Call DrawAnimatedRects(hwnd, IDANI_OPEN Or IDANI_CAPTION, rSource, rDest)
End Sub

Private Sub Command2_Click()
    ShowMinimzeToSysTray hwnd
End Sub

Private Sub Command1_Click()
    ShowRestoreFromSysTray Me.hwnd
End Sub

Kode di atas, akan menjadi tidak bermanfaat apabila aplikasi tidak menggunakan/memanfaatkan systray icon untuk menampilkan dan menyembunyikan aplikasi.

READ MORE - VB6 Animasi: Animasi Melayang Ala Google Talk

Effect Bayangan (Shadow) Pada Form Menggunakan VB6

Mengenai cara menambahkan effect bayangan (shadow effect) pada form - effect bayangan (shadow effect) ini akan terlihat bagus terutama pada form tanpa border (property BorderStyle = 0 - none). Bagaimana kode mengenai shadow effect ini?

Option Explicit 
 
Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long 
Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 
Private Const CS_DROPSHADOW As Long = &H20000 
Private Const GCL_STYLE As Long = -26 
 
Private Sub DropShadow(ByVal hWnd As Long) 
    Call SetClassLong(hWnd, GCL_STYLE, GetClassLong(hWnd, GCL_STYLE) Or CS_DROPSHADOW) 
End Sub 
 
Private Sub Form_Load() 
   DropShadow Me.hWnd 
End Sub 

Catatan: Effect bayangan (shadow effect) akan bekerja pada saat Show shadow under menus dicheck (default). Show shadow under menus terdapat pada start >> Settings >> Control Panel >> System >> Advanced >> Settings >> Show shadow under menus.

READ MORE - Effect Bayangan (Shadow) Pada Form Menggunakan VB6

Notify Form Dengan Effect Transparent Hover

Menjelaskan mengenai cara membuat notify form yang menggunakan effect transparent hover - Apa yang dimaksud dengan notify form itu? notify form adalah form yang bertugas memberitahukan sesuatu kepada user, umumnya notify form muncul sebelah kanan bagian bawah. Beberapa software yang menggunakan notify form diantaranya: Mozilla Firefox, Orbit Downloader, IDM, Avira, software-software Anti Virus, dan banyak lagi. Untuk membuat notify form, khususnya yang memiliki effect transparent hover (terinspirasi dari software notepad++ pada dialog findnya), copy dan pastekan kode di bawah ini:

'---------------------------------------------------------------------------------------------------------- 
'http://khoiriyyah.blogspot.com 
'coder: Administrator 
'---------------------------------------------------------------------------------------------------------- 
Option Explicit 
 
Dim blnHighlighted As Boolean 
Dim blnMouseDownClick As Boolean 'bug fixed on flickering 
 
Private Type POINTAPI 
    X As Long 
    Y As Long 
End Type 
 
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long 
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long 
Private Declare Sub InitCommonControls Lib "COMCTL32.DLL" () 
 
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 
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal color As Long, ByVal X As Byte, ByVal alpha As Long) As Boolean 
 
Const LWA_BOTH = 3 
Const LWA_ALPHA = 2 
Const LWA_COLORKEY = 1 
Const GWL_EXSTYLE = -20 
Const WS_EX_LAYERED = &H80000 
 
Dim iTransparant As Integer 
Dim blnUp As Boolean 
 
Private Sub Form_Initialize() 
    InitCommonControls 
End Sub 
 
Private Sub MakeTransparan(hWndBro As Long, iTransp As Integer) 
   On Error Resume Next 
   
   Dim ret As Long 
   ret = GetWindowLong(hWndBro, GWL_EXSTYLE) 
   
   SetWindowLong hWndBro, GWL_EXSTYLE, ret Or WS_EX_LAYERED 
   SetLayeredWindowAttributes hWndBro, RGB(255, 255, 0), iTransp, LWA_ALPHA 
   Exit Sub 
 
End Sub 
 
Private Sub cmdOK_Click() 
    'Kode selanjutnya disini .... 
    blnUp = False 
    tmrNotify.Enabled = True 
End Sub 
 
Private Sub cmdCancel_Click() 
    'kode selanjutnya disini .... 
    blnUp = False 
    tmrNotify.Enabled = True 
End Sub 
 
Private Sub Form_Load() 
    MakeTransparan Me.hwnd, 100 
    Top = ((GetSystemMetrics(17) + GetSystemMetrics(4)) * Screen.TwipsPerPixelY) 
    Left = (GetSystemMetrics(16) * Screen.TwipsPerPixelX) - Width 
    blnUp = True 
End Sub 
 
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    blnMouseDownClick = True 
End Sub 
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    If blnHighlighted Then Exit Sub 
    blnHighlighted = True 
    tmrSemiTransparent.Enabled = True 
    MakeTransparan Me.hwnd, 255 
End Sub 
 
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    blnMouseDownClick = False 
End Sub 
 
Private Sub tmrSemiTransparent_Timer() 
    If blnMouseDownClick Then Exit Sub 
    Dim pt As POINTAPI 
    GetCursorPos pt 
    ScreenToClient hwnd, pt 
    If (pt.X < 0 Or pt.Y < 0) Or _ 
    (pt.X > (Me.ScaleLeft + Me.ScaleWidth) / Screen.TwipsPerPixelX) Or _ 
       (pt.Y > (Me.ScaleTop + Me.ScaleHeight) / Screen.TwipsPerPixelY) Then 
        blnHighlighted = False 
        tmrSemiTransparent.Enabled = False 
        MakeTransparan Me.hwnd, 100 
    End If 
End Sub 
 
Private Sub tmrNotify_Timer() 
    Const s = 100 
    Dim v As Single 
    v = (GetSystemMetrics(17) + GetSystemMetrics(4)) * Screen.TwipsPerPixelY 
    If blnUp = True Then 
        If Top - s <= v - Height Then 
            Top = Top - (Top - (v - Height)) 
            tmrNotify.Enabled = False 
        Else 
            Top = Top - s 
        End If 
    Else 
        Top = Top + s 
        If Top >= v Then End 
    End If 
End Sub

READ MORE - Notify Form Dengan Effect Transparent Hover

Membuat Efek Fade-In Fade-Out Pada Form - VB6 Code

Di bawah ini merupakan fungsi untuk membuat efek fade pada sebuah form.

Option Explicit 
 
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 
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal color As Long, ByVal x As Byte, ByVal alpha As Long) As Boolean 
 
Const LWA_BOTH = 3 
Const LWA_ALPHA = 2 
Const LWA_COLORKEY = 1 
Const GWL_EXSTYLE = -20 
Const WS_EX_LAYERED = &H80000 
 
Dim iTransparant As Integer 
 
Public Sub MakeTransparan(hWndBro As Long, iTransp As Integer) 
    On Error Resume Next 
 
    Dim ret As Long 
    ret = GetWindowLong(hWndBro, GWL_EXSTYLE) 
 
    SetWindowLong hWndBro, GWL_EXSTYLE, ret Or WS_EX_LAYERED 
    SetLayeredWindowAttributes hWndBro, RGB(255, 255, 0), iTransp, LWA_ALPHA 
    Exit Sub 
End Sub 

Private Sub Command1_Click() 
    Unload Me 
End Sub 

Private Sub Form_Load() 
 
    Timer1.Enabled = False 
    Timer2.Enabled = False 
    Timer1.Interval = 1 
    Timer2.Interval = 1 
    Me.Visible = False   
    Timer1.Enabled = True 
 
End Sub 
 
Private Sub Form_Unload(Cancel As Integer) 
    Cancel = 1 
    Timer1.Enabled = False 
    Timer2.Enabled = True 
End Sub 
 
Private Sub Timer1_Timer() 
    On Error Resume Next 
    iTransparant = iTransparant + 5 
    If iTransparant > 255 Then 
        iTransparant = 255 
        Timer1.Enabled = False 
    End If 
      MakeTransparan Me.hWnd, iTransparant 
    Me.Show 
End Sub 
 
Private Sub Timer2_Timer() 
    On Error Resume Next 
    iTransparant = iTransparant - 5 
    If iTransparant < 0 Then 
        iTransparant = 0 
        Timer2.Enabled = False 
        End 
    End If 
    MakeTransparan Me.hWnd, iTransparant 
End Sub 

READ MORE - Membuat Efek Fade-In Fade-Out Pada Form - VB6 Code

Animasi Ketikan Tanpa Flicker

Fungsi di bawah ini digunakan untuk animasi yang menyerupai text yang sedang di ketik. Animasinya sangat halus nyaris tanpa kedipan.

Option Explicit 
 
Dim sAnimation As String 
 
Private Sub Form_Load() 
    sAnimation = "Test : http://4basic-vb.blogspot.com" 
End Sub 
 
Private Sub Timer1_Timer() 
    Dim sToAnimate As String 
    Static iAnimation As Integer 
    Dim c As Integer 
    iAnimation = iAnimation + 1 
 
    sToAnimate = Mid(sAnimation, 1,   iAnimation) 
    With Picture1 
        .Cls 
        .CurrentX = 25 
        .CurrentY = 100 
        Picture1.Print sToAnimate 
    End With 
    If iAnimation >= Len(sAnimation) Then 
      iAnimation = 0 
    End If 
End Sub 

READ MORE - Animasi Ketikan Tanpa Flicker

Membuat Efek Bayangan Pada Objek

Di bawah ini merupakan fungsi untuk membuat efek bayangan pada sebuah objek. Bagaimana implementasi dalam Visual Basic 6.0? bisa Anda simak kodenya di bawah ini:

Option Explicit 
 
Public Function Shadow(frm As Form, ctl As Control, Optional shWidth = 3, Optional Color = vbGrayed) 
    Dim oldWidth As Integer 
    Dim oldScale As Integer 
 
    With frm 
        oldWidth = .DrawWidth 
        oldScale = .ScaleMode 
        .ScaleMode = 3 
          .DrawWidth = 1 
        frm.Line (ctl.Left + shWidth, ctl.Top + shWidth)-Step(ctl.Width - 1, ctl.Height - 1), Color, BF 
        .DrawWidth = oldWidth 
        .ScaleMode = oldScale 
    End With 
 
End Function 

Contoh penggunaan fungsi membuat efek bayangan pada objek

Private Sub Command1_Click() 
    Shadow Me, Command1, 2, vbBlack 
End Sub 

Anda dapat menggunakannya pada objek secara bulk dengan menggunakan for...each.

READ MORE - Membuat Efek Bayangan Pada Objek

Membuat Efek Blow pada Form

Membuat efek/animasi blow/explode pada sebuah form.

Option Explicit 
 
Type RECT 
  Left As Long 
  Top As Long 
  Right As Long 
  Bottom As Long 
End Type 
 
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long 
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long 
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long 
Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long 
Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long 
Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long 
Declare Function SelectObject Lib "user32" (ByVal hdc As Long, ByVal hObject As Long) As Long 
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long 
 
Public Const   IMPLODE_EXPLODE_VALUE = 1500 'you can change the value 
 
Sub ExplodeForm(f As Form, Movement As Integer) 
    Dim myRect As RECT 
    Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy% 
    Dim TheScreen As Long 
  Dim Brush As Long 
  GetWindowRect f.hwnd, myRect 
    formWidth = (myRect.Right - myRect.Left) 
    formHeight = myRect.Bottom - myRect.Top 
      TheScreen = GetDC(0) 
    Brush = CreateSolidBrush(f.BackColor) 
    For i = 1 To Movement 
        Cx = formWidth * (i / Movement) 
        Cy = formHeight * (i / Movement) 
        X = myRect.Left + (formWidth - Cx) / 2 
        Y = myRect.Top + (formHeight - Cy) / 2 
        Rectangle TheScreen, X, Y, X + Cx, Y + Cy 
    Next i 
  X = ReleaseDC(0, TheScreen) 
    DeleteObject (Brush) 
End Sub 
 
Public Sub ImplodeForm(f As Form, Movement As Integer) 
    Dim myRect As RECT 
    Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy% 
    Dim TheScreen As Long 
    Dim Brush As Long 
    GetWindowRect f.hwnd, myRect 
    formWidth = (myRect.Right - myRect.Left) 
    formHeight = myRect.Bottom - myRect.Top 
    TheScreen = GetDC(0) 
    Brush = CreateSolidBrush(f.BackColor) 
    For i = Movement To 1 Step -1 
        Cx = formWidth * (i / Movement) 
        Cy = formHeight * (i / Movement) 
        X = myRect.Left + (formWidth - Cx)   / 2 
        Y = myRect.Top + (formHeight - Cy) / 2 
        Rectangle TheScreen, X, Y, X + Cx, Y + Cy 
    Next i 
    X = ReleaseDC(0, TheScreen) 
    DeleteObject (Brush) 
End Sub 

Contoh penggunaan membuat efek ledakan pada form

Private Sub Command1_Click() 
    Call ImplodeForm(Me, IMPLODE_EXPLODE_VALUE) 
    End 
    Set Form1 = Nothing 
End Sub 
   
Private Sub Form_Load() 
    Call ExplodeForm(Me, IMPLODE_EXPLODE_VALUE) 
End Sub 

READ MORE - Membuat Efek Blow pada Form