Cara Membuat Antivirus Sendiri

Cara Membuat Antivirus Sendiri

 by moeh cx on Sat Sep 17, 2011 9:06 am

Langsung saja .
Ane kasih nih Toutorial cara membuat Anti Virus

1. Buatlah 1 buah Form baru. dan berinama frmMain
lalu masukan Komponen :

- Frame (ganti namenya menjadi frScan dan ganti captionnya menjadi Scan area)
- Frame (ganti namenya menjadi frResult dan ganti captionnya menjadi Result area)
- UniList (ganti namenya menjadi lstScan)
- UniList (ganti namenya menjadi lstResult)
- UniLabel (ganti namenya menjadi lblFile dan ganti captionnya menjadi [READY] )
- UniDialog ( gak usah di apa apain cuman masukin saja ke FORM)
- Command Button ( ganti namenya menjadi cmdRemove dan ganti captionnya menjadi Remove )
- Command Button (ganti namenya menjadi cmdAdd dan ganti captionnya menjadi Add )
- Command Button (ganti namenya menjadi Command1 dan ganti captionnya menjadi Star Scan )
- Command Button (ganti namenya menjadi Command2 dan ganti captionnya menjadi Options )
- Command Button (ganti namenya menjadi Command3 dan ganti captionnya menjadi List Virus )
- Command Button (ganti namenya menjadi Command4 dan ganti captionnya menjadi About )
- Command Button (ganti namenya menjadi Command5 dan ganti captionnya menjadi Quit )

Lalu masukan Coding Ini di Form nya .

Code:

Private Sub Command3_Click()
MsgBox "[Daftar Virus]" & Chr(13) & "1. Virus1" & Chr(13) & "2. Virus2" & Chr(13) & "3. Virus3", vbOKOnly, "Daftar Virus"
End Sub

Private Sub Command4_Click()
frmAbout.Show
End Sub

Private Sub Form_Load()
lstResult.AddItem "Welcome to WMR Anti Vir !"
lstResult.AddItem "Copyright © 2009 - 2010, AndaSoft"

lstScan.AddItem Environ$("windir") & "\*.*"
BERHENTI = True ' Set nilai Berhenti True
BacaDatabase App.path & "\database.db"
End Sub

Private Sub cmdAdd_Click()
UniDialog1.FolderMessage = "Select a path : "
UniDialog1.ShowFolder
End Sub

Private Sub cmdRemove_Click()
On Error Resume Next

Static count As Integer
For count = 1 To lstScan.ListCount
    If lstScan.Selected(count - 1) = True Then lstScan.RemoveItem (count - 1)
Next
End Sub

Private Sub Command1_Click()
Static count As Byte
If lstScan.ListCount = 0 Then Exit Sub
If Command1.Caption = "Start &scan" Then
    BERHENTI = False
    PosisiScan (True)
    Command1.Caption = "Abort &scan"
    lstResult.Clear
    For count = 0 To lstScan.ListCount - 1
        If BERHENTI = True Then Exit For
        lstResult.AddItem "[Scanning File ...]"
        lstResult.AddItem " "
        lstResult.AddItem " "
        ScanFolder RemoveFromRight(lstScan.List(count), 4), lblFile, lstResult
    Next
    Command1.Caption = "Start &scan"
    PosisiScan (False)
    BERHENTI = True
    MsgBox "Scan is finished !", vbInformation, "MY Antivirus"
Else
    BERHENTI = True
    Command1.Caption = "Start &scan"
    PosisiScan (False)
End If

End Sub

Private Sub Command2_Click()
frmOption.Show 1, Me
End Sub

Private Sub Command5_Click()
Unload Me
End
End Sub

Private Sub Form_Resize()
On Error Resume Next
Me.Height = 9615
Me.Width = 10320
End Sub

Private Sub Form_Unload(Cancel As Integer)
If BERHENTI = False Then Cancel = 1
End Sub

Private Sub Image1_Click()
frmGenerator.Show
End Sub

Private Sub lstScan_Click(Button As UniListMouseButton)

End Sub

Private Sub UniDialog1_FolderSelect(ByVal path As String)
If path <> "" Then
    lstScan.AddItem path & "\*.*"
End If
End Sub

Private Function AddSlash(sPath As String) As String
If Right(sPath, 1) = "\" Then
    AddSlash = sPath
Else
    AddSlash = sPath & "\"
End If
End Function

Private Sub PosisiScan(TF As Boolean)
If TF = True Then
    Command2.Enabled = False
    Command3.Enabled = False
    Command4.Enabled = False
    Command5.Enabled = False
    frScan.Enabled = False
    frResult.Enabled = False
Else
    Command2.Enabled = True
    Command3.Enabled = True
    Command4.Enabled = True
    Command5.Enabled = True
    frScan.Enabled = True
    frResult.Enabled = True
End If

End Sub

Private Function RemoveFromRight(sTemp As String, iRight As Integer) As String
    RemoveFromRight = Left(sTemp, Len(sTemp) - iRight)
End Function

2. tambahkan 1 Form lagy. dan berinama frmOption
lalu masukan Commponen :

