I'm trying to write a VBA code, that would upload data to Access database using ADODB connection. The problem is that I want to check data integrity before upload, so checking for input mask format, allowed values, whether field is required, length of field, type of data. So far what I figured out, I would
- Let the user choose which database and what table to upload to (ADODB.OpenSchema)
- Connect with DAO to get information about inputmask and other (at least input mask can be done only by DAO)
- Connect to selected table, create empty recordset, disconnect (ADODB)
- Test data to parameters while building batch recordset, and ignore lines with wrtong data
- Upload data
Is there other commonly used way to test data for inputmask format, before uploading to database? Just give me directions, i'll google rest
See below what I have so far, if you are interested.
Thank you
Option Explicit
Option Base 1
Sub opentest()
Dim file As String, table As String
Dim outputarray As Variant
Dim cancelwork As Boolean
Dim coll As Collection
Set coll = New Collection
Dim adSchemaTables As Long, adOpenDynamic As Long, adLockBatchOptimistic As Long, adUseClient As Long 'named methods/properties must be defined as numbers for late binding
adOpenDynamic = 2
adLockBatchOptimistic = 4
adSchemaTables = 20
adUseClient = 3
With Application.FileDialog(msoFileDialogFilePicker) 'lets user select database
.Title = "Select Database"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
End
Else
file = CStr(.SelectedItems(1))
End If
End With
Dim cnn As Object, rs As Object ' late binding, should allow no need for ADO library reference in excel
Set cnn = createobject("ADODB.connection")
Set rs = createobject("ADODB.Recordset")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & file & ";" & "Persist Security Info=False"
Set rs = cnn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "link")) 'for linked tables
Do While Not rs.EOF
coll.Add CStr(rs("table_name"))
rs.MoveNext
Loop
Set rs = Nothing
Set rs = cnn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "table")) 'for actual tables
Do While Not rs.EOF
coll.Add CStr(rs("table_name"))
rs.MoveNext
Loop
Call ListBox(coll, table) 'lets the user select table where to upload
Set rs = Nothing
Set rs = createobject("ADODB.Recordset")
rs.CursorLocation = adUseClient
rs.Open "select * from " & table & " where false", cnn, adOpenDynamic, adLockBatchOptimistic 'connection
Set rs.ActiveConnection = Nothing 'disconnecting to build data
Call dataload(rs, cancelwork) 'calling dataload function
If cancelwork = True Then
Call closing(rs, cnn)
End
End If
Set rs.ActiveConnection = cnn
rs.UpdateBatch 'uploading data
Call closing(rs, cnn)
End Sub
Sub closing(rs As Object, cnn As Object)
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
End Sub
Private Sub ListBox(ByVal coll As Collection, ByRef table As String)
Dim item As Variant
For Each item In coll
ListBoxForm.ListBox1.AddItem (item)
Next item
ListBoxForm.Show
table = ListBoxForm.ListBox1.value
ListBoxForm.ListBox1.Clear
End Sub
Sub dataload(ByRef rs As Object, ByRef cancelwork As Boolean)
Dim loadarray() As Variant
Dim region As Range
Dim response As VbMsgBoxResult
On Error Resume Next
Set region = Application.InputBox(Prompt:="Select data to upload", Type:=8)
If region Is Nothing Then
End
End If
loadarray = region
If (UBound(loadarray, 2) - LBound(loadarray, 1) + 1) > rs.Fields.Count Then
MsgBox "Number of columns to be uploaded is greater then number of columns in database, ending"
cancelwork = True
Exit Sub
ElseIf (UBound(loadarray, 2) - LBound(loadarray, 1) + 1) < rs.Fields.Count Then
response = MsgBox("Number of columns to be uploaded is less then number of columns in database", vbOKCancel)
If response = vbCancel Then
cancelwork = True
Exit Sub
End If
End If
Set rs = recordsetload(rs, loadarray, region)
End Sub
Private Function recordsetload(rs As Object, loadarray As Variant, region As Range) As Object
Dim rowi As Long, columni As Long, rsrow As Long
For rowi = LBound(loadarray, 1) To UBound(loadarray, 1)
rs.AddNew
For columni = LBound(loadarray, 2) To UBound(loadarray, 2)
rs.Fields(columni - 1).value = loadarray(rowi, columni)
Next columni
Next rowi
Set recordsetload = rs
End Function
Sub daotry2()
Dim file As String
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select Database"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
End
Else
file = CStr(.SelectedItems(1))
End If
End With
Dim db As Object 'late binding without reference, seems to work, but might cause trouble, not tested
Dim tbl As Object
Dim dbe As Object
Set dbe = CreateObject("DAO.DBEngine.120") 'depends on win version
Set db = dbe.OpenDatabase(file)
Set tbl = db.TableDefs("CAPEX")
Debug.Print tbl.Fields(0).Properties("InputMask")
Debug.Print tbl.Fields(0).Properties("Size")
Debug.Print tbl.Fields(0).Properties("ValidationRule")
Debug.Print tbl.Fields(0).Properties("Required")
db.Close
End Sub
