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

Procedure Untuk Menambahkan File Ke Recent Document

Di bawah ini merupakan procedure untuk menambahkan file ke recent document. Untuk keperluan ini digunakan satu fungsi API yakni SHAddToRecentDocs yang terdapat pada shell32.dll.

Option Explicit 
 
Private Declare Sub SHAddToRecentDocs Lib "shell32.dll" (ByVal uFlags As Long, ByVal pv As String) 
 
Public Function AddToRecentDocument(FileName As String) 
  Call SHAddToRecentDocs(3, FileName) 
End Function 

Cara menggunakan Fungsi Menambahkan Nama File Ke Recent Documents

Private Sub Command1_Click() 
    AddToRecentDocument "C:\boot.ini" 
End Sub   

READ MORE - Procedure Untuk Menambahkan File Ke Recent Document

Mencegah Aplikasi Dijalankan Dua Kali

Di bawah ini merupakan fungsi kedua masih mengenai cara mencegah aplikasi dijalankan dua kali. Bagaimana implementasinya dalam Visual Basic 6.0? bisa Anda simak kodenya di bawah ini:

Option Explicit 
 
Declare Function OpenIcon Lib "user32" (ByVal hWnd As Long) As Long 
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 
Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long 
Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long 
 
Public Const GW_HWNDPREV = 3 
 
Sub ActivatePrevInstance() 
 
    Dim AppTitle As String 
    Dim PrevHndl As Long 
    Dim result As Long 
 
    AppTitle = App.Title 
    App.Title = "unwanted instance" 
 
    If PrevHndl = 0 Then 
        PrevHndl = FindWindow("ThunderRT6Main", AppTitle) 
        If PrevHndl <> 0 Then 
            PrevHndl = GetWindow(PrevHndl, GW_HWNDPREV) 
            result = OpenIcon(PrevHndl) 
            result = SetForegroundWindow(PrevHndl) 
            End 
        End If 
    End If 
 
End Sub 

Contoh penggunaan:

Private Sub Form_Load() 
    If App.PrevInstance Then ActivatePrevInstance 
End Sub 

READ MORE - Mencegah Aplikasi Dijalankan Dua Kali

Class CRC32 Sebuah File - VB6 Code

Di bawah ini merupakan class untuk mengetahui CRC32 dari sebuah file. Untuk keperluan ini copy dan pastekan kode di bawah ini ke dalam class, kemudian ganti nama kelasnya menjadi clsCRC.

Option Explicit 
 
Private crcTable(0 To 255) As Long 'crc32 
 
Private Function CRC32(ByRef bArrayIn() As Byte, ByVal lLen As Long, Optional ByVal lcrc As Long = 0) As Long 
 
    Dim lCurPos As Long 
    Dim lTemp As Long 
 
    If lLen = 0 Then Exit Function 'In case of empty file 
    lTemp = lcrc Xor &HFFFFFFFF 'lcrc is for current value from partial check on the partial array 
 
    For lCurPos = 0 To lLen 
        lTemp = (((lTemp And &HFFFFFF00) \ &H100) And &HFFFFFF) Xor (crcTable((lTemp And 255) Xor bArrayIn(lCurPos))) 
    Next lCurPos 
 
    CRC32 = lTemp Xor &HFFFFFFFF 
 
End Function 
 
Private Function BuildTable() As Boolean 
 
    Dim I As Long, x As Long, crc As Long 
    Const Limit = &HEDB88320 'usally its shown backward, cant remember what it was. 
 
    For I = 0 To 255 
        crc = I 
        For x = 0 To 7 
            If crc And 1 Then 
                crc = (((crc And &HFFFFFFFE) \ 2) And &H7FFFFFFF) Xor Limit 
            Else 
                crc = ((crc And &HFFFFFFFE) \ 2) And &H7FFFFFFF 
            End If 
        Next x 
        crcTable(I) = crc 
    Next I 
 
End Function 
 
Private Sub Class_Initialize() 
    BuildTable 
End Sub 
 
Public Function CekCRC32(FileName As String) As String 
 
    Dim lngCrc As Long 
    Dim sCrc As Long 
 
    On Error GoTo ErrHandler 
 
    Open FileName For Binary Access Read As #1 
    ReDim tmp(LOF(1)) As Byte 
    Get #1, , tmp() 
    Close #1 
 
    lngCrc = UBound(tmp) 
    lngCrc = CRC32(tmp, lngCrc) 
    CekCRC32 = Hex(lngCrc) 
 
    Exit Function 
 
    ErrHandler: 
 
    MsgBox Err.Description, vbCritical, "Error" 
 
End Function 

Contoh penggunaan Class CRC32

Option Explicit 
 
Private Sub Form_Load() 
    Dim crc As New clsCRC 
    MsgBox crc.CekCRC32("C:\boot.ini") 
End Sub 

READ MORE - Class CRC32 Sebuah File - VB6 Code