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

[Ken Puls]

You can view the page at http://www.excelguru.ca/forums/conte...ng-VBA-and-SQL

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

'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