Results 1 to 2 of 2

Thread: Article: Creating an Access Database (on the fly) Using VBA and SQL

  1. #1
    Administrator Ken Puls's Avatar
    Join Date
    Mar 2011
    Location
    Nanaimo, BC, Canada
    Posts
    2,021
    Articles
    79
    Blog Entries
    14

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



    Register for a FREE account, and/
    or Log in to avoid these ads!

    Ken Puls, FCPA, FCMA, MS MVP (Excel)

    Master your data with Power Query: Purchase your copy of my book M is for Data Monkey today!

    Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
    Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter

    If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.

  2. #2

    Send all folders email items to MS Access - runs from Outlook VBA

    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 & ";"

    'Stop
    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.AddNew
    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
    '.ReceivedByName
    '.ReceivedTime
    '.Recipients
    '.Size
    '.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.


    adoRS.Update
    End If
    End With
    Next
    Next
    ex:
    '"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
    adoRS.Close
    MsgBox "Complete."
    Exit Sub
    eh:
    MsgBox Error$
    'GoTo ex
    Stop
    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 & ", "
    Next
    sQL = sQL & ")"
    Debug.Print sQL
    'Stop
    adoConn.Execute sQL

    ex:

    Exit Function
    eh:
    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

    ex:

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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •