Membuat aplikasi administrasi pembayaran spp sekolah

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

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

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

• 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

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

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

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

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

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

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