In a previously post I wrote about how we can retrieve data from a SQL Server Compact Edition (SSCE) database with ADO and Excel. Here I will discuss how we actually can create a database with VBA in Excel. In a coming post I will show how it can be done in VSTO which will also show us the differences between VBA and .NET.
I have created an Excel Template file which can be downloaded from here. It gives us a structure to work in and to make sure we get a desired database created. The following screen shot below shows the customized template. The template itself can either be used with Excel 2007 or Excel 2010. Of course, it can be opened in older versions as well but without any access to a GUI to run the methods. It is implicit assumed that the database to be created consists of two or more tables, i.e. an error will appear if only one table is used:
To create the database in code we need to use the Microsoft ADOX library which was explicit designed to work with the Microsoft Jet OLE DB Provider. When we use it with other providers not all methods and not all properties may be available. This is indeed true when using the Microsoft SQL Server Compact 3.5 provider.
The Excel Template file contains code to select location of the database that will be created, code to create the database and code to clear the table from all data. The most interested code is the one that actually creates the database.
The first part of the code solution controls so that all entries are made and that it contains correct data:
'Callback for rxbtnCreate onAction
Sub Create_Database(control As IRibbonControl)
Const CstEmptyMsg As String = _
"A path to the database and " & _
"a name for the database " & _
"must exist. " & vbNewLine & _
"Please correct it and try again."
Const CstErrorMsg As String = _
"The database could not be created." & vbNewLine & _
"Make sure You have used correct " & vbNewLine & _
"values in the table and try again."
Const CstExtension As String = ".sdf"
Const CstFError As String = _
"You cannot have two fields with an identical name in the table."
Const CstFieldError As String = _
"At least one item lacks a field name."
Const CstPK As String = "TRUE"
Const CstTableError As String = _
"At least one item lacks a table name."
Const CstTypeSizeError As String = _
"At least one cell is empty in the DataType and DataSize fields."
Dim rnCheckTable As Range
Dim rnCheckTypeSize As Range
Dim rnCheckField As Range
Dim rnDataInput As Range
Dim rnUnique As Range
Dim lnEmptyCell As Long
Dim lnFieldCounter As Long
Dim lnLastRow As Long
Dim vaDataInput As Variant
Dim vaFields As Variant
Dim vaField As Variant
Dim vaTable As Variant
Dim vaTables As Variant
Dim stFileName As String
Dim stName As String
Dim stSuccessMsg As String
Dim stPath As String
Application.ScreenUpdating = False
wksTable.Unprotect
With wksTable
'Check that it exist a path and a name for the database.
stPath = .Range("dbPath").Value
stName = .Range("dbName").Value
If (stPath = Empty) Or (stName = Empty) Then
MsgBox Prompt:=CstEmptyMsg, Buttons:=vbOKOnly + vbCritical, Title:=Cm_stTitle
GoTo ExitSub
End If
'Grab the last used row.
lnLastRow = .Range("A102").End(xlUp).Row
'If no table exist than exit sub.
If lnLastRow = 2 Then GoTo ExitSub
'If one or more items lack table name then exit sub.
lnEmptyCell = 0
Set rnCheckTable = .Range("A3:A" & lnLastRow)
On Error Resume Next
lnEmptyCell = rnCheckTable.SpecialCells(xlCellTypeBlanks).Rows.Count
On Error GoTo 0
If lnEmptyCell > 0 Then
rnCheckTable.SpecialCells(xlCellTypeBlanks).Select
MsgBox CstTableError, vbOKOnly + vbCritical, Cm_stTitle
GoTo ExitSub
End If
'If one or more fields lack field name then exit sub.
lnEmptyCell = 0
Set rnCheckField = .Range("B3:B" & lnLastRow)
On Error Resume Next
lnEmptyCell = rnCheckField.SpecialCells(xlCellTypeBlanks).Rows.Count
On Error GoTo 0
If lnEmptyCell > 0 Then
rnCheckField.SpecialCells(xlCellTypeBlanks).Select
MsgBox CstFieldError, vbOKOnly + vbCritical, Cm_stTitle
GoTo ExitSub
End If
'Create a unique list of table names.
.Range("A2:A" & lnLastRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range("H1"), Unique:=True
vaTables = .Range("H2:H" & .Range("H102").End(xlUp).Row).Value
.Range("H1:H" & .Range("H102").End(xlUp).Row).ClearContents
'If it exist two or more fields with the same name in one table.
vaFields = rnCheckField.Value
For Each vaTable In vaTables
For Each vaField In vaFields
lnFieldCounter = .Evaluate("=SUMPRODUCT(--((" & rnCheckTable.Address & ")= _
""" & vaTable & """),--((" & rnCheckField.Address & ")=""" & vaField & """))")
If lnFieldCounter > 1 Then
MsgBox CstFError, vbOKOnly + vbCritical, Cm_stTitle
GoTo ExitSub
End If
Next vaField
Next vaTable
'If it exist two or more tables with the same name.
'No need to add any check for this as only one table with a specific name will be
'created and added to the database. And the related rows will be added to the created table.
lnEmptyCell = 0
Set rnCheckTypeSize = .Range("C3:D" & lnLastRow)
On Error Resume Next
lnEmptyCell = rnCheckTypeSize.SpecialCells(xlCellTypeBlanks).Rows.Count
On Error GoTo 0
If lnEmptyCell > 0 Then
rnCheckTypeSize.SpecialCells(xlCellTypeBlanks).Select
MsgBox CstTypeSizeError, vbOKOnly + vbCritical, Cm_stTitle
GoTo ExitSub
End If
'Grab the data entries.
Set rnDataInput = .Range("A3:E" & lnLastRow)
vaDataInput = rnDataInput.Value
End With
stSuccessMsg = "The database " & stName & CstExtension & vbNewLine & _
"has successfully been created in the " & vbNewLine & _
"folder " & stPath & "!"
'Put the name of the database together with the selected path to the location of the
'new database.
If Not stPath = "c:\" Then
stFileName = stPath & "\" & stName & CstExtension
Else
stFileName = stPath & stName & CstExtension
End If
'OK, time to send the data to the function that actually will create the database.
If Create_SSCE_Database(stFileName, vaTables, vaDataInput) Then
MsgBox Prompt:=stSuccessMsg, Buttons:=vbInformation, Title:=Cm_stTitle
Else
MsgBox Prompt:=CstErrorMsg, Buttons:=vbCritical, Title:=Cm_stTitle
End If
ExitSub:
wksTable.Protect
Exit Sub
End Sub
The second part of the main solution is the one that creates the database as the following code also shows:
Private Function Create_SSCE_Database(ByVal stDatabase As String, _ ByVal vaUniqueTables As Variant, _ ByVal vaData As Variant) As Boolean Const CstErrorMsg = "The following error has occured:" Dim ADOXCat As ADOX.Catalog Dim ADOXTable As ADOX.Table Dim iDataSize As Integer Dim lnColCounter As Long Dim lnRowCounter As Long Dim stAttributes As String Dim stConnection As String Dim stFieldName As String Dim stPK As String Dim bFlag As Boolean Dim vaDataType As Variant Dim vaItem As Variant On Error GoTo Error_Handling bFlag = True 'Connection string. stConnection = "Provider=Microsoft.SQLSERVER.CE.OLEDB.3.5;" & _ "Data Source=" & stDatabase & ";" & _ "Persist Security Info=False;" 'Instantiate the ADOX variable. Set ADOXCat = New ADOX.Catalog 'In case we have an already existing database. On Error Resume Next Kill stDatabase On Error GoTo 0 'Create the empty database. ADOXCat.Create stConnection 'All the properties of the connection string is printed to 'the Immediate Window. It can be valuable to access this 'information. 'Debug.Print xCat.ActiveConnection 'Here we create the tables and append the columns to them. For Each vaItem In vaUniqueTables Set ADOXTable = New ADOX.Table ADOXTable.Name = vaItem For lnRowCounter = LBound(vaData) To UBound(vaData) If vaData(lnRowCounter, 1) = vaItem Then stFieldName = CStr(vaData(lnRowCounter, 2)) vaDataType = vaData(lnRowCounter, 3) iDataSize = CInt(vaData(lnRowCounter, 4)) stAttributes = vaData(lnRowCounter, 5) Select Case vaDataType Case "adBoolean": ADOXTable.Columns.Append stFieldName, adBoolean, iDataSize Case "adCurrency": ADOXTable.Columns.Append stFieldName, adCurrency, iDataSize Case "adDBTimeStamp": ADOXTable.Columns.Append stFieldName, adDBTimeStamp, iDataSize Case "adDouble": ADOXTable.Columns.Append stFieldName, adDouble, iDataSize Case "adGUID": ADOXTable.Columns.Append stFieldName, adGUID, iDataSize Case "adInteger": ADOXTable.Columns.Append stFieldName, adInteger, iDataSize Case "adLongVarBinary": ADOXTable.Columns.Append stFieldName, adLongVarBinary, iDataSize Case "adSingle": ADOXTable.Columns.Append stFieldName, adSingle, iDataSize Case "adSmallInt": ADOXTable.Columns.Append stFieldName, adSmallInt, iDataSize Case "adUnsignedTinyInt": ADOXTable.Columns.Append stFieldName, adUnsignedTinyInt, iDataSize Case "adVarBinary": ADOXTable.Columns.Append stFieldName, adVarBinary, iDataSize Case "adVarWChar": ADOXTable.Columns.Append stFieldName, adVarWChar, iDataSize Case "adWChar": ADOXTable.Columns.Append stFieldName, adWChar, iDataSize End Select 'We cannot set this attribute for all data types but for most of them. 'For some unknown reason I was not able to use the names of the attributes. If stAttributes <> Empty Then Select Case stAttributes Case 1: ADOXTable.Columns(stFieldName).Attributes = 1 'adColFixed Case 2: ADOXTable.Columns(stFieldName).Attributes = 2 'adColNullable Case 3: ADOXTable.Columns(stFieldName).Attributes = 3 'adColFixed Or adColNullable End Select End If End If Next lnRowCounter 'Add the created table with its columns to the database. ADOXCat.Tables.Append ADOXTable Set ADOXTable = Nothing Next vaItem ExitHere: Set ADOXTable = Nothing Set ADOXCat = Nothing If bFlag Then Create_SSCE_Database = True Else Create_SSCE_Database = False End If Exit Function Error_Handling: bFlag = False Resume ExitHere End Function
Because I always try to use early binding a reference to the Object Library “Microsoft ADO Ext. x.x for DLL and Security” must be made (x.x refers to version number). After filling in the required data and running the above code a SSCE database is created in the wanted location. When we open the database in the SQL Server Management Studio it looks like the following:
That’s all! Now we can populate the SSCE database with data. Let me know if You think that the code can be improved.
The attached template file is not protected in any ways except the sheet protection is activated but with no password.
Kind regards,
Dennis
VSTO & .NET & Excel 