Template Source Code VB6+Database Ms.Access
Berikut ini adalah contoh source code untuk menangani database, lengkap dengan fungsi/prosedur menambah, menyimpan, mengedit, menghapus, navigasi, mencari pertama, mencari berikutnya, memfilter, dan menyortir data. Sangat cocok untuk digunakan sebagai template untuk menangani pemrograman database menggunakan coding yang memerlukan validasi data dan penanganan khusus lainnya.di visual basic 6, untuk mempraktekannya siapkan :
1. Buat 1 Project baru dengan 2 Form, beri nama frmData & frmInfo.2. Pada form tersebut, buat control sesuai coding di bawah ini.
3. Tambahkan reference "Microsoft ActiveX Data Objects 2.0 Library" dari menu Project->References...
4. Tambahkan component "Microsoft Common Dialog Control 6.0 (SP3)" dari menu Project->Components...
5. Copy-kan coding berikut ke dalam editor form yang bertalian.
'--------------- Coding di frmData ---------------------
Dim db As Connection
Dim WithEvents adoPrimaryRS As Recordset
Dim WithEvents rsCariData As Recordset
Dim cekID As Recordset
Dim mbChangedByCode As Boolean
Dim mvBookMark As Variant
Dim mbEditFlag As Boolean
Dim mbAddNewFlag As Boolean
Dim mbDataChanged As Boolean
Dim HasiBatal As Boolean
Dim NomorData As Integer
Dim Cari, Cari1, Hasil, Hasil1 As String
Public Sub EnablePicture(InFrame As PictureBox, _
ByVal Flag As Boolean)
'Untuk mengaktifkan/menon-aktifkan control dalam
'satu picture/frame tertentu secara menyeluruh...
Dim Contrl As Control
On Error Resume Next 'Jika error, lanjutkan saja
InFrame.Enabled = Flag
'Utk setiap control yg ada di dalam picture/frame ybt
For Each Contrl In InFrame.Parent.Controls
If (Contrl.Container.Name = InFrame.Name) Then
If (TypeOf Contrl Is Frame) And Not _
(Contrl.Name = InFrame.Name) Then
EnablePicture Contrl, Flag
Else
If Not (TypeOf Contrl Is Menu) Then _
Contrl.Enabled = Flag
End If
End If
Next
End Sub
Private Sub cmdAbout_Click()
MsgBox "(c) Masino Sinaga, 7 Mei 2002", vbInformation, "About"
End Sub
Private Sub cmdClearSearch_Click()
'Membersihkan kriteria pencarian
Dim Jawab As Integer
If Len(Cari) = 0 Then
MsgBox "Belum ada kriteria pencarian.", _
vbInformation, "Kriteria Masih Kosong"
Exit Sub
Else
Jawab = MsgBox("Kriteria pencarian sebelumnya = " _
& Cari & "" & Chr(13) & _
"Anda yakin ingin menghapusnya?", _
vbQuestion + vbYesNo, "Reset Pencarian")
End If
If Jawab = vbYes Then
cmdFindFirst.Enabled = True
frmInfo.cmdFindFirst.Enabled = True
Cari = ""
Hasil = ""
frmInfo.Text1 = ""
End If
End Sub
Private Sub cmdFilter_Click()
Dim kriteria As String
On Error GoTo Pesan
Set rsCariData = New Recordset
kriteria = InputBox("Masukkan data apa saja yang diketahui:", "Saring/Filter Data")
If kriteria = "" Then Exit Sub
Set adoPrimaryRS = New Recordset
adoPrimaryRS.Open "SHAPE " & _
"{select NIM,Nama,Nippos,Alamat," & _
"Tgl_lahir from t_mhs " & _
"WHERE NIM LIKE '%" & kriteria & "%' OR " & _
"Nama LIKE '%" & kriteria & "%' OR " & _
"Nippos LIKE '%" & kriteria & "%' OR " & _
"Alamat LIKE '%" & kriteria & "%' OR " & _
"Tgl_lahir LIKE '%" & kriteria & "%' " & _
"ORDER BY NIM} " & _
"AS ParentCMD " & _
"APPEND ({select NIM,Nama,Nippos," & _
"Alamat,Tgl_lahir from t_mhs " & _
"WHERE NIM LIKE '%" & kriteria & "%' OR " & _
"Nama LIKE '%" & kriteria & "%' OR " & _
"Nippos LIKE '%" & kriteria & "%' OR " & _
"Alamat LIKE '%" & kriteria & "%' OR " & _
"Tgl_lahir LIKE '%" & kriteria & "%' " & _
"ORDER BY NIM} " & _
"AS ChildCMD RELATE NIM TO NIM) " & _
"AS ChildCMD", db, _
adOpenStatic, adLockOptimistic
If adoPrimaryRS.RecordCount > 0 Then
Set grdDataGrid.DataSource = adoPrimaryRS.DataSource
Dim oTextData As TextBox
For Each oTextData In Me.txtFields
Set oTextData.DataSource = adoPrimaryRS.DataSource
Next
Else
cmdRefresh_Click
MsgBox "'" & kriteria & "' tidak ditemukan" & Chr(13) & _
"dalam data t_mhs!", vbCritical, "Tidak Ditemukan"
End If
Exit Sub
Pesan:
MsgBox "'" & kriteria & "' tidak ditemukan" & Chr(13) & _
"dalam data t_mhs!", vbCritical, "Tidak Ditemukan"
End Sub
Private Sub cmdSortASC_Click()
Dim kriteria As String
On Error GoTo Pesan
Set rsCariData = New Recordset
kriteria = InputBox("Masukkan field yang akan di-sortd ASCENDING:" & vbCrLf & _
"(Pilih salah satu: NIM atau Nama atau" & vbCrLf & _
"Nippos atau Alamat atau Tgl_lahir)", "Saring/Filter Data")
If kriteria = "" Then Exit Sub
Set adoPrimaryRS = New Recordset
adoPrimaryRS.Open "SHAPE {select NIM,Nama,Nippos,Alamat," & _
"Tgl_lahir from t_mhs ORDER BY " _
& kriteria & " ASC} AS ParentCMD APPEND " & _
"({select NIM,Nama,Nippos,Alamat, " & _
"Tgl_lahir from t_mhs ORDER BY " _
& kriteria & " ASC} AS ChildCMD RELATE NIM " & _
"TO NIM) AS ChildCMD", db, _
adOpenStatic, adLockOptimistic
Set grdDataGrid.DataSource = adoPrimaryRS.DataSource
Dim oTextData As TextBox
For Each oTextData In Me.txtFields
Set oTextData.DataSource = adoPrimaryRS.DataSource
Next
Exit Sub
Pesan:
MsgBox "Field '" & kriteria & "' tidak ditemukan" & Chr(13) & _
"dalam data t_mhs! Ganti dengan field:" & vbCrLf & _
"NIM atau Nama atau Nippos atau Alamat" & vbCrLf & _
"atau Tgl_lahir", vbCritical, "Tidak Ditemukan"
End Sub
Private Sub cmdSortDESC_Click()
Dim kriteria As String
On Error GoTo Pesan
Set rsCariData = New Recordset
kriteria = InputBox("Masukkan field yang akan di-sortd DESCENDING:" & vbCrLf & _
"(Pilih salah satu: NIM atau Nama atau" & vbCrLf & _
"Nippos atau Alamat atau Tgl_lahir)", "Saring/Filter Data")
If kriteria = "" Then Exit Sub
Set adoPrimaryRS = New Recordset
adoPrimaryRS.Open "SHAPE {select NIM,Nama,Nippos,Alamat," & _
"Tgl_lahir from t_mhs ORDER BY " _
& kriteria & " DESC} AS ParentCMD APPEND " & _
"({select NIM,Nama,Nippos,Alamat, " & _
"Tgl_lahir from t_mhs ORDER BY " _
& kriteria & " DESC} AS ChildCMD RELATE NIM " & _
"TO NIM) AS ChildCMD", db, _
adOpenStatic, adLockOptimistic
Set grdDataGrid.DataSource = adoPrimaryRS.DataSource
Dim oTextData As TextBox
For Each oTextData In Me.txtFields
Set oTextData.DataSource = adoPrimaryRS.DataSource
Next
Exit Sub
Pesan:
MsgBox "Field '" & kriteria & "' tidak ditemukan" & Chr(13) & _
"dalam data t_mhs! Ganti dengan field:" & vbCrLf & _
"NIM atau Nama atau Nippos atau Alamat" & vbCrLf & _
"atau Tgl_lahir", vbCritical, "Tidak Ditemukan"
End Sub
Private Sub cmdUnFilter_Click()
cmdRefresh_Click
EnablePicture picButtons, True
cmdUpdate.Enabled = False
cmdCancel.Enabled = False
End Sub
Private Sub rsCariData_MoveComplete(ByVal adReason As _
ADODB.EventReasonEnum, ByVal pError As _
ADODB.Error, adStatus As ADODB.EventStatusEnum, _
ByVal pRecordset As ADODB.Recordset)
NomorData = rsCariData.AbsolutePosition
lblStatus.Caption = "Data ke-" & CStr(NomorData) & "" & _
"dari " & rsCariData.RecordCount
End Sub
'Untuk mencari sembarang data mulai record pertama
'di seluruh field ybt
Private Sub cmdFindFirst_Click()
Dim adoCari As Recordset
adoPrimaryRS.MoveFirst
Set adoCari = New Recordset
If Cari = "" Then
Cari = UCase(InputBox("Masukkan data apa saja " & _
"yang diketahui: ", "Cari Data"))
Else
Cari = Cari1
End If
If StrPtr(Cari) = 0 Or Cari = "" Then Exit Sub
Ulang:
If adoPrimaryRS.EOF And adoPrimaryRS.RecordCount > 0 Then
cmdLast_Click
MsgBox "Data " & Cari & " tidak ditemukan!", _
vbCritical, "Tidak Ditemukan"
FileName = "Info.txt"
Open FileName For Output As #1
frmInfo.Text1 = "Data " & Cari & " tidak ditemukan!"
Print #1, frmInfo.Text1.Text
Close #1
Open FileName For Input As #1
frmInfo.Text1.Text = Input(LOF(1), 1)
Close #1
Exit Sub
End If
For i = 0 To 4
Hasil = UCase(txtFields(i).Text)
If InStr(1, UCase(txtFields(i).Text), UCase(Cari)) > 0 Then
FileName = "Info.txt"
Open FileName For Output As #1
frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text)
frmInfo.Text1 = "" & frmInfo.Text1.Text & "Ditemukan data '" & Cari & "' pada:" & vbCrLf & _
"----------------------" & String(Len(Cari) + 1, "-") & "" & vbCrLf & _
""
Print #1, frmInfo.Text1.Text
Close #1
For j = 0 To 4
Hasil = UCase(txtFields(j).Text)
If InStr(1, UCase(txtFields(j).Text), UCase(Cari)) > 0 Then
Cari1 = Cari
'Jika ketemu, beritahu user di field
'mana saja data yg dicari berada
Open FileName For Output As #1
frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text)
frmInfo.Text1 = "" & frmInfo.Text1.Text & "" & vbCrLf & _
" Record ke-" & CStr(adoPrimaryRS.AbsolutePosition) & "" & vbCrLf & _
" - Nama field: " & txtFields(j).DataField & "" & vbCrLf & _
" - Isi field : " & txtFields(j).Text & "" & vbCrLf & _
" - Kolom ke : " & j + 1 & " di tabel."
cmdFindFirst.Enabled = False
frmInfo.cmdFindFirst.Enabled = False
Print #1, frmInfo.Text1.Text
Close #1
Open FileName For Input As #1
frmInfo.Text1.Text = Input(LOF(1), 1)
frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text) + 1
Close #1
frmInfo.Show
SendKeys "{Home}+{End}"
Else
End If
Next j
Exit Sub
Else
End If
Next i
'Jika di record I tdk ketemu, maju ke record berikut
adoPrimaryRS.MoveNext
GoTo Ulang
End Sub
'Untuk mencari sembarang data pada record berikutnya
'di seluruh field mulai record I s.d. terakhir
'di mana kriteria pencarian telah diketahui
'pada saat pencarian pertama di atas...
Private Sub cmdFindNext_Click()
Cari1 = Cari
'Jika belum pernah pencarian pertama,
If Len(Trim(Hasil)) = 0 Then
'MsgBox "Klik dulu tombol Find First", vbCritical, "Find First"
cmdFindFirst_Click
Exit Sub
End If
'Jika sudah pernah dicari sebelumnya
adoPrimaryRS.MoveNext
Ulang:
'Jika tdk ketemu
If adoPrimaryRS.EOF And adoPrimaryRS.RecordCount > 0 Then
cmdLast_Click
MsgBox "Data " & Cari & " tidak ditemukan!", vbCritical, "Tidak Ditemukan"
Exit Sub
End If
For n = 0 To 4
Hasil = UCase(txtFields(n).Text)
If InStr(1, UCase(txtFields(n).Text), UCase(Cari1)) > 0 Then
For m = 0 To 4
Hasil = UCase(txtFields(m).Text)
If InStr(1, UCase(txtFields(m).Text), UCase(Cari1)) > 0 Then
'Jika ketemu, beritahu user di field
'mana saja data yg dicari berada
FileName = "Info.txt"
Open FileName For Output As #1
frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text)
frmInfo.Text1 = "" & frmInfo.Text1.Text & "" & vbCrLf & _
" Record ke-" & CStr(adoPrimaryRS.AbsolutePosition) & "" & vbCrLf & _
" - Nama field: " & txtFields(m).DataField & "" & vbCrLf & _
" - Isi field : " & txtFields(m).Text & "" & vbCrLf & _
" - Kolom ke : " & m + 1 & " di tabel."
Print #1, frmInfo.Text1.Text
Close #1
Open FileName For Input As #1
frmInfo.Text1.Text = Input(LOF(1), 1)
frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text) + 1
Close #1
frmInfo.Show
SendKeys "{Home}+{End}"
Else
End If
Next m
Exit Sub
Else
End If
Next n
adoPrimaryRS.MoveNext
GoTo Ulang
End Sub
Private Sub cmdView_Click()
frmInfo.Show
End Sub
Private Sub Form_Load()
On Error GoTo Pesan
HasilBatal = False
Set db = New Connection
db.CursorLocation = adUseClient
'Jika Anda menggunakan database tanpa dipassword dalam satu folder
'dengan aplikasi, Anda dapat menggunakan db.Open di bawah ini...
'db.Open "PROVIDER=MSDataShape;Data PROVIDER=" & _
' "Microsoft.Jet.OLEDB.3.51;Data Source=" _
' & App.Path & "\mahasiswa.mdb;"
'Jika Anda menggunakan database yang dipassword, dalam satu folder
'dengan aplikasi, Anda dapat menggunakan db.Open di bawah ini...
'db.Open "PROVIDER=MSDataShape;Data PROVIDER=" & _
' "Microsoft.Jet.OLEDB.3.51;Data Source=" _
' & App.Path & " \mahasiswa.mdb;Jet OLEDB:" & _
' "Database Password=passwordanda;"
'Jika Anda menggunakan DSN (ODBC) untuk koneksi ke database,
'gunakan db.Open di bawah...
db.Open "PROVIDER=MSDataShape;Data PROVIDER=MSDASQL;" & _
"dsn=mahasiswa;uid=;pwd=;"
Set adoPrimaryRS = New Recordset
'Dalam contoh ini kita menampilkan data keseluruhan di grid bawah,
'sementara untuk setiap data yang ditampilkan berada di atasnya...
'Sesuaikan setiap field di bawah dengan field di database Anda...
adoPrimaryRS.Open "SHAPE {select NIM,Nama,Nippos,Alamat," & _
"Tgl_lahir from t_mhs Order by NIM} " & _
"AS ParentCMD APPEND ({select NIM," & _
"Nama,Nippos,Alamat,Tgl_lahir FROM t_mhs " & _
"ORDER BY NIM } AS ChildCMD RELATE NIM " & _
"TO NIM) AS ChildCMD", db, _
adOpenStatic, adLockOptimistic
Dim oText As TextBox
'Hubungkan setiap textbox ke recordset
For Each oText In Me.txtFields
Set oText.DataSource = adoPrimaryRS
Next
'Hubungkan recordset ke grid (tabel)
Set grdDataGrid.DataSource = adoPrimaryRS.DataSource
mbDataChanged = False
Kunci 'Kunci tampilan data di bagian atas
grdDataGrid.Enabled = True
'Jika database kosong, siap-siap untuk menambah data...
If adoPrimaryRS.RecordCount < 1 Then
MsgBox "Database masih kosong!", vbCritical, _
"Database Kosong"
BukaKunci 'Buka kunci entrian terlebih dulu...
cmdAdd_Click
End If
Exit Sub
Pesan: 'Jika menggunakan DSN, berarti belum konek
MsgBox Err.Number & " - " & Err.Description
End 'dan langsung selesai dengan aplikasi
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'End
Set adoPrimaryRS = Nothing 'Bersihkan memori
db.Close 'Tutup database
Set db = Nothing 'Bersihkan memori
End Sub
'Ini untuk memeriksa penekanan tombol di keyboard...
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If mbEditFlag Or mbAddNewFlag Then Exit Sub
Select Case KeyCode
Case vbKeyEscape
cmdClose_Click
Case vbKeyEnd
cmdLast_Click
Case vbKeyHome
cmdFirst_Click
Case vbKeyUp, vbKeyPageUp
If Shift = vbCtrlMask Then
cmdFirst_Click
Else
cmdPrevious_Click
End If
Case vbKeyDown, vbKeyPageDown
If Shift = vbCtrlMask Then
cmdLast_Click
Else
cmdNext_Click
End If
End Select
End Sub
'Normalkan mouse jika sudah selesai
Private Sub Form_Unload(Cancel As Integer)
Screen.MousePointer = vbDefault
End Sub
'Menampilkan record pada posisi aktif dari recordset...
Private Sub adoPrimaryRS_MoveComplete(ByVal adReason As _
ADODB.EventReasonEnum, ByVal pError As _
ADODB.Error, adStatus As ADODB.EventStatusEnum, _
ByVal pRecordset As ADODB.Recordset)
NomorData = adoPrimaryRS.AbsolutePosition
lblStatus.Caption = "Record ke-" & CStr(NomorData) & " dari " _
& adoPrimaryRS.RecordCount
End Sub
Private Sub adoPrimaryRS_WillChangeRecord(ByVal adReason As _
ADODB.EventReasonEnum, ByVal cRecords As Long, _
adStatus As ADODB.EventStatusEnum, _
ByVal pRecordset As ADODB.Recordset)
'Selain di setiap prosedur, Anda juga bisa membuat validasi
'di sini. Ini adalah event yang dipanggil ketika
'kejadian berikut terjadi...
Dim bCancel As Boolean
Select Case adReason
Case adRsnAddNew
Case adRsnClose
Case adRsnDelete
Case adRsnFirstChange
Case adRsnMove
Case adRsnRequery
Case adRsnResynch
Case adRsnUndoAddNew
Case adRsnUndoDelete
Case adRsnUndoUpdate
Case adRsnUpdate
End Select
If bCancel Then adStatus = adStatusCancel
End Sub
Private Sub cmdAdd_Click()
On Error GoTo AddErr
With adoPrimaryRS
If Not (.BOF And .EOF) Then
mvBookMark = .Bookmark
End If
BukaKunci 'Buka kunci entrian terlebih dulu...
.AddNew
lblStatus.Caption = "Add record"
mbAddNewFlag = True
SetButtons False
End With
EnablePicture picUtility, False
grdDataGrid.Enabled = False 'Kunci tabel agar tdk error
On Error Resume Next
txtFields(0).SetFocus
Exit Sub
AddErr:
MsgBox Err.Description
End Sub
Private Sub cmdDelete_Click()
On Error GoTo DeleteErr
If MsgBox("Yakin record ini mau dihapus", _
vbQuestion + vbYesNo, "Hapus Record") _
<> vbYes Then
Exit Sub
End If
With adoPrimaryRS
.Delete
.MoveNext
If .EOF Then .MoveLast
End With
Exit Sub
DeleteErr:
MsgBox Err.Description
End Sub
Private Sub cmdRefresh_Click()
'Refresh sangat penting untuk aplikasi multi user
On Error GoTo RefreshErr
If HasilBatal = True Then
SetButtons True
HasilBatal = False
End If
cmdAdd.Enabled = True
cmdEdit.Enabled = True
cmdDelete.Enabled = True
cmdRefresh.Enabled = True
Set grdDataGrid.DataSource = Nothing
Set adoPrimaryRS = New Recordset
adoPrimaryRS.Open "SHAPE {select NIM,Nama,Nippos,Alamat," & _
"Tgl_lahir from t_mhs Order by NIM} " & _
"AS ParentCMD APPEND ({select NIM," & _
"Nama,Nippos,Alamat,Tgl_lahir FROM t_mhs " & _
"ORDER BY NIM } AS ChildCMD RELATE NIM " & _
"TO NIM) AS ChildCMD", db, _
adOpenStatic, adLockOptimistic
Dim oText As TextBox
'Hubungkan textbox dengan recordset
For Each oText In Me.txtFields
Set oText.DataSource = adoPrimaryRS
Next
Set grdDataGrid.DataSource = adoPrimaryRS.DataSource
grdDataGrid.Enabled = True
Exit Sub
RefreshErr:
cmdAdd.Enabled = False
cmdEdit.Enabled = False
cmdUpdate.Enabled = False
cmdDelete.Enabled = False
cmdCancel.Enabled = False
cmdRefresh.Enabled = True
mbEditFlag = False
mbAddNewFlag = False
adoPrimaryRS.CancelUpdate
If mvBookMark <> 0 Then
adoPrimaryRS.Bookmark = mvBookMark
Else
adoPrimaryRS.MoveFirst
End If
mbDataChanged = False
HasilBatal = True
cmdRefresh_Click 'Jadi, langsung otomatis refresh
Exit Sub
End Sub
Private Sub cmdEdit_Click()
On Error GoTo EditErr
EnablePicture picUtility, False
lblStatus.Caption = "Edit record"
mbEditFlag = True
SetButtons False
BukaKunci 'Buka kunci textbox agar bisa diedit
Exit Sub
EditErr:
MsgBox Err.Description
End Sub
Private Sub cmdCancel_Click()
On Error Resume Next
Kunci 'Kunci kembali textbox
cmdRefresh_Click
grdDataGrid.Enabled = True
If HasilBatal = True Then
EnablePicture picUtility, True
Exit Sub
End If
SetButtons True
mbEditFlag = False
mbAddNewFlag = False
adoPrimaryRS.CancelUpdate
If mvBookMark > 0 Then
adoPrimaryRS.Bookmark = mvBookMark
Else
adoPrimaryRS.MoveFirst
End If
mbDataChanged = False
EnablePicture picUtility, True
End Sub
Private Sub cmdUpdate_Click()
Dim i As Integer
On Error GoTo UpdateErr
For i = 0 To 4
If txtFields(i).Text = "" Then
MsgBox "Semua data harus diisi!", _
vbCritical, "Isi Semua Data"
txtFields(i).SetFocus
Exit Sub
End If
Next i
Set cekID = New Recordset
cekID.Open "SELECT * FROM t_mhs WHERE NIM=" & _
"'" & Trim(txtFields(0).Text) & "'", db
If cekID.RecordCount > 0 And mbAddNewFlag Then
MsgBox "NIM sudah ada. Ganti dengan yang lain!", _
vbCritical, "NIM Sudah Ada"
txtFields(0).SetFocus: SendKeys "{Home}+{End}"
Set cekID = Nothing
Exit Sub
End If
adoPrimaryRS.UpdateBatch adAffectAll
EnablePicture picUtility, True
If mbAddNewFlag Then
adoPrimaryRS.MoveLast
End If
mbEditFlag = False
mbAddNewFlag = False
SetButtons True
mbDataChanged = False
Kunci 'Kunci kembali textbox entrian
grdDataGrid.Enabled = True
NomorData = adoPrimaryRS.AbsolutePosition
lblStatus.Caption = "Record ke-" & CStr(NomorData) & _
" dari " & adoPrimaryRS.RecordCount
Exit Sub
UpdateErr:
MsgBox Err.Description
End Sub
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub cmdFirst_Click()
On Error GoTo GoFirstError
adoPrimaryRS.MoveFirst
mbDataChanged = False
Exit Sub
GoFirstError:
MsgBox Err.Description
End Sub
Private Sub cmdLast_Click()
On Error GoTo GoLastError
adoPrimaryRS.MoveLast
mbDataChanged = False
Exit Sub
GoLastError:
MsgBox Err.Description
End Sub
Private Sub cmdNext_Click()
On Error GoTo GoNextError
If Not adoPrimaryRS.EOF Then adoPrimaryRS.MoveNext
If adoPrimaryRS.EOF And adoPrimaryRS.RecordCount > 0 Then
Beep
adoPrimaryRS.MoveLast 'Jika mencapai akhir file...
End If
mbDataChanged = False 'Tampilkan record yang aktif
Exit Sub
GoNextError:
MsgBox Err.Description
End Sub
Private Sub cmdPrevious_Click()
On Error GoTo GoPrevError
If Not adoPrimaryRS.BOF Then adoPrimaryRS.MovePrevious
If adoPrimaryRS.BOF And adoPrimaryRS.RecordCount > 0 Then
Beep
adoPrimaryRS.MoveFirst 'Jika mencapai awal file...
End If
mbDataChanged = False 'Tampilkan record yang aktif
Exit Sub
GoPrevError:
MsgBox Err.Description
End Sub
Private Sub SetButtons(bVal As Boolean)
cmdAdd.Enabled = bVal
cmdEdit.Enabled = bVal
cmdUpdate.Enabled = Not bVal
cmdCancel.Enabled = Not bVal
cmdDelete.Enabled = bVal
cmdClose.Enabled = bVal
cmdRefresh.Enabled = bVal
cmdNext.Enabled = bVal
cmdFirst.Enabled = bVal
cmdLast.Enabled = bVal
cmdPrevious.Enabled = bVal
End Sub
Private Sub txtFields_KeyPress(Index As Integer, KeyAscii As Integer)
Select Case Index 'Agar ketika ditekan enter dapat pindah...
Case 0 To 4
If KeyAscii = 13 Then SendKeys "{Tab}"
End Select
End Sub
Sub Kunci() 'Kunci textbox dan grid
Dim i As Integer
For i = 0 To 4
txtFields(i).Locked = True
Next i
grdDataGrid.Enabled = False
End Sub
Sub BukaKunci() 'Buka kunci textbox dan grid
Dim i As Integer
For i = 0 To 4
txtFields(i).Locked = False
Next i
grdDataGrid.Enabled = True
End Sub
'--------------- Akhir coding di frmData -------------------
'--------------- Coding di frmInfo ---------------------
Private Sub cmdClearSearch_Click()
'tombol cmdClearSearch di frmData diklik...
frmData.cmdClearSearch.Value = True
End Sub
Private Sub cmdFindFirst_Click()
'tombol FindFirst di frmData diklik...
frmData.cmdFindFirst.Value = True
End Sub
Private Sub cmdFindNext_Click()
'tombol FindNext di frmData diklik...
frmData.cmdFindNext.Value = True
End Sub
Private Sub cmdOK_Click()
Me.Hide
End Sub
Private Sub cmdSimpan_Click()
On Error GoTo Batal 'Jika batal menyimpan file pergi ke Batal
If Text1.Text <> "" Then
With Dialog
.DialogTitle = "Simpan sebagai file teks"
.Filter = "*.txt|*.txt" 'Hanya file txt yg bisa disimpan
.FileName = "HasilCari"
.ShowSave 'Tampilkan kotak dialog simpan file
Open .FileName For Output As #1 'Simpan ke file
Print #1, Text1.Text
Close #1 'Tutup file
End With: Exit Sub
Else
MsgBox "Belum ada hasil pencarian!", vbCritical, "Kosong"
Exit Sub
End If
Batal: 'Label jika batal menyimpan
Exit Sub 'Langsung keluar dari prosedur ini
End Sub
'--------------- Akhir coding di frmInfo -------------------
Tags:
contoh program vb6, contoh fungsi di vb6, cara penggunaan fungsi vb, tutorial vb6, download tutorial vb6, vb6 tutorial download, dasar dasar vb6, belajar vb6, cara mudah belajar vb6, vb6 artikel download, vb6 blog, contoh program vb6, artikel vb6, semua tentang vb6, vb6 api, cara menggunakan module, cara menggunakan class module
Posting Komentar untuk "Template Source Code VB6+Database Ms.Access"