Read email content and save the data down in database

[Derek]

Hi guys, Please see below my updated code . I have actioned 1st question so my code now looks into the shared folder but my 2nd point moving item to complete folder doesn't work as expected . There are 2 emails in total in ExtractEmail folder and the code moves first email to Complete folder twice and doesn't action 2nd email at all

Sub Extract()
   
    On Error Resume Next
   
    Set myOlApp = Outlook.Application
    Set mynamespace = myOlApp.GetNamespace("mapi")
   
    Dim objFS As New Scripting.FileSystemObject
    Dim objFile As Scripting.TextStream
    Dim FilePath As String
    Dim sFilePath As String
    Dim fileNumber As Integer
    Dim strRowData As String
    Dim strDelimiter As String
    Dim myDestFolder As Outlook.Folder
    Dim olRecip As Outlook.Recipient
    Dim ShareInbox As Outlook.MAPIFolder
    Dim SubFolder As Object
    Dim j As Integer
   
   
    strRowData = ""
    ' Code to extract emails from specific subfolder within shared folder
    Set olRecip = mynamespace.CreateRecipient("www@gmail.com") '// Owner's Name or email address
    Set ShareInbox = mynamespace.GetSharedDefaultFolder(olRecip, olFolderInbox)
    Set SubFolder = ShareInbox.Folders("ExtractEmail") 'Change this line to specify folder
   
    'Set myFolder = myOlApp.ActiveExplorer.CurrentFolder
   
    Set myDestFolder = ShareInbox.Folders("Completed-Test")
     
    For I = 1 To SubFolder.Items.Count
   
   'Set myFolder = myOlApp.ActiveExplorer.CurrentFolder
   
  
    messageArray = ""
    strRowData = ""
   
    Set myitem = SubFolder.Items(I)
       
    msgtext = Trim(myitem.Body)
         
    'search for specific text
   
   
    delimtedMessage = Replace(Trim(msgtext), "Name", "###")
    delimtedMessage = Replace(Trim(delimtedMessage), "Account Number", "###")
    delimtedMessage = Replace(Trim(delimtedMessage), "Address", "###")
    delimtedMessage = Replace(delimtedMessage, "Telephone Number", "###")
    delimtedMessage = Replace(delimtedMessage, "DOB", "###")
    delimtedMessage = Replace(delimtedMessage, "University", "###")
    delimtedMessage = Replace(delimtedMessage, "SUbjects", "###")
    delimtedMessage = Replace(delimtedMessage, "Birth Place", "###")
    delimtedMessage = Replace(delimtedMessage, "SCore", "###")
    delimtedMessage = Replace(delimtedMessage, "Outcome", "###")
    delimtedMessage = Replace(delimtedMessage, "References", "###")
   
    messageArray = Split(delimtedMessage, "###")
   
    For j = 1 To 11
   
   ' strRowData = Trim(strRowData & Trim(messageArray(j)) & "|")
  
   strRowData = Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, "")

   
    Next j
   
    sFilePath = "C:\Users\a" & Format(Now, "ddmmyyyyhhmmss") & ".txt"
       
    Set objFile = objFS.CreateTextFile(sFilePath, False)
  
  
   With objFile
      .WriteLine strRowData
   End With
     
   
   myitem.Move myDestFolder
 
    Next I
    objFile.Close
    End Sub

 

[Cronk]

Replace
For I = 1 To SubFolder.Items.Count
with
for each myItem in SubFolder.Items

 

[Derek]

Thanks guys , my code is working fine now . At the moment it looks into all the emails in the folder . Can I add a filter so it will look into the emails whose subject line starts with 'Account holder details' ?

Thanks

 

[arnelgp]

you have in your code, myItem.Body, surely there must be a myItem.Subject that you can check, eg:

If Instr(myItem.Subject & "", "Account holder details") > 0 then

 

[Cronk]

Can I add a filter so it will look into the emails whose subject line starts with 'Account holder details' ?

