Setelah bepanjang lebar membicarakan Addins, maka sekarang kita akan menerapkannya dalam sebuah project yang bermanfaat (jika dilanjutkan memprogramnya) yaitu: generator database yang sangat sederhana (hanya untuk MS Access saja, untuk database lainnya, silakan modifikasi kodenya). Project ini hanya akan mengenerate GUI-nya saja (tanpa kode), adapun jika jika ingin menambahkan kode-kode yang sesuai Anda dapat merujuk pada tautan di samping, menambah kode pada module (tentu saja setelah dimodifikasi dan disesuaikan).
Langkah-Langkah:
Kode pada modDatabase:
READ MORE - Membaca Struktur Table dan Menerapkannya Dalam GUI
Langkah-Langkah:
- Buat project Addin
- Masukan kode-kode di bawah ini:
Public VBInstance As VBIDE.VBE
Public Connect As Connect
Option Explicit
Dim strCon As String
Private Sub cboTables_Click()
Set cat = New ADOX.Catalog
Set cat.ActiveConnection = DBase
Dim c As ADOX.Column
lstAll.Clear
For Each c In cat.Tables(GetTabelValidName(cboTables.Text)).Columns
lstAll.AddItem c.Name
Next
If lstAll.ListCount > 0 Then lstAll.ListIndex = 0
Set cat = Nothing
End Sub
Private Function GetTabelValidName(strName As String) As String
Dim s() As String
s = Split(strName, " : ")
GetTabelValidName = s(1)
End Function
Private Sub cmdConnect_Click()
On Error GoTo ErrHandler
strCon = getADOConnectionString()
If strCon = "" Then Exit Sub
txtCon.Text = strCon
If OpenDataBase(strCon) = True Then
FillComboWithTables
End If
Exit Sub
ErrHandler:
MsgBox Err.Number & vbNewLine & Err.Description, vbExclamation + vbOKOnly, "Connection Error"
lstAll.Clear
cboTables.Clear
End Sub
Private Function FillComboWithTables()
Set cat = New ADOX.Catalog
Set cat.ActiveConnection = DBase
Dim i As Integer
cboTables.Clear
lstAll.Clear
For i = 0 To cat.Tables.Count - 1
If cat.Tables(i).Type <> "SYSTEM TABLE" And cat.Tables(i).Type <> "ACCESS TABLE" Then
If cat.Tables(i).Type = "TABLE" Then
cboTables.AddItem "Table : " & cat.Tables(i).Name
Else
cboTables.AddItem "query : " & cat.Tables(i).Name
End If
End If
Next i
Set cat = Nothing
End Function
Private Sub Command1_Click()
AddFormAndControls Replace(GetTabelValidName(cboTables.Text), " ", "_"), GetTabelValidName(cboTables.Text)
End Sub
Private Function AddFormAndControls(f As String, c As String)
On Error Resume Next
Dim frm As VBIDE.VBComponent
Dim ctl As VBControl
Dim frmCurrent As VBForm
Dim i As Integer, x As Integer, y As Integer, k As Integer
Set frm = VBInstance.ActiveVBProject.VBComponents.Add(vbext_ct_VBForm)
Set frmCurrent = VBInstance.SelectedVBComponent.Designer
For i = 0 To lstAll.ListCount - 1
'kode di bawah ini untuk menambah TextBox
Set ctl = frmCurrent.VBControls.Add("VB.TextBox")
With ctl
.Properties("Name") = "txt" & Replace(lstAll.List(i), " ", "_")
If i = 0 Then
.Properties("Top") = 500
x = 500
Else
x = x + 400 'spasi (jarak) untuk TextBox
End If
.Properties("Top") = x
.Properties("Left") = 2500
.Properties("Width") = 4000
.Properties("Height") = 330
.Properties("Text") = lstAll.List(i)
'.properties dan lain-lain, disesuaikan kebutuhan
End With
If i = lstAll.ListCount - 1 Then
y = x + 2000 'Form Height
k = x + 900 'CommandButton Top
End If
'kode di bawah ini untuk menambah label
Set ctl = frmCurrent.VBControls.Add("VB.Label")
With ctl
.Properties("Name") = lstAll.List(i)
.Properties("Top") = x
.Properties("Left") = 465
.Properties("Width") = 2000
.Properties("Height") = 255
.Properties("Caption") = lstAll.List(i)
.Properties("BackStyle") = 0 'transparent
'.properties dan lain-lain, disesuaikan kebutuhan
End With
Next
Set ctl = frmCurrent.VBControls.Add("VB.CommandButton")
With ctl
.Properties("Name") = "cmdUpdate"
.Properties("Top") = k
.Properties("Left") = 5040
.Properties("Width") = 1455
.Properties("Height") = 375
.Properties("Caption") = "&Update"
'.properties dan lain-lain, disesuaikan kebutuhan
End With
Set ctl = frmCurrent.VBControls.Add("VB.CommandButton")
With ctl
.Properties("Name") = "cmdCancel"
.Properties("Top") = k
.Properties("Left") = 3480
.Properties("Width") = 1455
.Properties("Height") = 375
.Properties("Caption") = "&Cancel"
'.properties dan lain-lain, disesuaikan kebutuhan
End With
InsertOCX "{2CDCDF4C-4914-4DBC-99CB-12359BE472E1}"
Set ctl = frmCurrent.VBControls.Add("Liner.cLiner")
With ctl
.Properties("Top") = k - 300
.Properties("Left") = -5
.Properties("Width") = 7000
.Properties("Height") = 30
End With
With frm
.Properties("Name") = "frm" & f
.Properties("Width") = 7155
.Properties("Caption") = c
.Properties("Height") = y
End With
'--------------------------------------------------------------------------------------------------
'tambahkan kontrol lain-lain ThirdParty OCX
'tambahkan pula kode-kode yang sesuai
'maaf, belum dibuatkan....
'--------------------------------------------------------------------------------------------------
End Function
Public Function InsertOCX(ProgID As String) As Boolean
On Error GoTo ErrHandler
'Add OCX
VBInstance.ActiveVBProject.AddToolboxProgID ProgID
InsertOCX = True
Exit Function
ErrHandler:
InsertOCX = False
End Function
Kode pada modDatabase:
Option ExplicitKode pada modDataLinks: silakan copy dan pastekan dari tautan di samping module data links.
Public DBase As New ADODB.Connection
Public cat As ADOX.Catalog
Function OpenDataBase(sFilename As String) As Boolean
'// Membuat koneksi ke database
Set DBase = New ADODB.Connection
With DBase
.CursorLocation = adUseClient
.Open "Provider= Microsoft.Jet.OLEDB.4.0;Persist security info=False;Data Source=" & sFilename & ";Jet OLEDB:Database;"
End With
OpenDataBase = True
End Function
- Rubahlah menu Addins yang akan ditampilkan dengan merujuk pada link ini.
- Tambahkan satu OCX yang dibutuhkan download disini.
- Selesai. Anda bisa mengujinya sekarang, dengan cara mengcompilennya atau tanpa compile seperti posting yang telah ditulis terdahulu.
- Jika hasilnya sama seperti ini [download project jadi], maka saya ucapkan: selamat Anda berhasil!
