Super Shared

Option Explicit
Dim db As ADODB.Connection
Dim adoPrimaryRSLoginSiswa As ADODB.Recordset

Private Sub Form_Load()
On Error GoTo err
 Set db = New ADODB.Connection
 db.CursorLocation = adUseClient
 db.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;" & _
 "Data Source=" & App.Path & "DBPembelajaran.mdb;"
err:
 If db.State = 1 Then
 MsgBox "Terkoneksi dengan database"
 ElseIf db.State = 0 Then
 MsgBox "Tidak Terkoneksi dengan database.", vbInformation, "Error"
 End If
End Sub
 

Private Sub Form_Load()
On Error GoTo ERR
 Dim DBBerPassword
 Set DBBerPassword = New ADODB.Connection
 DBBerPassword.CursorLocation = adUseClient
 DBBerPassword.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "DBPembelajaran - Copy.mdb" & ";Persist Security Info=False;Mode=12;Jet OLEDB:Database Password=TulisPasswordnya"
ERR:
 If DBBerPassword.State = 1 Then
 MsgBox "Terkoneksi dengan database"
 ElseIf DBBerPassword.State = 0 Then
 MsgBox "Tidak Terkoneksi dengan database.", vbInformation, "Error"
 End If
End Sub

Private Sub Command1_Click()
On Error GoTo err
 Set adoPrimaryRSLoginSiswa = New ADODB.Recordset
 adoPrimaryRSLoginSiswa.Open "TblSiswaLogin", db, adOpenStatic, adLockOptimistic
err:
 If adoPrimaryRSLoginSiswa.State = 1 Then
 MsgBox "Terkoneksi dengan Tabel"
 ElseIf adoPrimaryRSLoginSiswa.State = 0 Then
 MsgBox "Tabel tidak ditemukan, cek kembali tabel yang ada dalam database.", vbInformation, "Error"
 End If
End Sub

Private Sub Command2_Click()
 adoPrimaryRSLoginSiswa.MoveFirst
 MsgBox "NAMA FIELD : " & adoPrimaryRSLoginSiswa.Fields(0).Name & _
 vbCrLf & "ISI FIELD RECORD PERTAMA : " & adoPrimaryRSLoginSiswa.Fields(0).Value, vbInformation
End Sub

Private Sub Command3_Click()
 Set Me.Text1.DataSource = adoPrimaryRSLoginSiswa
 Set Me.Text2.DataSource = adoPrimaryRSLoginSiswa
 
 Me.Text1.DataField = "NAMA_SISWA"
 Me.Text2.DataField = "NIS"
 
End Sub

Private Sub Command4_Click()
 DI PROPERTY Text3 MultiLine pilih True
 DI PROPERTY Text3 ScrollBars pilih 3
 Text3.Text = "MENGECEK FIELD NIS KOSONG"
 adoPrimaryRSLoginSiswa.MoveFirst
 While Not adoPrimaryRSLoginSiswa.EOF
 If IsNull(adoPrimaryRSLoginSiswa.Fields("NIS")) = True Then
 Text3.Text = Text3.Text & vbCrLf & "NO : " & adoPrimaryRSLoginSiswa.AbsolutePosition & ". " & adoPrimaryRSLoginSiswa.Fields("NAMA_SISWA").Value & " KOSONG"
 ElseIf IsNull(adoPrimaryRSLoginSiswa.Fields("NIS")) = False Then
 Text3.Text = Text3.Text & vbCrLf & "NO : " & adoPrimaryRSLoginSiswa.AbsolutePosition & " TIDAK KOSONG "
 End If
 adoPrimaryRSLoginSiswa.MoveNext
 Wend
End Sub

Private Sub Command5_Click()
 If adoPrimaryRSLoginSiswa.AbsolutePosition = 1 Or adoPrimaryRSLoginSiswa.RecordCount = 0 Then
 Beep
 Else
 adoPrimaryRSLoginSiswa.MoveFirst Ke record Pertama
 End If
 Me.Label2.Caption = "NO. " & adoPrimaryRSLoginSiswa.AbsolutePosition
End Sub

Private Sub Command6_Click()
 If adoPrimaryRSLoginSiswa.AbsolutePosition = 1 Or adoPrimaryRSLoginSiswa.RecordCount = 0 Then
 Beep
 Else
 adoPrimaryRSLoginSiswa.MovePrevious "Ke record Sebelumnya End If
 Me.Label2.Caption = "NO. " & adoPrimaryRSLoginSiswa.AbsolutePosition
End Sub

