Read email content and save the data down in database (1 Viewer)

Derek

Registered User.
Local time
Today, 02:59
Joined
May 4, 2010
Messages
226
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 :(
Code:
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

Registered User.
Local time
Today, 19:59
Joined
Jul 4, 2013
Messages
2,380
Replace
For I = 1 To SubFolder.Items.Count
with
for each myItem in SubFolder.Items
 

Derek

Registered User.
Local time
Today, 02:59
Joined
May 4, 2010
Messages
226
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

error reading drive A:
Local time
Today, 17:59
Joined
May 7, 2009
Messages
9,590
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

Registered User.
Local time
Today, 19:59
Joined
Jul 4, 2013
Messages
2,380
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

Registered User.
Local time
Today, 02:59
Joined
May 4, 2010
Messages
226
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
Code:
Set olRecip = mynamespace.CreateRecipient("a1&bc@gmail.com")
 

strive4peace

AWF VIP
Local time
Today, 04:59
Joined
Apr 3, 2020
Messages
524
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)
NewDataSource_OutlookFolder.png

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

AWF VIP
Local time
Today, 04:59
Joined
Apr 3, 2020
Messages
524
then you can use Append queries to copy information to Access tables if you want
 
Last edited:

Cronk

Registered User.
Local time
Today, 19:59
Joined
Jul 4, 2013
Messages
2,380
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
Code:
   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

Registered User.
Local time
Today, 02:59
Joined
May 4, 2010
Messages
226
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++.
Code:
For j = 1 To 11
    
            strRowData = Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, "")
    
Next j
 

Attachments

Gasman

Enthusiastic Amateur
Local time
Today, 10:59
Joined
Sep 21, 2011
Messages
5,963
Tabs are not CR or LF ?
Use your code to replace two Tabs for one?

Tab is CHR(9) or vbTab
 

Derek

Registered User.
Local time
Today, 02:59
Joined
May 4, 2010
Messages
226
I have amended my line as below but it doesn't take off tab spaces
Code:
strRowData = Replace(Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, ""), vbTab, "")
 

Gasman

Enthusiastic Amateur
Local time
Today, 10:59
Joined
Sep 21, 2011
Messages
5,963
Well I would say they are not Tabs then. How did you determine they were Tabs?
 

Cronk

Registered User.
Local time
Today, 19:59
Joined
Jul 4, 2013
Messages
2,380
After the j loop in #30 add the following code
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

Registered User.
Local time
Today, 02:59
Joined
May 4, 2010
Messages
226
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

Registered User.
Local time
Today, 19:59
Joined
Jul 4, 2013
Messages
2,380
Is the xml in an attachment?
 

theDBguy

I’m here to help
Local time
Today, 02:59
Joined
Oct 29, 2018
Messages
10,714
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.

 

Gasman

Enthusiastic Amateur
Local time
Today, 10:59
Joined
Sep 21, 2011
Messages
5,963
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

Registered User.
Local time
Today, 02:59
Joined
May 4, 2010
Messages
226
Gasman , I have deleted that post . Can you please amend this line of code accordingly ?
Code:
strRowData = Replace(Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, ""), vbTab, "")
 

Gasman

Enthusiastic Amateur
Local time
Today, 10:59
Joined
Sep 21, 2011
Messages
5,963
W
Gasman , I have deleted that post . Can you please amend this line of code accordingly ?
Code:
strRowData = Replace(Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, ""), vbTab, "")
Wow, I would leave that alone? o_O
Just add
Code:
strRowData = Replace(strRowData," " & vbCRLF, vbCRLF)
as the next line ?
 

Users Who Are Viewing This Thread (Users: 0, Guests: 1)

Top Bottom