• Creating an Access Database (on the fly) Using VBA and SQL

    I recently had reason to create a database on the fly if one did not exist. Since it took me some trial, error and searching (and then more trial and error,) I decided to share the method to do this. The following routine will create an Access database from any VBA enabled application, such as Word, Excel, Outlook, etc...

    About the Example:
    The example below creates a database at the root of the C: drive, using your MS Office Username. It also creates a new table "tblSample" with six fields in it. The most interesting part about this is that the code I provided below actually turns on the Unicode compression setting. Why is this important?
    • With Unicode Compression turned off, Access will pad all field inputs with trailing spaces to the maximum number of characters in the field.
    • It saves space in the database, since those spaces are not stored.
    • Without Unicode compression turned on, you will probably need to Trim (remove spaces) from all field values you work with in code.

    Unicode compression is, by default, turned on when you create a table through the UI in Access. It is by default turned OFF though, when you create a table using SQL's CREATE TABLE statement. The "With Compression" (or "With Comp") setting enables Unicode Compression on your database fields. What I found really interesting about this flag, though, is that it ONLY works when you send your SQL statement from an ADO connection. I prefer to test all my SQL through the Access UI before I pull it into VBA code, so this really threw me for a loop for quite a while.

    Code Required:
    The code below goes in a standard module. Don't forget to set a reference to the Microsoft ActiveX Data Objects Library. The following code was developed using the 2.8 version.

    NOTE: There is no error handling in this routine. Running it more than once will result in an error about the database already being created.

    Private Sub CreateDatabase()
    'Author       : Ken Puls (www.excelguru.ca)
    'Macro Purpose: Create an Access database on the fly
        Dim dbConnectStr As String
        Dim Catalog As Object
        Dim cnt As ADODB.Connection
        Dim dbPath As String
        'Set database name here
        dbPath = "C:" & Application.UserName & ".mdb"
        dbConnectStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath & ";"
        'Create new database
        Set Catalog = CreateObject("ADOX.Catalog")
        Catalog.Create dbConnectStr
        Set Catalog = Nothing
        'Connect to database and insert a new table
        Set cnt = New ADODB.Connection
        With cnt
            .Open dbConnectStr
            .Execute "CREATE TABLE tblSample ([Name] text(50) WITH Compression, " & _
                     "[Address] text(150) WITH Compression, " & _
                     "[City] text(50) WITH Compression, " & _
                     "[ProvinceState] text(2) WITH Compression, " & _
                     "[Postal] text(6) WITH Compression, " & _
                     "[Account] decimal(6))"
        End With
        Set cnt = Nothing
    End Sub
    Additional Info:
    One challenge with creating Access tables via ADO is that the data types are not named consistently between Access and ADO. If you are trying to create a table via ADO and SQL, you may want to check out this article for a bit of help.

    Also... if you know of, or come across, any better targeted articles for this purpose, please leave a comment below.

    This article was originally posted on the Professional Office Developers Association website (proofficedev.org) - site no longer exists.
    A Portuguese translation of this article can also be found at MS Office Gurus - Brazil.


    I'm afraid that you must be logged in to comment or leave a testimonial. I wish it could be otherwise, but I'm trying to keep my site spam free for everyone's benefit. If you don't yet have an account it's completely free to sign up, and a very quick process. Simply click here to Register. Not only can you post a comment here, but it gives you full access to posts questions in our forum as well!


    If you already have an account, and just haven't logged in yet, what are you waiting for? Login Now!

    Comments 1 Comment
    1. Michael05's Avatar
      Michael05 -
      Complete code to send all emails from Outlook to an Access db... fully automated. Tested to work with MS Office 2010, the db will be created in your C: temp folder. You will need to add a reference to ADO; open outlook VBA window and paste code at the top. Code executes from FnExportEmail()
      This code has only been tested on one computer so it's probable you will find things to edit... hope you find it useful!

      Option Explicit
      Const sDbName As String = "MyEmail.accdb"
      Public bPermissionExit As Boolean
      Public Sub FnExportEmail()
      If MsgBox("This operation can take several minutes and you will not be able to use Outlook while the process runs. " _
      & " Do you want to export your emails to an Access database?", vbYesNo, "Export emails") = vbYes Then
      Call ExportMailByFolder
      End If
      End Sub
      Private Sub BtnExport_Click()
      If MsgBox("This operation can take several minutes and you will not be able to use Outlook while the process runs. " _
      & " Do you want to export your emails to an Access database?", vbYesNo, "Export emails") = vbYes Then
      Call ExportMailByFolder
      End If
      End Sub

      'resources used
      'http links had to be deleted to post this

      Private Sub ExportMailByFolder() 'Export specified fields from each mail 'item in selected folder.
      On Error GoTo eh
      Dim ns As Outlook.NameSpace
      Dim objFolder As Outlook.MAPIFolder
      Dim Catalog As Object
      Set ns = GetNamespace("MAPI")

      Dim aflds As Variant, aType As Variant
      'below will be the db table field names and data types
      aflds = Array("ID", "Importance", "Folder", "From", "Priority", "Subject", "Message To Me", "Message CC to Me", "SenderName", "CC", "To", "Received", "Message Size", "Contents", "Created", "Has Attachments", "Modified", "Subject Prefix", "Content Unread", "Normalized Subject", "Object Type")
      aType = Array("auto", "long", "text", "text", "long", "text", "boolean", "boolean", "text", "text", "text", "date", "Int", "memo", "date", "boolean", "date", "text", "long", "text", "int")
      ' If MsgBox("Would you like to select a folder? Select 'No' to export all folders.", vbYesNo, "Folder Selection") = vbYes Then
      ' Set objFolder = ns.PickFolder '**** pick a folder ***
      ' Else
      ' Set objFolder = ns.Folders.Item(1).Folders.GetFirst 'Item(2) prints -> "Public Folders - youEmailAddress"
      ' 'ns.Folders.Item(1).Folders.Item(i)
      ' End If

      Dim adoConn As ADODB.Connection
      Dim adoRS As ADODB.Recordset
      Dim intCounter As Integer
      Dim sDbPath As String
      Dim dbConnectStr As String
      Dim olFolder As Outlook.MAPIFolder
      Dim sQL As String

      Set adoConn = CreateObject("ADODB.Connection")
      Set adoRS = CreateObject("ADODB.Recordset")

      sDbPath = Environ("tmp") & "\apps_prod\MyEmail\" 'Set database full path here > points to C: temp folder
      dbConnectStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDbPath & sDbName & ";"

      If Dir(sDbPath & sDbName) <> "" Then 'the db was found
      'db was found, now we can add records
      adoConn.Open dbConnectStr
      Else 'db not found, so we create it
      'Create new database
      On Error Resume Next
      MkDir Environ("tmp") & "\apps_prod\" 'create folder if they do not exist
      MkDir Environ("tmp") & "\apps_prod\MyEmail\"
      On Error GoTo eh

      Set Catalog = CreateObject("ADOX.Catalog")
      Catalog.Create dbConnectStr 'create a blank db
      Set Catalog = Nothing
      adoConn.Open dbConnectStr
      Call Fn_ADO_CreateTbl(adoConn, "T_OL", aflds, aType) 'DROP and then create the table
      End If

      adoRS.Open "SELECT * FROM T_OL", adoConn, adOpenDynamic, adLockOptimistic 'connect to the db, which will hold the email data
      'For Each olFolder In objFolder.Folders ' olParentFolder.Folders
      For Each olFolder In ns.Folders.Item(1).Folders
      Set objFolder = olFolder 'ns.Folders.Item(1).Folders.Item(i)
      'Debug.Print objFolder.Name
      'emails are moved into an Access table called "T_OL", where "Contents" = the email body and is a memo field ; text fields are text (255)
      For intCounter = objFolder.Items.Count To 1 Step -1
      With objFolder.Items(intCounter) 'Copy property value to corresponding fields 'in target file.
      'for a propertiy list see: another good link but it had to be deleted

      If .Class = olMail Then
      adoRS("Folder") = Mid(objFolder.Name, 1, 254)
      adoRS("Subject") = Mid(.Subject, 1, 254)
      adoRS("Contents") = .Body
      adoRS("SenderName") = .SenderName
      adoRS("To") = Mid(.To, 1, 254)
      adoRS("From") = Mid(.SenderEmailAddress, 1, 254)
      'adoRS("FromType") = .SenderEmailType ''EX' for a Microsoft Exchange server address, etc. Read-only.
      adoRS("CC") = Mid(.CC, 1, 254)
      'adoRS("BCCName") = Mid(.BCC, 1, 254)
      'adoRS("Importance") = .Importance
      'adoRS("Sensitivity") = .Sensitivity
      adoRS("Created") = .CreationTime
      adoRS("Message Size") = .Size
      adoRS("Modified") = .LastModificationTime
      '.Attachments ' Returns an Attachments object that represents all the attachments for the specified item. Read-only.
      '.Sender ' Returns or sets an AddressEntry object that corresponds to the user of the account from which the MailItem is sent. Read/write.

      End If
      End With
      '"CREATE VIEW MyTableView AS SELECT MyTable.* FROM MyTable;"
      sQL = "CREATE VIEW Q_FolderCount AS SELECT T_OL.Folder, Count(T_OL.ID) AS CountOfID From T_OL GROUP BY T_OL.Folder;" 'add a qry to the db
      adoConn.Execute sQL
      'Application.FollowHyperlink sDbPath & sDbName, , True 'good feature too bad it does not work

      MsgBox "Open this folder file to view the data." & vbCrLf & sDbPath & sDbName
      MsgBox "Complete."
      Exit Sub
      MsgBox Error$
      'GoTo ex
      Resume Next
      End Sub

      'last edits on 4/2013 -added in auto number and text field type (using number or text name: "double", "text", "memo", etc.)
      'if the table is not created, create it
      'we do this so we can simply import a form and all the code is included to use in any db
      'how we use this code:
      'Dim aflds As Variant, aType as Variant
      'aflds = Array("MyID", "FieldName2", "FieldName3", "FieldName4", "price", "createDate")
      'aType = Array("auto", "text", "memo", "text", "double", "date")
      'call Fn_ReCreateTbl("TL_TblSpec",aflds, aType)
      Function Fn_ADO_CreateTbl(adoConn As ADODB.Connection, sTblName As String, aflds As Variant, aType As Variant)
      On Error GoTo eh
      Dim sQL As String
      Dim i As Long

      On Error Resume Next
      adoConn.Connection.Execute "DROP TABLE " & sTblName
      On Error GoTo eh

      sQL = "CREATE TABLE " & sTblName & " ("

      For i = 0 To UBound(aflds)
      sQL = sQL & "[" & aflds(i) & "]" & FnTypeConversion_ADO(aType(i))
      If i < UBound(aflds) Then sQL = sQL & ", "
      sQL = sQL & ")"
      Debug.Print sQL
      adoConn.Execute sQL


      Exit Function
      MsgBox Err.Description & " " & Err.Number
      Resume Next
      End Function
      'this function is not fully tested for all types
      Function FnTypeConversion_ADO(vType As Variant) As String
      On Error GoTo ex
      Select Case vType
      Case "auto"
      FnTypeConversion_ADO = " COUNTER " 'auto number
      Case "text"
      FnTypeConversion_ADO = " text(255) WITH Compression " 'text
      Case 203, "memo"
      FnTypeConversion_ADO = " LONGTEXT " 'memo
      Case 2, "integer", "int"
      FnTypeConversion_ADO = " INTEGER " 'int
      Case 3, "long"
      FnTypeConversion_ADO = " LONG " 'long
      Case 5, "double", "dbl"
      FnTypeConversion_ADO = " DOUBLE " 'dbl
      Case 131, "decimal"
      FnTypeConversion_ADO = " decimal(6) " 'decimal
      Case 7, "date"
      FnTypeConversion_ADO = " DATETIME " 'date
      Case 6, "currency"
      FnTypeConversion_ADO = " CURRENCY " 'currency
      Case 11, "boolean", "bln"
      FnTypeConversion_ADO = " YESNO" 'boolean
      Case 205, "bianary"
      FnTypeConversion_ADO = " BIANARY " 'bianary
      Case Else
      FnTypeConversion_ADO = " text(255) WITH Compression " 'text
      End Select


      Exit Function
      MsgBox Err.Description & " " & Err.Number
      Resume Next
      End Function