- CheckBox ( ganti name nya menjadi ck1 dan captionnya menjadi Enable filter file size (by pass file up to 4 MB) )
- CheckBox ( ganti name nya menjadi ck2 dan captionnya menjadi Enable clean virus found (deleted virus after found) )
- CheckBox ( ganti name nya menjadi ck3 dan captionnya menjadi Enable normalize attribute (normalize attribute every file found) )
- Command Button ( ganti name nya menjadi cmdCancle dan captionnya menjadi Cancel
- Command Button ( ganti name nya menjadi cmdOk dan captionnya menjadi OK )

dan masukan coding di frmOption seperti ini :

Code:

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub ReleaseCapture Lib "user32" ()

Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2


Private Sub cmdCancel_Click()
ck1.value = 0
ck2.value = 0
ck3.value = 0

Me.Hide
End Sub

Private Sub cmdOK_Click()
Me.Hide
End Sub

Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lngReturnValue As Long
If Button = 1 Then
    Call ReleaseCapture
    lngReturnValue = SendMessage(Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub

Bagian Form sudah selesai Tinggal sekarang bagian module..

Tambahkan 5 buah Module.
-Modul1 ganti namanya menjadi ModDb
dan masukan Codding sperty ini

Code:

Public sMD5() As String
Public sNamaVirus() As String
Public JumlahVirus As Integer

Public Function BacaDatabase(sPath As String)
Static sTemp As String
Static sTmp() As String
Static sTmp2() As String
Static pisah As String
Static iCount As Integer
Static iTemp As Integer


pisah = Chr(13)
sTemp = ReadAnsiFile(sPath) ' boleh diganti fungsi ReadUnicodeFile
sTmp() = Split(sTemp, pisah)

iTemp = UBound(sTmp()) - 1 ' untuk jumlah virus

ReDim sMD5(iTemp) As String
ReDim sNamaVirus(iTemp) As String

For iCount = 1 To iTemp
    sTmp2() = Split(sTmp(iCount), ":")
    sMD5(iCount) = Mid(sTmp2(0), 2)
    sNamaVirus(iCount) = sTmp2(1)
Next
JumlahVirus = iTemp
End Function


Public Function isFileVirus(sPath As String, lstVirus As UniList) As Boolean
Static iCount As Integer
Static MD5file As String

MD5file = GET_MD5(sPath)

For iCount = 1 To JumlahVirus
    If sMD5(iCount) = MD5file Then ' jika virus didapet
        lstVirus.AddItem "Virus Found ! [" & sNamaVirus(iCount) & "] - " & sPath
        isFileVirus = True
        Exit Function
    End If
Next
isFileVirus = False
End Function

-Module2 ganti namanya menjadi ModFile
masukan codding seperty ini

Code:

Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileW" (ByVal lpFileName As Long) As Long
Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesW" (ByVal lpFileName As Long, ByVal dwFileAttributes As Long) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesW" (ByVal lpFileName As Long) As Long

Dim RDF As New clsFile

Public Function ReadUnicodeFile(sFilePath As String, Msg As Boolean, nStart As Long, nLenght As Long) As String
On Error Resume Next
Dim zFileName  As String
Dim hFile      As Long 'nomor file handle, valid jika > 0;
Dim nFileLen    As Long
Dim nOperation  As Long
    'coba baca file yang namanya mengandung unsur unicode:
    zFileName = sFilePath
    'gunakan akses "read_write_existing" untuk menguji apakah file benar-benar ada:
    hFile = RDF.VbOpenFile(zFileName, FOR_BINARY_ACCESS_READ_WRITE_EXISTING, LOCK_NONE)
    'selanjutnya:
    If hFile > 0 Then 'jika berhasil membuka file hFile/Handel file > 0;
        'cari tahu ukuran filenya:
        nFileLen = RDF.VbFileLen(hFile)
       
        Dim bufData()  As Byte
            nOperation = RDF.VbReadFileB(hFile, nStart, nLenght, bufData)
            ReadUnicodeFile = StrConv(bufData, vbUnicode)
            RDF.VbCloseFile hFile 'harus tutup handle ke file setelah mengaksesnya !!!
    Else 'jika gagal membuka file;
            If Msg = True Then MsgBox "#gagal membuka file ! :("
            GoTo TERAKHIR
    End If
Exit Function

TERAKHIR:
End Function

Public Function ReadAnsiFile(sFile As String) As String
Dim sTemp As String
Open sFile For Binary As #1
    sTemp = Space(LOF(1))
    Get #1, , sTemp
Close #1
ReadAnsiFile = sTemp
End Function

Public Function NormalizeAttribute(sPath As String)
On Error Resume Next
If GetFileAttributes(StrPtr(sPath)) = 4 Then ' system
  SetFileAttributes StrPtr(sPath), 0
ElseIf GetFileAttributes(StrPtr(sPath)) = 6 Then ' hidden + system
  SetFileAttributes StrPtr(sPath), 0
ElseIf GetFileAttributes(StrPtr(sPath)) = 2 Then '
  SetFileAttributes sPath, 0
ElseIf GetFileAttributes(StrPtr(sPath)) = 38 Then '
  SetFileAttributes StrPtr(sPath), 0
ElseIf GetFileAttributes(StrPtr(sPath)) = 39 Then '
  SetFileAttributes StrPtr(sPath), 0
End If
End Function

Public Function HapusFile(sPath As String)
On Error Resume Next

SetFileAttributes StrPtr(sPath), 0
DeleteFile StrPtr(sPath)

End Function

Public Function isProperFile(sPath As String, limitSizeMB As Integer, sExt As String) As Boolean
On Error Resume Next
If (limitSizeMB * 1024 * 1024) > FileLen(sPath) Then
    If InStr(1, UCase(sExt), UCase(Right(sPath, 3))) > 0 Then
        isProperFile = True
    Else
        isProperFile = False
    End If
Else
    isProperFile = False
End If
End Function

-module3 ganti namanya menjadi ModMD5
masukan codding seperti ini :

Code:

' Mendapatkan MD5 (message digest 5) dengan mengambil 2000 kar dari kiri data file yang dibaca
' Anda bisa modifikasi sendiri data dari sebuah file yang ingin dijadikan ceksum MD5
' pada kasus ni saya mengambil 2000 kar sebelah kiri seluruh bagian data dari isi file
' atau jika file kurang dari 2000 byte maka data file diambil semuanya

Public Function GET_MD5(FileName As String) As String
On Error GoTo Salah
   
    Dim MD5 As New clsMD5
    Dim Buff As String
   
    Buff = ReadUnicodeFile(FileName, False, 1, 2000) ' --> baca file 2000 dari kiri aj
   
    Buff = Left(Buff, 2000) ' 2000 menandakan banyaknya kar yang diambil dari kiri
   
    MD5.MD5Init
    MD5.DigestStrToHexStr Buff
    GET_MD5 = MD5.GetValues
    Set MD5 = Nothing
    Exit Function
Salah:
End Function

[/Spoiler]

-Module4 ganti namanya menjadi ModSearch
masukan codding seperti ini :

[Spoiler]
Dim FSO As Object
Public BERHENTI As Boolean

Private Function GET_Folder(Folder As String, lbFile As UniLabel, lstInfo As UniList) As String
On Error Resume Next
Dim sFolder As Object

For Each sFolder In FSO.getFolder(Folder).subFolders
    GET_Folder (sFolder.path), lbFile, lstInfo
    If BERHENTI = True Then Exit Function
    GetFile sFolder.path, lbFile, lstInfo
Next
End Function

Private Function GetFile(path As String, lbFile As UniLabel, lstInfo As UniList)
Dim sFile As Object
For Each sFile In FSO.getFolder(path).Files
    DoEvents
    If BERHENTI = True Then Exit Function
    lbFile.Caption = sFile
    If frmOption.ck1.value = 1 Then
        If isProperFile(CStr(sFile), 3, "EXE DLL VBS VMX DB COM SCR BAT") = True Then
            If isFileVirus(CStr(sFile), lstInfo) = True Then
                If frmOption.ck2.value = 1 Then HapusFile CStr(sFile)
            End If
            If frmOption.ck3.value = 1 Then NormalizeAttribute CStr(sFile)
        End If
    Else
        If isFileVirus(CStr(sFile), lstInfo) = True Then
            If frmOption.ck2.value = 1 Then HapusFile CStr(sFile)
        End If
        If frmOption.ck3.value = 1 Then NormalizeAttribute CStr(sFile)
    End If
Next
End Function

Public Function ScanFolder(Folder As String, lbFile As UniLabel, lstInfo As UniList)
Dim sFile As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each sFile In FSO.getFolder(Folder).Files
    DoEvents
    lbFile.Caption = sFile
    If frmOption.ck1.value = 1 Then
        If isProperFile(CStr(sFile), 3, "EXE DLL VBS VMX DB COM SCR BAT") = True Then
            If isFileVirus(CStr(sFile), lstInfo) = True Then
                If frmOption.ck2.value = 1 Then HapusFile CStr(sFile)
            End If
            If frmOption.ck3.value = 1 Then NormalizeAttribute CStr(sFile)
        End If
    Else
        If isFileVirus(CStr(sFile), lstInfo) = True Then
            If frmOption.ck2.value = 1 Then HapusFile CStr(sFile)
        End If
        If frmOption.ck3.value = 1 Then NormalizeAttribute CStr(sFile)
    End If
Next
GET_Folder Folder, lbFile, lstInfo ' Lanjut ke file - file adalam sub folder
End Function

-Module5 ganti namanya menjadi ModUniList
masukan codding ini :

Code:

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Public Type UniList_IPAOHook
    lpVTable As Long
    IPAOReal As IOleInPlaceActiveObject
    Ctl As UniList
    ThisPointer As Long
End Type

Private Const S_FALSE As Long = 1
Private Const S_OK As Long = 0

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function IsEqualGUID Lib "ole32" (iid1 As GUID, iid2 As GUID) As Long

Private IID_IOleInPlaceActiveObject As GUID
Private m_IPAOVTable(9) As Long

Private Function AddOf(ByVal AddressOfProcedure As Long) As Long
    AddOf = AddressOfProcedure
End Function

Private Function IPAO_AddRef(This As UniList_IPAOHook) As Long
    IPAO_AddRef = This.IPAOReal.AddRef
End Function

Private Function IPAO_ContextSensitiveHelp(This As UniList_IPAOHook, ByVal fEnterMode As Long) As Long
    IPAO_ContextSensitiveHelp = This.IPAOReal.ContextSensitiveHelp(fEnterMode)
End Function

Private Function IPAO_EnableModeless(This As UniList_IPAOHook, ByVal fEnable As Long) As Long
    IPAO_EnableModeless = This.IPAOReal.EnableModeless(fEnable)
End Function

Private Function IPAO_GetWindow(This As UniList_IPAOHook, phwnd As Long) As Long
    IPAO_GetWindow = This.IPAOReal.GetWindow(phwnd)
End Function

Private Function IPAO_OnDocWindowActivate(This As UniList_IPAOHook, ByVal fActivate As Long) As Long
    IPAO_OnDocWindowActivate = This.IPAOReal.OnDocWindowActivate(fActivate)
End Function

Private Function IPAO_OnFrameWindowActivate(This As UniList_IPAOHook, ByVal fActivate As Long) As Long
    IPAO_OnFrameWindowActivate = This.IPAOReal.OnFrameWindowActivate(fActivate)
End Function

Private Function IPAO_QueryInterface(This As UniList_IPAOHook, riid As GUID, pvObj As Long) As Long
    If IsEqualGUID(riid, IID_IOleInPlaceActiveObject) Then
        pvObj = This.ThisPointer
        IPAO_AddRef This
        IPAO_QueryInterface = 0
    Else
        IPAO_QueryInterface = This.IPAOReal.QueryInterface(ByVal VarPtr(riid), pvObj)
    End If
End Function

Private Function IPAO_Release(This As UniList_IPAOHook) As Long
    IPAO_Release = This.IPAOReal.Release
End Function

Private Function IPAO_ResizeBorder(This As UniList_IPAOHook, prcBorder As RECT, ByVal puiWindow As IOleInPlaceUIWindow, ByVal fFrameWindow As Long) As Long
    IPAO_ResizeBorder = This.IPAOReal.ResizeBorder(VarPtr(prcBorder), puiWindow, fFrameWindow)
End Function

Private Function IPAO_TranslateAccelerator(This As UniList_IPAOHook, lpMsg As Msg) As Long
    Dim CtlText As UniList
    If TypeOf This.Ctl Is UniList Then
        Set CtlText = This.Ctl
        If CtlText.TranslateAccel(lpMsg) Then IPAO_TranslateAccelerator = S_OK: Exit Function
    End If
    IPAO_TranslateAccelerator = This.IPAOReal.TranslateAccelerator(ByVal VarPtr(lpMsg))
End Function

Public Sub UniList_Init(UniList_IPAOHook As UniList_IPAOHook, Ctl As UniList)
    Dim IPAO As IOleInPlaceActiveObject
    If m_IPAOVTable(0) = 0 Then
        m_IPAOVTable(0) = AddOf(AddressOf IPAO_QueryInterface)
        m_IPAOVTable(1) = AddOf(AddressOf IPAO_AddRef)
        m_IPAOVTable(2) = AddOf(AddressOf IPAO_Release)
        m_IPAOVTable(3) = AddOf(AddressOf IPAO_GetWindow)
        m_IPAOVTable(4) = AddOf(AddressOf IPAO_ContextSensitiveHelp)
        m_IPAOVTable(5) = AddOf(AddressOf IPAO_TranslateAccelerator)
        m_IPAOVTable(6) = AddOf(AddressOf IPAO_OnFrameWindowActivate)
        m_IPAOVTable(7) = AddOf(AddressOf IPAO_OnDocWindowActivate)
        m_IPAOVTable(8) = AddOf(AddressOf IPAO_ResizeBorder)
        m_IPAOVTable(9) = AddOf(AddressOf IPAO_EnableModeless)
        With IID_IOleInPlaceActiveObject
          .Data1 = &H117&
          .Data4(0) = &HC0
          .Data4(7) = &H46
        End With
    End If
    With UniList_IPAOHook
        Set IPAO = Ctl
        CopyMemory .IPAOReal, IPAO, 4
        CopyMemory .Ctl, Ctl, 4
        .lpVTable = VarPtr(m_IPAOVTable(0))
        .ThisPointer = VarPtr(UniList_IPAOHook)
    End With
End Sub
Public Sub UniList_Terminate(UniList_IPAOHook As UniList_IPAOHook)
    With UniList_IPAOHook
        CopyMemory .IPAOReal, 0&, 4
        CopyMemory .Ctl, 0&, 4
    End With
End Sub

Module udah selesai ..
sekarang bagian 'Class Module'

Masukan 2 buat Class Module.
-Class1 ganti namanya menjadi clsFile
dan masukan Codding ini :

Code:

Option Explicit

Private Const MAX_PATH      As Long = 260              '00-FF
Private Const MAX_BUFFER    As Long = (MAX_PATH * 2)    '00 00 - FF FF

Private Const SYNCHRONIZE = &H100000    'penting! sinkronisasi data dan akses dengan proses lain.
Private Const READ_CONTROL = &H20000    'penting! ijin untuk mengoperasikan file.
Private Const FILE_READ_DATA = (&H1)    'penting! operasi: membaca file.
Private Const FILE_WRITE_DATA = (&H2)  'penting! operasi: menulis file.

Private Const FILE_SHARE_READ = &H1    'dapat diakses baca oleh proses lain.
Private Const FILE_SHARE_WRITE = &H2    'dapat diakses tulis oleh proses lain.
Private Const FILE_SHARE_DELETE = &H4  'dapat diakses hapus oleh proses lain.

Private Const FILE_ATTRIBUTE_NORMAL = &H80 'untuk file standar.

'operasi alternatif untuk file yang akan dibuat ataupun dibuka:
Private Const FILE_DISPOSE_CREATE_NEW = 1          'hanya akan membuat file baru. bila file sudah ada sebelumnya, fungsi gagal.
Private Const FILE_DISPOSE_CREATE_ALWAYS = 2        'hapus file yang lama (bila ada), dan akan membuat file yang baru.
Private Const FILE_DISPOSE_OPEN_EXISTING = 3        'hanya akan membuka file yang sudah ada, bila file tidak ada, fungsi gagal.
Private Const FILE_DISPOSE_OPEN_ALWAYS = 4          'membuka file yang ada (bila ada), dan akan membuat file yang baru bila file belum ada.
Private Const FILE_DISPOSE_TRUNCATE_EXISTING = 5    'membuka file yang sudah ada, dan menghapus semua isinya terlebih dahulu. fungsi gagal bila file tidak ada.

'membuka file:
Private Declare Function CreateFileW Lib "kernel32" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CreateFileA Lib "kernel32" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long

'mencari ukuran file:
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long

'menggeser posisi pointer ke file:
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long

'operasi dasar untuk file yang telah dibuka:
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long

'menutup file yang telah dibuka:
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

'\\Ingat!:
Public Enum CREATE_ACCESS_OPTIONS
    FOR_BINARY_ACCESS_READ = 1                  'hanya membaca isi dari file, tanpa memodifikasi isi file. bila file tidak ada, fungsi gagal.
    FOR_BINARY_ACCESS_WRITE = 2                'hanya menulis isi ke file, bila file belum ada, akan dibuatkan file baru.
    FOR_BINARY_ACCESS_READ_WRITE = 3            'untuk membaca dan menulis file, bila file belum ada, akan dibuatkan file baru.
    FOR_BINARY_ACCESS_READ_WRITE_EXISTING = 4  'untuk membaca dan menulis file, bila file belum ada, fungsi akan gagal. lebih aman.
End Enum

'\\Ingat!:
Public Enum SHARE_ACCESS_OPTIONS
    LOCK_READ_WRITE = 1 'hanya "sharing delete access", untuk proses yang lain.
    LOCK_READ = 2      'hanya "sharing write + delete access", untuk proses yang lain.
    LOCK_WRITE = 3      'hanya "sharing read + delete access", untuk proses yang lain.
    LOCK_NONE = 4      '"sharing" semuanya, tanpa terkecuali.
End Enum

Public Function VbOpenFile(ByVal szFileName As String, ByVal opCreateOption As CREATE_ACCESS_OPTIONS, ByVal opShareAccess As SHARE_ACCESS_OPTIONS) As Long
On Error Resume Next 'memberi nomor handle ke file bila berhasil, 0 jika gagal.
Dim KeResult        As Long 'result dari kernel32.
Dim KeCreateAccess  As Long
Dim KeCreateOption  As Long
Dim KeShareAccess  As Long
   
    Select Case opCreateOption
        Case FOR_BINARY_ACCESS_READ                '1
            KeCreateAccess = SYNCHRONIZE Or READ_CONTROL Or FILE_READ_DATA
            KeCreateOption = FILE_DISPOSE_OPEN_EXISTING
        Case FOR_BINARY_ACCESS_WRITE                '2
            KeCreateAccess = SYNCHRONIZE Or READ_CONTROL Or FILE_WRITE_DATA
            KeCreateOption = FILE_DISPOSE_OPEN_ALWAYS
        Case FOR_BINARY_ACCESS_READ_WRITE          '3
            KeCreateAccess = SYNCHRONIZE Or READ_CONTROL Or FILE_READ_DATA Or FILE_WRITE_DATA
            KeCreateOption = FILE_DISPOSE_OPEN_ALWAYS
        Case FOR_BINARY_ACCESS_READ_WRITE_EXISTING  '4
            KeCreateAccess = SYNCHRONIZE Or READ_CONTROL Or FILE_READ_DATA Or FILE_WRITE_DATA
            KeCreateOption = FILE_DISPOSE_OPEN_EXISTING
    End Select
   
    Select Case opShareAccess
        Case LOCK_READ_WRITE    '1
            KeShareAccess = FILE_SHARE_DELETE
        Case LOCK_READ          '2
            KeShareAccess = FILE_SHARE_WRITE Or FILE_SHARE_DELETE
        Case LOCK_WRITE        '3
            KeShareAccess = FILE_SHARE_READ Or FILE_SHARE_DELETE
        Case LOCK_NONE          '4
            KeShareAccess = FILE_SHARE_READ Or FILE_SHARE_WRITE Or FILE_SHARE_DELETE
    End Select
   
    'pakai cara utama (unicode):
    KeResult = CreateFileW(StrPtr(szFileName), KeCreateAccess, KeShareAccess, ByVal 0, KeCreateOption, FILE_ATTRIBUTE_NORMAL, 0)
    If KeResult > 0 Then        'sukses pakai cara unicode.
        VbOpenFile = KeResult 'masukkan ke fungsi (return): nomor handle menuju ke file.
        GoTo TERAKHIR
    End If
   
    'pakai cara cadangan (ansi):
    KeResult = 0                'reset, sekarang coba pakai ansi:
    KeResult = CreateFileA(szFileName, KeCreateAccess, KeShareAccess, ByVal 0, KeCreateOption, FILE_ATTRIBUTE_NORMAL, 0)
    If KeResult > 0 Then        'sukses pakai cara ansi.
        VbOpenFile = KeResult  'masukkan ke fungsi (return): nomor handle menuju ke file.
        GoTo TERAKHIR
    End If
   
    VbOpenFile = 0            'gagal membuka file :(
   
TERAKHIR:
    If Err.Number > 0 Then
        Err.Clear
    End If
End Function

Public Function VbFileLen(ByVal nFileHandle As Long) As Long
On Error Resume Next 'memberi nilai angka sebesar ukuran file dalam bytes.
    VbFileLen = GetFileSize(nFileHandle, 0)
TERAKHIR:
    If Err.Number > 0 Then
        Err.Clear
    End If
End Function

Public Function VbCloseFile(ByVal nFileHandle As Long) As Long
On Error Resume Next 'memberi nilai 1 jika berhasil, 0 jika gagal.
    VbCloseFile = CloseHandle(nFileHandle)
TERAKHIR:
    If Err.Number > 0 Then
        Err.Clear
    End If
End Function

Public Function VbReadFileB(ByVal nFileHandle As Long, ByVal nStartPos As Long, ByVal nReadLength As Long, ByRef OutFileData() As Byte) As Long
On Error Resume Next 'memberi isi ukuran file (buffer) dalam bytes sebagai pengembalian (return) + isi buffer.

Erase OutFileData                  'reset memori data.

'lanjut yang baru:
Dim nTrueLen        As Long
    nTrueLen = GetFileSize(nFileHandle, 0) 'cari ukuran filenya.
Dim nRequestStart  As Long
Dim nRequestLen    As Long
Dim nApproxLen      As Long
Dim KeResult        As Long

    'optimisasi opsional, dapat diganti sesuai keinginan:
    If nTrueLen <= -1 Then
        VbReadFileB = -1 'error: file tidak ada.
        GoTo TERAKHIR
    ElseIf nTrueLen = 0 Then
        VbReadFileB = -2 'error: file isi kosong.
        GoTo TERAKHIR
    End If
    If nStartPos > nTrueLen Then
        VbReadFileB = -3 'error: start melebihi akhir.
        GoTo TERAKHIR
    End If
    If nStartPos <= 0 Then
        VbReadFileB = -4 'error: start pointer tidak sesuai.
        GoTo TERAKHIR
    End If
    If nReadLength <= 0 Then
        VbReadFileB = -5 'error: panjang yang diminta tidak sesuai.
        GoTo TERAKHIR
    End If
    If nReadLength > nTrueLen Then
        VbReadFileB = -6 'error: panjang yang diminta melebihi akhir.
        GoTo TERAKHIR
    End If
   
    nRequestStart = nStartPos 'start pointer ke data (base 1).
    nRequestLen = nReadLength 'panjang data.
   
    ReDim OutFileData(nRequestLen - 1) As Byte 'persiapkan buffer data (base 0).
   
    SetFilePointer nFileHandle, (nRequestStart - 1), 0, 0 'set start pointer ke handle (base 0).
    KeResult = ReadFile(nFileHandle, OutFileData(0), nRequestLen, nApproxLen, ByVal 0)
   
    If nApproxLen <> nRequestLen Then 'test ukuran buffer dengan isi datanya.
        ReDim Preserve OutFileData(nApproxLen - 1) As Byte 'sesuaikan lagi ukuran buffer (base 0).
    End If
   
    VbReadFileB = nApproxLen  '<-- beritahu jumlah bytes yang berhasil dibaca.
     
TERAKHIR:
    If Err.Number > 0 Then
        Err.Clear
    End If
End Function

Private Sub Class_Initialize()
On Error Resume Next
    DoEvents
TERAKHIR:
    If Err.Number > 0 Then
        Err.Clear
    End If
End Sub

Private Sub Class_Terminate()
On Error Resume Next
    DoEvents
TERAKHIR:
    If Err.Number > 0 Then
        Err.Clear
    End If
End Sub

-class2 ganti namanya menjadi clsMD5
masukan coding ini :

Code:

Option Explicit

Private Const OFFSET_4 = 4294967296#
Private Const MAXINT_4 = 2147483647
Private State(4) As Long
Private ByteCounter As Long
Private ByteBuffer(63) As Byte
Private Const S11 = 7
Private Const S12 = 12
Private Const S13 = 17
Private Const S14 = 22
Private Const S21 = 5
Private Const S22 = 9
Private Const S23 = 14
Private Const S24 = 20
Private Const S31 = 4
Private Const S32 = 11
Private Const S33 = 16
Private Const S34 = 23
Private Const S41 = 6
Private Const S42 = 10
Private Const S43 = 15
Private Const S44 = 21
Property Get RegisterA() As String
    RegisterA = State(1)
End Property
Property Get RegisterB() As String
    RegisterB = State(2)
End Property

Property Get RegisterC() As String
    RegisterC = State(3)
End Property

Property Get RegisterD() As String
    RegisterD = State(4)
End Property
Public Function DigestStrToHexStr(SourceString As String) As String
    MD5Init
    MD5Update Len(SourceString), StringToArray(SourceString)
    MD5Final
    DigestStrToHexStr = GetValues
End Function
Public Function DigestFileToHexStr(inFIle As String) As String
On Error GoTo errorhandler
GoSub begin

errorhandler:
    DigestFileToHexStr = ""
    Exit Function
   
begin:
    Dim FileO As Integer
    FileO = FreeFile
    Call FileLen(inFIle)
    Open inFIle For Binary Access Read As #FileO
    MD5Init
    Do While Not EOF(FileO)
        Get #FileO, , ByteBuffer
        If Loc(FileO) < LOF(FileO) Then
            ByteCounter = ByteCounter + 64
            MD5Transform ByteBuffer
        End If
    Loop
    ByteCounter = ByteCounter + (LOF(FileO) Mod 64)
    Close #FileO
    MD5Final
    DigestFileToHexStr = GetValues
End Function
Private Function StringToArray(InString As String) As Byte()
    Dim i As Integer, bytBuffer() As Byte
    ReDim bytBuffer(Len(InString))
    For i = 0 To Len(InString) - 1
        bytBuffer(i) = Asc(Mid$(InString, i + 1, 1))
    Next i
    StringToArray = bytBuffer
End Function
Public Function GetValues() As String
    GetValues = LongToString(State(1)) & LongToString(State(2)) & LongToString(State(3)) & LongToString(State(4))
End Function
Private Function LongToString(Num As Long) As String
        Dim A As Byte, B As Byte, c As Byte, d As Byte
        A = Num And &HFF&
        If A < 16 Then LongToString = "0" & Hex(A) Else LongToString = Hex(A)
        B = (Num And &HFF00&) \ 256
        If B < 16 Then LongToString = LongToString & "0" & Hex(B) Else LongToString = LongToString & Hex(B)
        c = (Num And &HFF0000) \ 65536
        If c < 16 Then LongToString = LongToString & "0" & Hex(c) Else LongToString = LongToString & Hex(c)
        If Num < 0 Then d = ((Num And &H7F000000) \ 16777216) Or &H80& Else d = (Num And &HFF000000) \ 16777216
        If d < 16 Then LongToString = LongToString & "0" & Hex(d) Else LongToString = LongToString & Hex(d)
End Function

Public Sub MD5Init()
    ByteCounter = 0
    State(1) = UnsignedToLong(1732584193#)
    State(2) = UnsignedToLong(4023233417#)
    State(3) = UnsignedToLong(2562383102#)
    State(4) = UnsignedToLong(271733878#)
End Sub

Public Sub MD5Final()
    Dim dblBits As Double, padding(72) As Byte, lngBytesBuffered As Long
    padding(0) = &H80
    dblBits = ByteCounter * 8
    lngBytesBuffered = ByteCounter Mod 64
    If lngBytesBuffered <= 56 Then MD5Update 56 - lngBytesBuffered, padding Else MD5Update 120 - ByteCounter, padding
    padding(0) = UnsignedToLong(dblBits) And &HFF&
    padding(1) = UnsignedToLong(dblBits) \ 256 And &HFF&
    padding(2) = UnsignedToLong(dblBits) \ 65536 And &HFF&
    padding(3) = UnsignedToLong(dblBits) \ 16777216 And &HFF&
    padding(4) = 0
    padding(5) = 0
    padding(6) = 0
    padding(7) = 0
    MD5Update 8, padding
End Sub
Public Sub MD5Update(InputLen As Long, InputBuffer() As Byte)
    Dim II As Integer, i As Integer, J As Integer, K As Integer, lngBufferedBytes As Long, lngBufferRemaining As Long, lngRem As Long

    lngBufferedBytes = ByteCounter Mod 64
    lngBufferRemaining = 64 - lngBufferedBytes
    ByteCounter = ByteCounter + InputLen

    If InputLen >= lngBufferRemaining Then
        For II = 0 To lngBufferRemaining - 1
            ByteBuffer(lngBufferedBytes + II) = InputBuffer(II)
        Next II
        MD5Transform ByteBuffer
        lngRem = (InputLen) Mod 64
        For i = lngBufferRemaining To InputLen - II - lngRem Step 64
            For J = 0 To 63
                ByteBuffer(J) = InputBuffer(i + J)
            Next J
            MD5Transform ByteBuffer
        Next i
        lngBufferedBytes = 0
    Else
      i = 0
    End If
    For K = 0 To InputLen - i - 1
        ByteBuffer(lngBufferedBytes + K) = InputBuffer(i + K)
    Next K
End Sub
Private Sub MD5Transform(Buffer() As Byte)
    Dim X(16) As Long, A As Long, B As Long, c As Long, d As Long
   
    A = State(1)
    B = State(2)
    c = State(3)
    d = State(4)
    Decode 64, X, Buffer
    FF A, B, c, d, X(0), S11, -680876936
    FF d, A, B, c, X(1), S12, -389564586
    FF c, d, A, B, X(2), S13, 606105819
    FF B, c, d, A, X(3), S14, -1044525330
    FF A, B, c, d, X(4), S11, -176418897
    FF d, A, B, c, X(5), S12, 1200080426
    FF c, d, A, B, X(6), S13, -1473231341
    FF B, c, d, A, X(7), S14, -45705983
    FF A, B, c, d, X(8), S11, 1770035416
    FF d, A, B, c, X(9), S12, -1958414417
    FF c, d, A, B, X(10), S13, -42063
    FF B, c, d, A, X(11), S14, -1990404162
    FF A, B, c, d, X(12), S11, 1804603682
    FF d, A, B, c, X(13), S12, -40341101
    FF c, d, A, B, X(14), S13, -1502002290
    FF B, c, d, A, X(15), S14, 1236535329

    GG A, B, c, d, X(1), S21, -165796510
    GG d, A, B, c, X(6), S22, -1069501632
    GG c, d, A, B, X(11), S23, 643717713
    GG B, c, d, A, X(0), S24, -373897302
    GG A, B, c, d, X(5), S21, -701558691
    GG d, A, B, c, X(10), S22, 38016083
    GG c, d, A, B, X(15), S23, -660478335
    GG B, c, d, A, X(4), S24, -405537848
    GG A, B, c, d, X(9), S21, 568446438
    GG d, A, B, c, X(14), S22, -1019803690
    GG c, d, A, B, X(3), S23, -187363961
    GG B, c, d, A, X(8), S24, 1163531501
    GG A, B, c, d, X(13), S21, -1444681467
    GG d, A, B, c, X(2), S22, -51403784
    GG c, d, A, B, X(7), S23, 1735328473
    GG B, c, d, A, X(12), S24, -1926607734

    HH A, B, c, d, X(5), S31, -378558
    HH d, A, B, c, X(8), S32, -2022574463
    HH c, d, A, B, X(11), S33, 1839030562
    HH B, c, d, A, X(14), S34, -35309556
    HH A, B, c, d, X(1), S31, -1530992060
    HH d, A, B, c, X(4), S32, 1272893353
    HH c, d, A, B, X(7), S33, -155497632
    HH B, c, d, A, X(10), S34, -1094730640
    HH A, B, c, d, X(13), S31, 681279174
    HH d, A, B, c, X(0), S32, -358537222
    HH c, d, A, B, X(3), S33, -722521979
    HH B, c, d, A, X(6), S34, 76029189
    HH A, B, c, d, X(9), S31, -640364487
    HH d, A, B, c, X(12), S32, -421815835
    HH c, d, A, B, X(15), S33, 530742520
    HH B, c, d, A, X(2), S34, -995338651

    II A, B, c, d, X(0), S41, -198630844
    II d, A, B, c, X(7), S42, 1126891415
    II c, d, A, B, X(14), S43, -1416354905
    II B, c, d, A, X(5), S44, -57434055
    II A, B, c, d, X(12), S41, 1700485571
    II d, A, B, c, X(3), S42, -1894986606
    II c, d, A, B, X(10), S43, -1051523
    II B, c, d, A, X(1), S44, -2054922799
    II A, B, c, d, X(8), S41, 1873313359
    II d, A, B, c, X(15), S42, -30611744
    II c, d, A, B, X(6), S43, -1560198380
    II B, c, d, A, X(13), S44, 1309151649
    II A, B, c, d, X(4), S41, -145523070
    II d, A, B, c, X(11), S42, -1120210379
    II c, d, A, B, X(2), S43, 718787259
    II B, c, d, A, X(9), S44, -343485551

    State(1) = LongOverflowAdd(State(1), A)
    State(2) = LongOverflowAdd(State(2), B)
    State(3) = LongOverflowAdd(State(3), c)
    State(4) = LongOverflowAdd(State(4), d)
End Sub

Private Sub Decode(Length As Integer, OutputBuffer() As Long, InputBuffer() As Byte)
    Dim intDblIndex As Integer, intByteIndex As Integer, dblSum As Double
    For intByteIndex = 0 To Length - 1 Step 4
        dblSum = InputBuffer(intByteIndex) + InputBuffer(intByteIndex + 1) * 256# + InputBuffer(intByteIndex + 2) * 65536# + InputBuffer(intByteIndex + 3) * 16777216#
        OutputBuffer(intDblIndex) = UnsignedToLong(dblSum)
        intDblIndex = intDblIndex + 1
    Next intByteIndex
End Sub
Private Function FF(A As Long, B As Long, c As Long, d As Long, X As Long, s As Long, ac As Long) As Long
    A = LongOverflowAdd4(A, (B And c) Or (Not (B) And d), X, ac)
    A = LongLeftRotate(A, s)
    A = LongOverflowAdd(A, B)
End Function
Private Function GG(A As Long, B As Long, c As Long, d As Long, X As Long, s As Long, ac As Long) As Long
    A = LongOverflowAdd4(A, (B And d) Or (c And Not (d)), X, ac)
    A = LongLeftRotate(A, s)
    A = LongOverflowAdd(A, B)
End Function
Private Function HH(A As Long, B As Long, c As Long, d As Long, X As Long, s As Long, ac As Long) As Long
    A = LongOverflowAdd4(A, B Xor c Xor d, X, ac)
    A = LongLeftRotate(A, s)
    A = LongOverflowAdd(A, B)
End Function
Private Function II(A As Long, B As Long, c As Long, d As Long, X As Long, s As Long, ac As Long) As Long
    A = LongOverflowAdd4(A, c Xor (B Or Not (d)), X, ac)
    A = LongLeftRotate(A, s)
    A = LongOverflowAdd(A, B)
End Function

Function LongLeftRotate(value As Long, Bits As Long) As Long
    Dim lngSign As Long, lngI As Long
    Bits = Bits Mod 32
    If Bits = 0 Then LongLeftRotate = value: Exit Function
    For lngI = 1 To Bits
        lngSign = value And &HC0000000
        value = (value And &H3FFFFFFF) * 2
        value = value Or ((lngSign < 0) And 1) Or (CBool(lngSign And &H40000000) And &H80000000)
    Next
    LongLeftRotate = value
End Function
Private Function LongOverflowAdd(Val1 As Long, Val2 As Long) As Long
    Dim lngHighWord As Long, lngLowWord As Long, lngOverflow As Long
    lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&)
    lngOverflow = lngLowWord \ 65536
    lngHighWord = (((Val1 And &HFFFF0000) \ 65536) + ((Val2 And &HFFFF0000) \ 65536) + lngOverflow) And &HFFFF&
    LongOverflowAdd = UnsignedToLong((lngHighWord * 65536#) + (lngLowWord And &HFFFF&))
End Function
Private Function LongOverflowAdd4(Val1 As Long, Val2 As Long, val3 As Long, val4 As Long) As Long
    Dim lngHighWord As Long, lngLowWord As Long, lngOverflow As Long
    lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&) + (val3 And &HFFFF&) + (val4 And &HFFFF&)
    lngOverflow = lngLowWord \ 65536
    lngHighWord = (((Val1 And &HFFFF0000) \ 65536) + ((Val2 And &HFFFF0000) \ 65536) + ((val3 And &HFFFF0000) \ 65536) + ((val4 And &HFFFF0000) \ 65536) + lngOverflow) And &HFFFF&
    LongOverflowAdd4 = UnsignedToLong((lngHighWord * 65536#) + (lngLowWord And &HFFFF&))
End Function

Private Function UnsignedToLong(value As Double) As Long
    If value < 0 Or value >= OFFSET_4 Then Error 6
    If value <= MAXINT_4 Then UnsignedToLong = value Else UnsignedToLong = value - OFFSET_4
End Function
Private Function LongToUnsigned(value As Long) As Double
    If value < 0 Then LongToUnsigned = value + OFFSET_4 Else LongToUnsigned = value
End Function

Sekarang tinggal tambahkan Usser Controls.
untuk usser Control tinggal tambahkan saja dari Folder (source code) yg bisa di download disini

Sekian Toturial dari ane
mudah mudahan dengan mempelajari Toturial diatas, semua sahabat cx bisa membuat antivirus sendiri

sekalian ane minta dong