Jumat, 23 September 2011

RESTOR DATABASE dengan Vb6.0

RESTOR DATABASE
-          Buat Project baru pada VB 6.0 -> Pilih Standar EXE
-          Pilih Menu Project -> Componen (Ctrl +T) -> Beri Conteng Pada
1.      Microsoft ADO Data Control 6.0 (OLDB)
2.      Microsoft Common Dialog Control 6.0 (SP6)
3.      Microsoft Data Grid Control 6.0 (OLDB)
4.      Microsoft Windows Common Control 6.0 (SP6)
-          Pilih Applay  -> OK
Buat Rancangan Form Seperti Gambar Dibawah ini

 

Coding
Buat Modul Ketikan Code Berikut

Public Con As ADODB.Connection
Public Con1 As ADODB.Connection
Public rs As ADODB.Recordset
Public rs1 As ADODB.Recordset


Sub Connects()
On Error Resume Next
Set Con = New ADODB.Connection
Con.Provider = "Microsoft.Jet.OLEDB.4.0"
Con.Open FrmConection.TxtConection
End Sub


Sub DisConnects()
On Error Resume Next
Con.Close
End Sub


Sub Main()
   FrmMonitor.Show
End Sub


Ketikkan Kode Pada Form

Private Sub Command1_Click()                                      'Mengambil Database
On Error Resume Next
Dim buka As String
With CommonDialog1
.Filter = "MS Acces (*.mdb) |*.mdb;|Acces 2007-2010 (*.Accdb)|*.Accdb|all files|*.*" 'Menyaring Tipe Database

.DialogTitle = "Open Database"
.FileName = ""             'Membersihkan file name (URL)
.ShowOpen
buka = .FileName
If .FileName = "" Then
Exit Sub
Else
TxtConection.Text = buka                                                     'File Name (Hal Terpenting)
Label2.Caption = "Database Title = " & .FileTitle                'Nama Data
Label3.Caption = "Database Prenter = " & .PrinterDefault   'Status
Label4.Caption = "Database Copies = " & .Copies               'Jumlah Copy
Label5.Caption = "FilterIndex  = " & .FilterIndex                'Index Penyaringan data

FrmConection.Caption = "Conection OK"  'Merubah title Form
End If
End With
End Sub


Private Sub Command2_Click()
If TxtConection.Text = "No Conection" Then          
                           'Jika tidak ada Database yang dipilih maka
MsgBox "Can not Conect Database ! Please Chouse Database", vbCritical 'Beri Pesan
Else                    ' Jika tidak (ada database yang dipilih)
Me.Hide
Restor.Show
Restor.Label4.Caption = Label2.Caption
Restor.Label5.Caption = Label4.Caption
End If
End Sub


Private Sub Command3_Click()
Unload Me       'tutup Form
End Sub

 

Ketikkan pada form Kode Berikut

Dim rsimpor As ADODB.Recordset


Sub listing()
'Memasukkan Nama Tabel Ke List data
On Error Resume Next
List1.Clear
Set rs = Con.OpenSchema(adSchemaTables)
    Do Until rs.EOF
        If Left$(rs.Fields(2), 4) <> "MSys" Then
            If rs.Fields!TABLE_TYPE = "TABLE" Then
                List1.AddItem rs.Fields(2)
            End If
        End If
        rs.MoveNext
    Loop
End Sub


Private Sub Command1_Click()
'Kembali ke Conection Database yang Di Restor
Unload Me
FrmConection.Show
End Sub


Private Sub Command2_Click()
DisConnects
FileCopy App.Path & "\kosong.mdb", Text1.Text    'mengkopy data ke kosong database
Connects                                         'memutus Cinection
pb1.Value = 0
pb1.Max = List1.ListCount
With List1
    For i = 0 To List1.ListCount - 1
    List1.ListIndex = i
    pb1.Value = i + 1
         SQLImpor = "SELECT [" & List1.Text & "].*" & _
                     " INTO [" & List1.Text & "] IN '" & Text1.Text & _
                     "' FROM [" & List1.Text & "]"
       
         Con.Execute SQLImpor
     Label3.Caption = "Backup Tabel : " & List1.Text
    Label1.Caption = "Value = " & pb1.Value
    Next i
End With
MsgBox "Back Up Data telah selesai", vbInformation
pb1.Value = 0
End Sub


Private Sub Command3_Click() ' Melihat Database
Unload Me
FrmMonitor.Show
End Sub


Private Sub Form_Load()
Connects
listing
Text1.Text = App.Path & "\Databese\db1.mdb" 'Tempat Pentimpana Database Yang di Restor
    Label2.Caption = List1.ListCount
End Sub


 
 

Kode :
Option Explicit
Private koneksi As ADODB.Connection


Private Function konek() As Boolean
    On Error GoTo out
        Set koneksi = New ADODB.Connection
        koneksi.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\Databese\db1.mdb;Persist Security Info=False"
        koneksi.CursorLocation = adUseClient
        konek = True
out:
End Function


Sub listing() 'Menampilkan Nama-nama Tabel Ke List & Combo box
On Error Resume Next
List1.Clear
Set Adodc2.Recordset = koneksi.OpenSchema(adSchemaTables)
    Do Until Adodc2.Recordset.EOF
        If Left$(Adodc2.Recordset.Fields(2), 4) <> "MSys" Then
            If Adodc2.Recordset.Fields!TABLE_TYPE = "TABLE" Then
                List1.AddItem Adodc2.Recordset.Fields(2)
                Combo1.AddItem Adodc2.Recordset.Fields(2)
            End If
        End If
        Adodc2.Recordset.MoveNext
    Loop
End Sub


Private Sub Command1_Click()
Call Form_Load
    Adodc1.ConnectionString = koneksi.ConnectionString
    Adodc1.RecordSource = Combo1
    Set DataGrid1.DataSource = Adodc1
    Label5.Caption = Adodc1.Recordset.RecordCount   'Menampilkan Jumlah Baris Tabel
    Label7.Caption = App.Path & "\Database\db1.mdb" 'Menampilkan FileName
    Text1.Text = Adodc1.ConnectionString            'Menampilkan Conection
End Sub


Private Sub Command2_Click() 'Disconct
 koneksi.Close
 Unload Me
 Me.Show
End Sub


Private Sub Command3_Click() 'Exit
End
End Sub


Private Sub Form_Load()
If Not konek() Then
        MsgBox "Gak bisa terhubung ke database!", vbCritical
        End
    End If
    listing  'Memanggil Prosedure Mengisi List Box
    Text1.Text = Adodc1.ConnectionString
End Sub





Download  Projectnya di Sini : Restor Database With VB 6.0.rar

5 komentar:

  1. Very Simple dan Bermanfaat .. :D
    Mampir yah ke blog ane :D

    BalasHapus
  2. Komentar ini telah dihapus oleh pengarang.

    BalasHapus
  3. mau nanya ni soal data base yang sudah di buat di acces emang harus di savenya dengan eksitensi *.Mbd mohon bantuannnya ya

    BalasHapus
    Balasan
    1. Tergantung Driver Conecting-nya,
      kalo mas peke "ODBC driver for MS Access 2010" bebrarti formatnya (*.accdb)

      Hapus