I covered that in #9. If not using Instr(myItem.subject....) as suggested by arnelgp, then alternatively Left(myItem.subject,.....)

 

[Derek]

Thanks guys , during testing we found out something that if the shared mailbox has & sign in it then the script doesn’t recognise the mailbox and doesn’t do any processing . Any mailbox without & sign work fine

Set olRecip = mynamespace.CreateRecipient("a1&bc@gmail.com")

 

[strive4peace]

hi Derek,

You can link to an Outlook folder from Access (it needs to be a local folder, not a cloud folder -- so set up a rule to move/copy messages if its cloudy)

This screen is Office 365, but you can find this in lower versions too, path to choice a little different -- check the External Data ribbon

 

[strive4peace]

then you can use Append queries to copy information to Access tables if you want

 

[Cronk]

Maybe Outlook mailbox is displaying the amphersand as an underscore or other character. So another possibility is to loop through the names of the folder collection by using code like

   Set oleApp = GetObject("", "Outlook.Application")
   Set oleMAPI = oleApp.GetNamespace("MAPI")
   oleMAPI.Logon "", "", False
   Set objFolderColl = oleMAPI.Folders
   For n = 1 To objFolderColl.Count
      debug.print objFolderColl(n).Name
   Next

 

[Derek]

Guys, the users have got a new folder without '&' sign and the above issue has been resolved and the script works fine with no issues.

The other thing I came across is some emails have weird formatting with extra spaces(tab spaces) in it and the below code doesn't take them off although I have used vbCR and vbLf in my script . Can anyone please help me this? Please see attached the extra spacing in notepad++.

For j = 1 To 11
    
            strRowData = Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, "")
    
Next j

 

[Gasman]

Tabs are not CR or LF ?
Use your code to replace two Tabs for one?

Tab is CHR(9) or vbTab

 

[Derek]

I have amended my line as below but it doesn't take off tab spaces

strRowData = Replace(Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, ""), vbTab, "")

 

[Gasman]

Well I would say they are not Tabs then. How did you determine they were Tabs?

 

[Cronk]

After the j loop in #30 add the following code

dim str as string
for j = 1 to len(strRowData)
  str = mid(strRowData,j,1)
  debug.print str, asc(str)
next j

That will give you a listing of every character in your extracted data, together with its asc value. Then you can remove the spaces you want with Replace(..... ,chr(i),"") where i is the corresponding value of the spaces from the output from the code above.

 

[Derek]

Hi guys,

I have another query from the stakeholders . How can we extract data from the outlook emails that has a HTML table in the email and a XML file that’s sent to the designated mailbox. The mailbox will need to be managed but is there an a way we could to do some sort of extract with the XML file?"

Any help will be much appreciated .

Thanks,

 

[Cronk]

Is the xml in an attachment?

 

[theDBguy]

Hi guys,

I have another query from the stakeholders . How can we extract data from the outlook emails that has a HTML table in the email and a XML file that’s sent to the designated mailbox. The mailbox will need to be managed but is there an a way we could to do some sort of extract with the XML file?"

Any help will be much appreciated .

Thanks,

Hi. Sounds like this is related to this new thread.

Extract xml file data from outlook email

Hi guys , I have recently made an outlook script working to extract data from email body to .txt file . For that one the email body contents were in structured format . Just wonderingcan we extract data from the outlook emails that has a HTML table in the email and a XML file that’s sent to...

www.access-programmers.co.uk

 

[Gasman]

Looks like you could replace " " & vbCRLF with just vbCRLF ?

Also you have just broken GDPR rules?
I would delete that pdf ASAP and replace with dummy data.?

 

[Derek]

Gasman , I have deleted that post . Can you please amend this line of code accordingly ?

strRowData = Replace(Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, ""), vbTab, "")

 

[Gasman]

W

Gasman , I have deleted that post . Can you please amend this line of code accordingly ?

strRowData = Replace(Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, ""), vbTab, "")

Wow, I would leave that alone?
Just add

strRowData = Replace(strRowData," " & vbCRLF, vbCRLF)

as the next line ?