Data Extraction From an .msg File (1 Viewer)

JohnLee

Registered User.
Local time
Today, 04:36
Joined
Mar 8, 2007
Messages
692
Hi,
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:
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

The field headings are all in black bold and the required data come after the colon, I have name the fields in my database exactly the same but using the normal naming conventions:
strFirstName
strSurname
strStreetNr
strCity
strPostcode
strTel
strMobile
strEmail
strVoucherCode
strAddif
strModel
strSerialNo
strName
strStreet
strNr
strPostcode2
strGasSafe
strIsadv
strTC

The location of the files is as follows:

G:\Scan - Verify\eFlow\Dynamics\Vaillant\Old no DPA

And each file is name in the following format:

Product Registration (1).msg

Any assistance would be most appreciated.

Regards

John
 

Ranman256

Registered User.
Local time
Today, 07:36
Joined
Apr 9, 2015
Messages
3,685
This is not the layout for access to import files.
It needs to be like an excel file layout, the 1st row has all the column names,
then every row after that are the data fields separated by a delimiter.
(either comma, tab, or semicolon)

Access cannot import your layout without a lot of VBA programming.
 

jdraw

Super Moderator
Staff member
Local time
Today, 07:36
Joined
Jan 23, 2006
Messages
13,464
You could post the database you are currently developing and some sample msg files.
Zip and post.
Are all msg files the exact same format?

You do realize we have no access to your G: drive....
 

arnelgp

error reading drive A:
Local time
Today, 20:36
Joined
May 7, 2009
Messages
11,121
can you upload your db and 3 sample .msg files so i can test my code.
 

arnelgp

error reading drive A:
Local time
Today, 20:36
Joined
May 7, 2009
Messages
11,121
please test, if not working send me a db with your table to update and some .msg files to work with.

run UpdateTableFromMsg from Module1. syntax:

call UpdateTableFromMsg("yourTableNameToUpdate")
 

Attachments

  • TestPurpose.accdb
    448 KB · Views: 38

JohnLee

Registered User.
Local time
Today, 04:36
Joined
Mar 8, 2007
Messages
692
Hi Ranman256,

Thank you for your response, I do realise that there will be a need for VBA programming, that's why I posted this in the Modules & VBA section of this forum.

For JDraw,

I do have access to my G Drive, I use it every single day, so there is no problem there, thank you for your response.

For arnelgp

Because of the content of my db I can't upload that but I can upload a test db with a table in it and a module that I was trying to amend to deal with .msg files. You'll note that code I am useing there is orginally for text files, and I was hoping to try and amend it to read .msg files.

I've uploaded my test db

Thank you all for your responses

Regards

John
 

Attachments

  • Test.zip
    31 KB · Views: 42

arnelgp

error reading drive A:
Local time
Today, 20:36
Joined
May 7, 2009
Messages
11,121
Mr. Lee try this again.

changes to your table (tblWebReg):
i have to increase each field size to 255 to accommodate variable length strings in .msg file. i am encountering error when putting value (text) in a field saying the value will not fit because my field size is small.
i also set the property Allow Zero Length to Yes (previous value is No) coz there are field values that are blank.
strEmail field is not in the table so i added it.
i also added strlsadv field.
 

Attachments

  • Test.mdb
    544 KB · Views: 39

JohnLee

Registered User.
Local time
Today, 04:36
Joined
Mar 8, 2007
Messages
692
Hi arnelgp,

Thanks for your assistance here, I will test this, this morning, I've been out of the office. I'll let you know how I get on.

Regards

John
 

JohnLee

Registered User.
Local time
Today, 04:36
Joined
Mar 8, 2007
Messages
692
Hi arnelgp,

Thank you very much for your assistance, it worked a treat, it has enabled me to identify mulitple records for the same customer and we only need to process one record for each customer.

If I could ask what was your thought process in your approach to writing that code, this so that I can improve my understanding on how I should approaching dealing with such senario's in the future.

Once again a big thank you

Regards

John
 

JohnLee

Registered User.
Local time
Today, 04:36
Joined
Mar 8, 2007
Messages
692
Good morning arnelgp,

I would like to thank you again for your assistance with the code to extracting data from an .msg file.

