Option Compare Database
Option Explicit
Dim rs As DAO.Recordset
'----------------------------------------------------------------
' arnel g. puzon
' 18-Aug-2015
'
' in response to Mr. JohnLee's
'
' I Hoping someone can help me as I’m having problems understanding
' how to write VBA to extract data from “.msg” files and import that data into a table in my database.
' I have over 5000 .msg files of which I need to extract the following information:
'----------------------------------------------------------------
Public Sub UpdateTableFromMsgFiles()
'
'-----------------------------------------------------------------
' table structure to update from .msg (outlook)
'
' strFirstName
' strSurname
' strStreetNr
' strCity
' strPostcode
' strTel
' strMobile
' strEmail
' strVoucherCode
' strAddif
' strModel
' strSerialNo
' strName
' strStreet
' strNr
' strPostcode2
' strGasSafe
' strIsadv
' strTC
' strInstallationDate
'
'---------------------------------------------------------------
'
' location of .msg
' G:\Scan - Verify\eFlow\Dynamics\Vaillant\Old No DPA Printed
'
'----------------------------------------------------------------
' format of .msg
'
' First Name: Tim
' Surname: O 'Rourke
' Street & Nr: 399 Upper Eastern Green Lane
' City: Coventry
' Postcode: CV5 7DJ
' Tel: 02476 421140
' Mobile: 07854420697
' Email: timorourke@ fsmail.net
' Do you have a voucher code?:
' adddif:
' Select a model: ecoTEC plus 831
' serial numer (28 didgets): 21145000100116861300375260N1 DD-MM-YYYY Installation Date: 2015-03-27
' Name: Barry Allard,Premium Heating and Plumbing
' Street: Broad Lane
' Nr.: Coventry
' Postcode: CV5 7DJ
' Gas Safe Number (5/6 digits): 518169
' isadv:
' tc: 1
' DD-MM-YYYY Installation Date:
'
'----------------------------------------------------------------
' Make reference to the ff:
'
' Microsoft Outlook XX.X Object Library
' Microsoft Scripting Runtime
'
'----------------------------------------------------------------
' your table name here
Const strTableName As String = "tblWebReg"
Dim db As DAO.Database
Dim fso As Scripting.FileSystemObject
Dim strPath As String
Dim strSaveTo As String
Dim lngCounter As Long
Dim strHTML As String
Dim OL As Outlook.Application
Dim Msg As Outlook.MailItem
Dim f As Scripting.File
'*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'*!
'*!
'*! CHANGE THE PATH BELOW TO THE CORRECT LOCATION OF YOUR .msg FILES
'*!
'*!
'strPath = CurrentProject.Path
strPath = "G:\Scan - Verify\eFlow\Dynamics\Vaillant\Old No DPA Printed"
'*!
'*!
'*! NOTE:
'*! it will create a temporary folder "Text" to your source
'*! folder.
'*!
'*!
'*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
strSaveTo = strPath & "\Text"
Set fso = New Scripting.FileSystemObject
If fso.FolderExists(strSaveTo) Then
' delete folder if already exists
fso.DeleteFolder strSaveTo, True
End If
' create new temporary foldr
fso.CreateFolder strSaveTo
Set db = CurrentDb
' open our table
Set rs = db.OpenRecordset(strTableName, dbOpenDynaset)
' create outlook instance
Set OL = CreateObject("Outlook.Application")
' create scripting instance
Set fso = CreateObject("Scripting.FileSystemObject")
' recurse folder for .msg files
For Each f In fso.GetFolder(strPath).Files
If LCase(fso.GetExtensionName(f)) = "msg" Then
Set Msg = OL.CreateItemFromTemplate(f.Path)
' save .msg as text file, so we can read later
'Msg.SaveAs strSaveTo & "\" & Replace(f.Name, ".msg", ".txt"), olTXT 'olDoc
Call subSaveStream(fso, strSaveTo & "\" & Replace(f.Name, ".msg", ".txt"), Msg.Body)
End If
Next
If Not (OL Is Nothing) Then OL.Quit: Set OL = Nothing
'process our text files
lngCounter = 0
For Each f In fso.GetFolder(strSaveTo).Files
If LCase(fso.GetExtensionName(f)) = "txt" Then
''''''''''''''''''''
'' add to our table
''''''''''''''''''''
Call addToTable(f)
End If
Next
house_keeping:
' housekeeping
' close all instance of automations
If Not (fso Is Nothing) Then Set fso = Nothing
If Not (rs Is Nothing) Then rs.Close: Set rs = Nothing
If Not (db Is Nothing) Then db.Close: Set db = Nothing
MsgBox "Done!" & vbCrLf & vbCrLf & "Please see table tblWebReg."
End Sub
Private Sub addToTable(ByVal strFileName As String)
' array to hold search strings
Dim s() As String
' array to hold table field names
Dim f() As String
Dim bolAdd As Boolean
Dim bolVaillant As Boolean
Dim i As Long
Dim j As Long
Dim lngPos As Long
Dim bolPostalOneFinished As Boolean
Dim strTextLine As String
Dim iFile As Integer
' variable count for vaillant msg
Dim bytAddress As Byte
Dim bytCity As Byte
Dim bytPostCode As Byte
ReDim s(19)
ReDim f(19)
' text to search in the text file
s(0) = "First Name:"
s(1) = "Surname:"
s(2) = "Street & Nr:"
s(3) = "City:"
s(4) = "Postcode:"
s(5) = "Tel:"
s(6) = "Mobile:"
s(7) = "Email:"
s(8) = "Do you have a voucher code?:"
s(9) = "adddif:"
s(10) = "Select a model:"
s(11) = "serial numer (28 didgets):"
s(12) = "Name:"
s(13) = "Street:"
s(14) = "Nr.:"
s(15) = "Postcode:"
s(16) = "Gas Safe Number (5/6 digits):"
s(17) = "isadv:"
s(18) = "tc:"
s(19) = "DD-MM-YYYY Installation Date:"
'field name to update from our table
f(0) = "strFirstName"
f(1) = "strSurname"
f(2) = "strStreetNr"
f(3) = "strCity"
f(4) = "strPostcode"
f(5) = "strTel"
f(6) = "strMobile"
f(7) = "strEmail"
f(8) = "strVoucherCode"
f(9) = "strAddif"
f(10) = "strModel"
f(11) = "strSerialNo"
f(12) = "strName"
f(13) = "strStreet"
f(14) = "strNr"
f(15) = "strPostcode2"
f(16) = "strGasSafe"
f(17) = "strIsadv"
f(18) = "strTC"
f(19) = "strInstallationDate"
iFile = FreeFile
Open strFileName For Input As #iFile
Line Input #iFile, strTextLine
While Not EOF(iFile)
'check for blank line and skip if blank
If Not (Trim(strTextLine) = "") Then
If InStr(strTextLine, "vaillantthinksahead") Then
'this one has different format
bolVaillant = True
ReDim s(18)
ReDim f(18)
s(0) = "Full Name:"
s(1) = "Address:"
s(2) = "City:"
s(3) = "Postcode:"
s(4) = "Address:"
s(5) = "City:"
s(6) = "Postcode:"
s(7) = "Email:"
s(8) = "Phone:"
s(9) = "Mobile:"
s(10) = "Name:"
s(11) = "Address:"
s(12) = "Postcode:"
s(13) = "Gas Safe Number:"
s(14) = "Is Advance:"
s(15) = "Serial Number:"
s(16) = "Installation Date:"
s(17) = "Model:"
s(18) = "Voucher Code:"
f(0) = "strFullName"
f(1) = "strStreetNr"
f(2) = "strCity"
f(3) = "strPostcode"
f(4) = "strCorrespondenceAddress"
f(5) = "strCorrespondenceCity"
f(6) = "strCorrespondencePostCode"
f(7) = "strCorrespondenceEmail"
f(8) = "strCorrespondencePhone"
f(9) = "strCorrespondenceMobile"
f(10) = "strName"
f(11) = "strStreet"
f(12) = "strPostcode2"
f(13) = "strGasSafe"
f(14) = "strIsadv"
f(15) = "strSerialNo"
f(16) = "strInstallationDate"
f(17) = "strModel"
f(18) = "strVoucherCode"
End If
If (bolVaillant) Then
For i = LBound(s) To UBound(s)
DoEvents
lngPos = InStr(strTextLine, s(i))
If lngPos > 0 Then
If Not bolAdd Then
bolAdd = True
rs.AddNew
End If
Select Case i
Case 1, 4, 11
' three field for Address
bytAddress = bytAddress + 1
j = Switch(bytAddress = 1, 1, bytAddress = 2, 4, bytAddress = 3, 11)
Call rsUpdate(f(j), strTextLine, s(j))
'Select Case bytAddress
' Case 1
' Call rsUpdate(f(1), strTextLine, s(1))
' Case 2
' Call rsUpdate(f(4), strTextLine, s(4))
' Case Else
' Call rsUpdate(f(11), strTextLine, s(11))
'End Select
Case 2, 5
' two fields for City
bytCity = bytCity + 1
j = Switch(bytCity = 1, 2, bytCity = 2, 5)
Call rsUpdate(f(j), strTextLine, s(j))
'Select Case bytCity
' Case 1
' Call rsUpdate(f(2), strTextLine, s(2))
' Case Else
' Call rsUpdate(f(5), strTextLine, s(5))
'End Select
Case 3, 6, 12
' three fields for Postcode
bytPostCode = bytPostCode + 1
j = Switch(bytPostCode = 1, 3, bytPostCode = 2, 6, bytPostCode = 3, 12)
Call rsUpdate(f(j), strTextLine, s(j))
'Select Case bytPostCode
' Case 1
' Call rsUpdate(f(3), strTextLine, s(3))
' Case 2
' Call rsUpdate(f(6), strTextLine, s(6))
' Case Else
' Call rsUpdate(f(12), strTextLine, s(12))
'End Select
Case Else
Call rsUpdate(f(i), strTextLine, s(i))
End Select
Exit For
End If
Next i
Else
For i = LBound(s) To UBound(s)
DoEvents
lngPos = InStr(strTextLine, s(i))
' test if search string in our text variable
If lngPos <> 0 Then
' found, then create new recod to our table
If Not bolAdd Then
bolAdd = True
rs.AddNew
End If
' check if postal code is being processed
Select Case i
Case 4, 15
' two fields for Postcode
bytPostCode = bytPostCode + 1
j = Switch(bytPostCode = 1, 4, bytPostCode = 2, 15)
Call rsUpdate(f(j), strTextLine, s(j))
'Select Case bytPostCode
' Case 1
' Call rsUpdate(f(4), strTextLine, s(4))
' Case Else
' Call rsUpdate(f(15), strTextLine, s(15))
'End Select
Case 11
' remove DD-MM-YYYY from our text line
lngPos = InStr(strTextLine, "DD-MM-YYYY")
If lngPos > 0 Then strTextLine = Left(strTextLine, lngPos - 1)
Call rsUpdate(f(11), strTextLine, s(11))
Case Else
Call rsUpdate(f(i), strTextLine, s(i))
End Select
Exit For
End If
Next
End If
End If
Line Input #iFile, strTextLine
Wend
If bolAdd Then rs.Update
' close text file
Close #iFile
' remove array from memory
Erase s
Erase f
End Sub
Private Sub rsUpdate(ByVal strFieldName As String, _
ByVal strTextLine As String, ByVal strTextToBeReplaced As String)
' remove our search string from this text and
' remove all leading and trailing space from text
strTextLine = RTrim(LTrim(Replace(strTextLine, strTextToBeReplaced, "")))
' update field with our text
'
' note:
'
' table's field size must be big enough (255 char) to hold variable
' length strings.
' i have access complaining when saving this record, saying
' that that the text i am saving cannot fit on the field!
' i don't want to truncate it as we may loose some text.
'
' but if you really want to fit the text to the size of your field (losing some text)
' just uncomment the line below and comment out
' the second line in the code
' rs.Fields(strFieldName).Value = Left(strTextLine, rs.Fields(strFieldName).Size)
rs.Fields(strFieldName).Value = "" & strTextLine
DoEvents
End Sub
Public Sub subSaveStream(ByRef fso As Scripting.FileSystemObject, ByVal sFileName As String, ByVal sText As String)
Dim TxtStream As Scripting.TextStream
Set TxtStream = fso.CreateTextFile(sFileName, True)
With TxtStream
.Write sText
.Close
End With
Set TxtStream = Nothing
End Sub
