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 .
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 :
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
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
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 :
' 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 :
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 :
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 :
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( Else LongToString = LongToString & Hex( 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), 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 ( And d), X, ac) A = LongLeftRotate(A, s) A = LongOverflowAdd(A, 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, 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, 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, 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 di Link
Sekian Toutorial dari saya .
Mohon maaf jika tulisannya Acak acakan.
Silakan di kembangkan dan semoga bermanfaat .
1 komentar:
lengkap ya tutorial nya.
Bagus benget. cuman, kalo bisa kasih source nya. ane nyasar ksini. blog walking.
download juga AV buatan ane dong.
http://wildan-hilmi27.blogspot.com/
Salam Blog Walking
Posting Komentar