VSTO & .NET & Excel

September 25, 2010

Create SQL Server Compact Edition Database with VBA

Filed under: Excel, SQL Server — Dennis M Wallentin @ 3:47 pm

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


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
 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
 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
 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
 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
 MsgBox Prompt:=CstErrorMsg, Buttons:=vbCritical, Title:=Cm_stTitle
End If

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
'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

 Set ADOXTable = Nothing
 Set ADOXCat = Nothing

 If bFlag Then
 Create_SSCE_Database = True
 Create_SSCE_Database = False
 End If
 Exit Function

 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,

September 9, 2010

Office 2010 PIA Redistributable available for download!

Filed under: .NET & Excel, COM Add-ins, Excel, VSTO & Excel, XLLs — Dennis M Wallentin @ 6:23 pm

I know that some developers have been waiting to get access to Office 2010 PIA Restributable. Although we can create our own IA some developers prefer to use the officially PIA from Microsoft.

Today when I checked it up I was pleasant surprise to find out that the PIA package is now available for download.

Click on the following URL to get to the page from where You can download it: Microsoft Office 2010: Primary Interop Assemblies Redistributable


Kind regards,

Create a free website or blog at WordPress.com.