Template Source Code VB6+Database Ms.Access | DASAR PROGRAMER

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
Jika Anda menyukai Artikel di blog ini, Silahkan klik disini untuk berlangganan gratis via email, dengan begitu Anda akan mendapat kiriman artikel setiap ada artikel yang terbit di dasarprogrammer.blogspot.com

0 komentar:

Posting Komentar