Private Sub Command7_Click()
 If adoPrimaryRSLoginSiswa.AbsolutePosition = adoPrimaryRSLoginSiswa.RecordCount Or adoPrimaryRSLoginSiswa.RecordCount = 0 Then
 Beep
 Else
 adoPrimaryRSLoginSiswa.MoveNext Ke record Selanjutnya End If
 Me.Label2.Caption = "NO. " & adoPrimaryRSLoginSiswa.AbsolutePosition
End Sub

Private Sub Command8_Click()
 If adoPrimaryRSLoginSiswa.AbsolutePosition = adoPrimaryRSLoginSiswa.RecordCount Or adoPrimaryRSLoginSiswa.RecordCount = 0 Then
 Beep
 Else
 adoPrimaryRSLoginSiswa.MoveLast Ke record Terakhir End If
 Me.Label2.Caption = "NO. " & adoPrimaryRSLoginSiswa.AbsolutePosition
End Sub

Private Sub Command9_Click()
Dim NamaTabel As ADODB.Recordset
Set NamaTabel = db.OpenSchema(adSchemaTables)
 While Not NamaTabel.EOF
 If NamaTabel!TABLE_TYPE = "TABLE" Then Text4.Text = Text4.Text & vbCrLf & NamaTabel!TABLE_NAME
 NamaTabel.MoveNext
 Wend
End Sub

Private Sub Command10_Click()
Dim Column As ADODB.Field
If adoPrimaryRSLoginSiswa.State = adStateOpen Then
 For Each Column In adoPrimaryRSLoginSiswa.Fields
 Text5.Text = Text5.Text & vbCrLf & Column.Name
 Next
End If
End Sub

Private Sub Command11_Click()
 Dim Cmd As New ADODB.Command
 Cmd.ActiveConnection = db
 Cmd.CommandText = "create table TabelBaru (NAMA_SISWA varchar(20), KELAS varchar(5), TENTANG_SISWA LongChar, Foto LongBinary)"
 Cmd.Execute
End Sub

Private Sub Command12_Click()
Tambahkan references Microsoft ADO Ext. 2.1 for DDL and Security atau versi lebih tinggi
 Dim Xconx As ADODB.Connection
 Dim Xcmd As ADODB.Command
 Dim Xrs As ADODB.Recordset
 Dim m_MDBdatabase As String
 Dim m_MDBtable As String

Tambahkan columns di tabel yang sudah ada
 Dim ADOXcat As ADOX.Catalog
 Dim MStbl As ADOX.table
 Dim MScol As ADOX.Column
 
 m_MDBdatabase = App.Path & "DBPembelajaran.mdb"
 m_MDBtable = "TblSiswaLogin"

Membuat koneksi
 Set Xconx = New ADODB.Connection
 Set Xcmd = New ADODB.Command
 Set Xrs = New ADODB.Recordset
 Set Xconx = CreateObject("ADODB.Connection")
 Xconx.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
 "Persist Security Info=False;" & _
 "Data Source=" & m_MDBdatabase
 Set Xrs = CreateObject("ADODB.Recordset")
 Xrs.CursorLocation = adUseServer

Mengirimkan MDB dan table ke catalog
 Set ADOXcat = New ADOX.Catalog
 ADOXcat.ActiveConnection = _
 "Provider=Microsoft.Jet.OLEDB.4.0;" & _
 "Data Source=" & m_MDBdatabase
 Set MStbl = ADOXcat.Tables(m_MDBtable)

Menambahkan columns/Field ke tabel yang ada
 MStbl.Columns.Append "NILAI", adDouble
 MStbl.Columns.Append "KETERANGAN", adVarWChar, 255
 MStbl.Columns.Append "TANGGAL_LAHIR", adDate
 
Bersihkan
 ADOXcat.ActiveConnection.Close
 Set ADOXcat = Nothing
 Set MStbl = Nothing
 Set MScol = Nothing
 Set Xconx = Nothing
 Set Xcmd = Nothing
 Set Xrs = Nothing
End Sub

Private Sub Command13_Click()
 db.Execute "DELETE FROM TBLsiswalogin"
End Sub

Private Sub Command14_Click()
Tambahkan references Microsoft DAO 3.6 Object Library atau versi lebih tinggi
 Dim ConMateri As Database, AdoDao%
 Set ConMateri = OpenDatabase(App.Path & "DBPembelajaran.MDB", False, False, "MS Access;Pwd=dbpwd")
 Dim TbDef As TableDefs
 Set TbDef = ConMateri.TableDefs
 ConMateri.TableDefs.Delete "NamaTabelYangAkanDiHapus"
End Sub