I need your assistance again, because the clients without notice have submitted .msg files in a different format, which I didn’t discover until no data was being imported into my DB.

I had a look at your code and thought that all I needed to do was make some changes to this code block:

Code:
[FONT=Times New Roman]Private Sub addToTable(ByVal strFileName As String)[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    ' array to hold search strings[/FONT]
[FONT=Times New Roman]    Dim s(0 To 19) As String[/FONT]
[FONT=Times New Roman]    ' array to hold table field names[/FONT]
[FONT=Times New Roman]    Dim f(0 To 19) As String[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    Dim bolAdd As Boolean[/FONT]
[FONT=Times New Roman]    Dim i As Long[/FONT]
[FONT=Times New Roman]    Dim lngPos As Long[/FONT]
[FONT=Times New Roman]    Dim bolPostalOneFinished As Boolean[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    Dim strTextLine As String[/FONT]
[FONT=Times New Roman]    Dim iFile As Integer[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    ' text to search in the text file[/FONT]
[FONT=Times New Roman]    s(0) = "First Name:"[/FONT]
[FONT=Times New Roman]    s(1) = "Surname:"[/FONT]
[FONT=Times New Roman]    s(2) = "Street & Nr:"[/FONT]
[FONT=Times New Roman]    s(3) = "City:"[/FONT]
[FONT=Times New Roman]    s(4) = "Postcode:"[/FONT]
[FONT=Times New Roman]    s(5) = "Tel:"[/FONT]
[FONT=Times New Roman]    s(6) = "Mobile:"[/FONT]
[FONT=Times New Roman]    s(7) = "Email:"[/FONT]
[FONT=Times New Roman]    s(8) = "Do you have a voucher code?:"[/FONT]
[FONT=Times New Roman]    s(9) = "adddif:"[/FONT]
[FONT=Times New Roman]    s(10) = "Select a model:"[/FONT]
[FONT=Times New Roman]    s(11) = "serial numer (28 didgets):"[/FONT]
[FONT=Times New Roman]    s(12) = "Name:"[/FONT]
[FONT=Times New Roman]    s(13) = "Street:"[/FONT]
[FONT=Times New Roman]    s(14) = "Nr.:"[/FONT]
[FONT=Times New Roman]    s(15) = "Postcode:"[/FONT]
[FONT=Times New Roman]    s(16) = "Gas Safe Number (5/6 digits):"[/FONT]
[FONT=Times New Roman]    s(17) = "isadv:"[/FONT]
[FONT=Times New Roman]    s(18) = "tc:"[/FONT]
[FONT=Times New Roman]    s(19) = "DD-MM-YYYY Installation Date:"[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    'field name to update from our table[/FONT]
[FONT=Times New Roman]    f(0) = "strFirstName"[/FONT]
[FONT=Times New Roman]    f(1) = "strSurname"[/FONT]
[FONT=Times New Roman]    f(2) = "strStreetNr"[/FONT]
[FONT=Times New Roman]    f(3) = "strCity"[/FONT]
[FONT=Times New Roman]    f(4) = "strPostcode"[/FONT]
[FONT=Times New Roman]    f(5) = "strTel"[/FONT]
[FONT=Times New Roman]    f(6) = "strMobile"[/FONT]
[FONT=Times New Roman]    f(7) = "strEmail"[/FONT]
[FONT=Times New Roman]    f(8) = "strVoucherCode"[/FONT]
[FONT=Times New Roman]    f(9) = "strAddif"[/FONT]
[FONT=Times New Roman]    f(10) = "strModel"[/FONT]
[FONT=Times New Roman]    f(11) = "strSerialNo"[/FONT]
[FONT=Times New Roman]    f(12) = "strName"[/FONT]
[FONT=Times New Roman]    f(13) = "strStreet"[/FONT]
[FONT=Times New Roman]    f(14) = "strNr"[/FONT]
[FONT=Times New Roman]    f(15) = "strPostcode2"[/FONT]
[FONT=Times New Roman]    f(16) = "strGasSafe"[/FONT]
[FONT=Times New Roman]    f(17) = "strIsadv"[/FONT]
[FONT=Times New Roman]    f(18) = "strTC"[/FONT]
[FONT=Times New Roman]    f(19) = "strInstallationDate"[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    iFile = FreeFile[/FONT]
[FONT=Times New Roman]    Open strFileName For Input As #iFile[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    Line Input #iFile, strTextLine[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    While Not EOF(iFile)[/FONT]
[FONT=Times New Roman]        [/FONT]
[FONT=Times New Roman]        'check for blank line and skip if blank[/FONT]
[FONT=Times New Roman]        If Not (Trim(strTextLine) = "") Then[/FONT]
[FONT=Times New Roman]            For i = LBound(s) To UBound(s)[/FONT]
[FONT=Times New Roman]                [/FONT]
[FONT=Times New Roman]                DoEvents[/FONT]
[FONT=Times New Roman]                [/FONT]
[FONT=Times New Roman]                lngPos = InStr(strTextLine, s(i))[/FONT]
[FONT=Times New Roman]                ' test if search string in our text variable[/FONT]
[FONT=Times New Roman]                If lngPos <> 0 Then[/FONT]
[FONT=Times New Roman]                    ' found, then create new recod to our table[/FONT]
[FONT=Times New Roman]                    If Not bolAdd Then[/FONT]
[FONT=Times New Roman]                        bolAdd = True[/FONT]
[FONT=Times New Roman]                        rs.AddNew[/FONT]
[FONT=Times New Roman]                    End If[/FONT]
[FONT=Times New Roman]                    ' check if postal code is being processed[/FONT]
[FONT=Times New Roman]                    If (i = 4) Then[/FONT]
[FONT=Times New Roman]                        ' did we already update first postal[/FONT]
[FONT=Times New Roman]                        If bolPostalOneFinished Then[/FONT]
[FONT=Times New Roman]                            ' update second postal field[/FONT]
[FONT=Times New Roman]                            Call rsUpdate(f(15), strTextLine, s(15))[/FONT]
[FONT=Times New Roman]                        Else[/FONT]
[FONT=Times New Roman]                            ' update first postal field[/FONT]
[FONT=Times New Roman]                            Call rsUpdate(f(i), strTextLine, s(i))[/FONT]
[FONT=Times New Roman]                            bolPostalOneFinished = True[/FONT]
[FONT=Times New Roman]                        End If[/FONT]
[FONT=Times New Roman]                    Else[/FONT]
[FONT=Times New Roman]                        If (i = 11) Then[/FONT]
[FONT=Times New Roman]                            'remove the DD-MM-YYYY[/FONT]
[FONT=Times New Roman]                            lngPos = InStr(strTextLine, "DD-MM-YYYY")[/FONT]
[FONT=Times New Roman]                            If lngPos > 0 Then strTextLine = Left(strTextLine, lngPos - 1)  ' remove DD-MM-YYYY from our text line[/FONT]
[FONT=Times New Roman]                        End If[/FONT]
[FONT=Times New Roman]                        ' update rest of field[/FONT]
[FONT=Times New Roman]                        Call rsUpdate(f(i), strTextLine, s(i))[/FONT]
[FONT=Times New Roman]                    End If[/FONT]
[FONT=Times New Roman]                    [/FONT]
[FONT=Times New Roman]                    Exit For[/FONT]
[FONT=Times New Roman]                    [/FONT]
[FONT=Times New Roman]                End If[/FONT]
[FONT=Times New Roman]                [/FONT]
[FONT=Times New Roman]            Next[/FONT]
[FONT=Times New Roman]        End If[/FONT]
[FONT=Times New Roman]        Line Input #iFile, strTextLine[/FONT]
[FONT=Times New Roman] [/FONT]
[FONT=Times New Roman]    Wend[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    If bolAdd Then rs.Update[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    ' close text file[/FONT]
[FONT=Times New Roman]    Close #iFile[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    ' remove array from memory[/FONT]
[FONT=Times New Roman]    Erase s[/FONT]
[FONT=Times New Roman]    Erase f[/FONT]
[FONT=Times New Roman]End Sub[/FONT]


To as shown below:

Code:
[/FONT]
[FONT=Times New Roman][FONT=Times New Roman]Private Sub addToTable(ByVal strFileName As String)[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    ' array to hold search strings[/FONT]
[FONT=Times New Roman]    Dim s(0 To 21) As String[/FONT]
[FONT=Times New Roman]    ' array to hold table field names[/FONT]
[FONT=Times New Roman]    Dim f(0 To 21) As String[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    Dim bolAdd As Boolean[/FONT]
[FONT=Times New Roman]    Dim i As Long[/FONT]
[FONT=Times New Roman]    Dim lngPos As Long[/FONT]
[FONT=Times New Roman]    Dim bolPostalOneFinished As Boolean[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    Dim strTextLine As String[/FONT]
[FONT=Times New Roman]    Dim iFile As Integer[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    ' text to search in the text file[/FONT]
[FONT=Times New Roman]    s(0) = "Full Name:"[/FONT]
[FONT=Times New Roman]    s(1) = "Address:"[/FONT]
[FONT=Times New Roman]    s(2) = "City:"[/FONT]
[FONT=Times New Roman]    s(3) = "Postcode:"[/FONT]
[FONT=Times New Roman]    s(4) = "Correspondence Address:"[/FONT]
[FONT=Times New Roman]    s(5) = "Address:"[/FONT]
[FONT=Times New Roman]    s(6) = "City:"[/FONT]
[FONT=Times New Roman]    s(7) = "Postcode:"[/FONT]
[FONT=Times New Roman]    s(8) = "Email:"[/FONT]
[FONT=Times New Roman]    s(9) = "Phone:"[/FONT]
[FONT=Times New Roman]    s(10) = "Mobile:"[/FONT]
[FONT=Times New Roman]    s(11) = "Installer Details:"[/FONT]
[FONT=Times New Roman]    s(12) = "Name:"[/FONT]
[FONT=Times New Roman]    s(13) = "Address:"[/FONT]
[FONT=Times New Roman]    s(14) = "Postcode:"[/FONT]
[FONT=Times New Roman]    s(15) = "Gas Safe Number:"[/FONT]
[FONT=Times New Roman]    s(16) = "Is Advance:"[/FONT]
[FONT=Times New Roman]    s(17) = "Product Details:"[/FONT]
[FONT=Times New Roman]    s(18) = "Serial Number:"[/FONT]
[FONT=Times New Roman]    s(19) = "Installation Date:"[/FONT]
[FONT=Times New Roman]    s(20) = “Model:”[/FONT]
[FONT=Times New Roman]    s(21) = “Voucher Code:”[/FONT]
[FONT=Times New Roman] [/FONT]
[FONT=Times New Roman]    'field name to update from our table[/FONT]
[FONT=Times New Roman]    f(0) = "strFullName"[/FONT]
[FONT=Times New Roman]    f(1) = "strAddress"[/FONT]
[FONT=Times New Roman]    f(2) = "strCity"[/FONT]
[FONT=Times New Roman]    f(3) = "strPostcode"[/FONT]
[FONT=Times New Roman]    f(4) = "strCorrespondenceAddress"[/FONT]
[FONT=Times New Roman]    f(5) = "strAddress2"[/FONT]
[FONT=Times New Roman]    f(6) = "strCity"[/FONT]
[FONT=Times New Roman]    f(7) = "strPostcode2"[/FONT]
[FONT=Times New Roman]    f(8) = "strEmail"[/FONT]
[FONT=Times New Roman]    f(9) = "strPhone"[/FONT]
[FONT=Times New Roman]    f(10) = "strMobile"[/FONT]
[FONT=Times New Roman]    f(11) = "strInstallerDetails"[/FONT]
[FONT=Times New Roman]    f(12) = "strName"[/FONT]
[FONT=Times New Roman]    f(13) = "strAddress3"[/FONT]
[FONT=Times New Roman]    f(14) = "strPostcode3"[/FONT]
[FONT=Times New Roman]    f(15) = "strGasSafeNumber"[/FONT]
[FONT=Times New Roman]    f(16) = "strIsAdvance"[/FONT]
[FONT=Times New Roman]    f(17) = "strProductDetails"[/FONT]
[FONT=Times New Roman]    f(18) = "strSerialNumber"[/FONT]
[FONT=Times New Roman]    f(19) = "strInstallationDate"[/FONT]
[FONT=Times New Roman]    f(20)= ”strModel”[/FONT]
[FONT=Times New Roman]    f(21)= “VoucherCode”[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    iFile = FreeFile[/FONT]
[FONT=Times New Roman]    Open strFileName For Input As #iFile[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    Line Input #iFile, strTextLine[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    While Not EOF(iFile)[/FONT]
[FONT=Times New Roman]        [/FONT]
[FONT=Times New Roman]        'check for blank line and skip if blank[/FONT]
[FONT=Times New Roman]        If Not (Trim(strTextLine) = "") Then[/FONT]
[FONT=Times New Roman]            For i = LBound(s) To UBound(s)[/FONT]
[FONT=Times New Roman]                [/FONT]
[FONT=Times New Roman]                DoEvents[/FONT]
[FONT=Times New Roman]                [/FONT]
[FONT=Times New Roman]                lngPos = InStr(strTextLine, s(i))[/FONT]
[FONT=Times New Roman]                ' test if search string in our text variable[/FONT]
[FONT=Times New Roman]                If lngPos <> 0 Then[/FONT]
[FONT=Times New Roman]                    ' found, then create new recod to our table[/FONT]
[FONT=Times New Roman]                    If Not bolAdd Then[/FONT]
[FONT=Times New Roman]                        bolAdd = True[/FONT]
[FONT=Times New Roman]                        rs.AddNew[/FONT]
[FONT=Times New Roman]                    End If[/FONT]
[FONT=Times New Roman]                    ' check if postal code is being processed[/FONT]
[FONT=Times New Roman]                    If (i = 4) Then[/FONT]
[FONT=Times New Roman]                        ' did we already update first postal[/FONT]
[FONT=Times New Roman]                        If bolPostalOneFinished Then[/FONT]
[FONT=Times New Roman]                            ' update second postal field[/FONT]
[FONT=Times New Roman]                            Call rsUpdate(f(15), strTextLine, s(15))[/FONT]
[FONT=Times New Roman]                        Else[/FONT]
[FONT=Times New Roman]                            ' update first postal field[/FONT]
[FONT=Times New Roman]                            Call rsUpdate(f(i), strTextLine, s(i))[/FONT]
[FONT=Times New Roman]                            bolPostalOneFinished = True[/FONT]
[FONT=Times New Roman]                        End If[/FONT]
[FONT=Times New Roman]                    Else[/FONT]
[FONT=Times New Roman]                        If (i = 11) Then[/FONT]
[FONT=Times New Roman]                            'remove the DD-MM-YYYY[/FONT]
[FONT=Times New Roman]                            lngPos = InStr(strTextLine, "DD-MM-YYYY")[/FONT]
[FONT=Times New Roman]                            If lngPos > 0 Then strTextLine = Left(strTextLine, lngPos - 1)  ' remove DD-MM-YYYY from our text line[/FONT]
[FONT=Times New Roman]                        End If[/FONT]
[FONT=Times New Roman]                        ' update rest of field[/FONT]
[FONT=Times New Roman]                        Call rsUpdate(f(i), strTextLine, s(i))[/FONT]
[FONT=Times New Roman]                    End If[/FONT]
[FONT=Times New Roman]                    [/FONT]
[FONT=Times New Roman]                    Exit For[/FONT]
[FONT=Times New Roman]                    [/FONT]
[FONT=Times New Roman]                End If[/FONT]
[FONT=Times New Roman]                [/FONT]
[FONT=Times New Roman]            Next[/FONT]
[FONT=Times New Roman]        End If[/FONT]
[FONT=Times New Roman]        Line Input #iFile, strTextLine[/FONT]
[FONT=Times New Roman] [/FONT]
[FONT=Times New Roman]    Wend[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    If bolAdd Then rs.Update[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    ' close text file[/FONT]
[FONT=Times New Roman]    Close #iFile[/FONT]
[FONT=Times New Roman]    [/FONT]
[FONT=Times New Roman]    ' remove array from memory[/FONT]
[FONT=Times New Roman]    Erase s[/FONT]
[FONT=Times New Roman]    Erase f[/FONT]
[FONT=Times New Roman]End Sub[/FONT][/FONT]
[FONT=Times New Roman]

But this clearly is not the case because firstly the resultant text file doesn’t look like the attached example [Vaillant - Guarantee Registration Confirmation(275).txt], it looks like the 2nd example [Vaillant - Guarantee Registration Confirmation (1159).txt]
Which explains why no data was extracted from the text files. There is clearly more to your code than I tried to work out, hence why I couldn’t make the adjustments to try and deal with this new format.

If I could trouble you again to assist me with dealing this new format of .msg file it would be highly appreciated.

Regards

John Lee
 

Attachments

  • Vaillant - Guarantee Registration Confirmation(275).txt
    731 bytes · Views: 46
  • Vaillant - Guarantee Registration Confirmation (1159).txt
    1.8 KB · Views: 35

arnelgp

error reading drive A:
Local time
Today, 20:36
Joined
May 7, 2009
Messages
11,121
hello mr. lee if you can upload the 2 .msg file instead.
 

JohnLee

Registered User.
Local time
Today, 04:36
Joined
Mar 8, 2007
Messages
692
Hi arnelgp,

Please find 3 files uploaded.

Many thanks

John
 

Attachments

  • msg files.zip
    29 KB · Views: 38
Last edited:

arnelgp

error reading drive A:
Local time
Today, 20:36
Joined
May 7, 2009
Messages
11,121
does the company "Valiant.co.uk" has this .msg format among the rest? i am experiencing internet problem right now so i'll just inform you when we are ready.
 

JohnLee

Registered User.
Local time
Today, 04:36
Joined
Mar 8, 2007
Messages
692
Hi arnelgp,

On the .msg files I have from Vaillant they appear to be using on this latest batch of email the following in the "From:" part:

Vaillant.co.uk vaillant@hrocdigital.co.uk

On the initial .msg files I provided in my first post they are using this in the "From:" part:

noreply@vaillanat.com

Does this answer your question?

Regards

John
 

JohnLee

Registered User.
Local time
Today, 04:36
Joined
Mar 8, 2007
Messages
692
Good morning arnelgp,

I clicked on your link, however unfortunatley due to my companie's security protocols in place, I am blocked from accessing your link. could you possible upload the code on here.

Your assistance is most appreciated.

Regards

John
 

arnelgp

error reading drive A:
Local time
Today, 20:36
Joined
May 7, 2009
Messages
11,121
sorry i have slow connection. i always get disconnected.

Code:
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
 

arnelgp

error reading drive A:
Local time
Today, 20:36
Joined
May 7, 2009
Messages
11,121
there are fields that i added to your table. please compare below with your table since i am unable to upload to this site due to poor internet.

Field Names:

lngRecordID
strFullName
strFirstName
strSurname
strStreetNr
strCity
strPostcode
strTel
strMobile
strCorrespondenceAddress
strCorrespondenceCity
strCorrespondencePostCode
strCorrespondenceEmail
strCorrespondencePhone
strCorrespondenceMobile
strVoucherCode
strAddif
strModel
strSerialNo
strInstallationDate
strName
strStreet
strNr
strPostcode2
strGasSafe
strTC
strEMail
strIsadv
 

JohnLee

Registered User.
Local time
Today, 04:36
Joined
Mar 8, 2007
Messages
692
Hi arnelgp,

Just briefly back in the office this morning will confirm with you later with results.

Thanks once again for your help.

Regards

John
 

JohnLee

Registered User.
Local time
Today, 04:36
Joined
Mar 8, 2007
Messages
692
Hi arnelgp,

I've finally been able to continue my work with the .msg files and deployed your code, however when I run your code I keep getting the following message:

Run-time error 94

Invalid use of Null

and then this block of code is highlighted when I select debug:

Code:
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
                                [COLOR=red]j = Switch(bytPostCode = 1, 4, bytPostCode = 2, 15)
[/COLOR]                                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

The snippet of code highlighted in red is highlighted in yellow.

I've checked my table to make sure all the fields match what you have in your code and they do, all the fields are set to allow zero lengths and are set 255 characters and I've re-ran the code serveral times with different volumes of data and the first 11 records come into the table okay but then nothing after that. I had grouped together a total of 20 .msg files and only the first 11 records were imported into the table.

When I then removed those first 11 records [both .msg and .txt files and the Text Folder] and ran the process again that is when the problem identified above keeps coming up, even when I remove those 9 ,msg files and put 10 different .msg files into that folder the same problem occurs.

Your assistance once again would be most appreciated.

Regards

John
 

Users who are viewing this thread

Top Bottom