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 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 = "Z:\TEST"
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
SysCmd acSysCmdInitMeter, "Preparing", 3
Set db = CurrentDb
' open our table
Set rs = db.OpenRecordset(strTableName, dbOpenDynaset)
SysCmd acSysCmdUpdateMeter, 1
' create outlook instance
Set ol = CreateObject("Outlook.Application")
SysCmd acSysCmdUpdateMeter, 2
' create scripting instance
Set fso = CreateObject("Scripting.FileSystemObject")
SysCmd acSysCmdUpdateMeter, 3
SysCmd acSysCmdInitMeter, "Determining no of files to process", 3
' just how many .msg files do we need to process
For Each f In fso.GetFolder(strPath).Files
If LCase(fso.GetExtensionName(f)) = "msg" Then
lngCounter = lngCounter + 1
If lngCounter Mod 4 <> 0 Then
SysCmd acSysCmdUpdateMeter, (lngCounter Mod 4)
End If
End If
Next f
' recurse folder for .msg files
SysCmd acSysCmdInitMeter, "Saving .msg file as text file", lngCounter
lngCounter = 0
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
lngCounter = lngCounter + 1
SysCmd acSysCmdUpdateMeter, lngCounter
Msg.SaveAs strSaveTo & "\" & left(f.NAME, Len(f.NAME) - 3) & "txt", olTXT 'olDoc
End If
Next
If Not (ol Is Nothing) Then ol.Quit: Set ol = Nothing
'process our text files
SysCmd acSysCmdInitMeter, "extracting text and saving to table", lngCounter
lngCounter = 0
For Each f In fso.GetFolder(strSaveTo).Files
If LCase(fso.GetExtensionName(f)) = "txt" Then
lngCounter = lngCounter + 1
SysCmd acSysCmdUpdateMeter, lngCounter
Call addToTable(f)
End If
Next
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
SysCmd acSysCmdRemoveMeter
End Sub
Private Sub addToTable(ByVal strFilename As String)
' array to hold search strings
Dim s(0 To 19) As String
' array to hold table field names
Dim f(0 To 19) As String
Dim bolAdd As Boolean
Dim i As Long
Dim lngPos As Long
Dim bolPostalOneFinished As Boolean
Dim strTextLine As String
Dim iFile As Integer
' 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
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
If (i = 4) Then
' did we already update first postal
If bolPostalOneFinished Then
' update second postal field
Call rsUpdate(f(15), strTextLine, s(15))
Else
' update first postal field
Call rsUpdate(f(i), strTextLine, s(i))
bolPostalOneFinished = True
End If
Else
If (i = 11) Then
'remove the DD-MM-YYYY
lngPos = InStr(strTextLine, "DD-MM-YYYY")
If lngPos > 0 Then strTextLine = left(strTextLine, lngPos - 1) ' remove DD-MM-YYYY from our text line
End If
' update rest of field
Call rsUpdate(f(i), strTextLine, s(i))
End If
Exit For
End If
Next
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) '1st line
rs.fields(strFieldName).value = strTextLine '2nd line
DoEvents
End Sub
