Morya1
asked on
Excel 2007 - From Outlook to spreadsheet
I get a bunch of emaiils in this form:
Transaction # Â Â Â Â Â Â 00000002E7-xxx
Client: Â Â Â Â Â Â SML.
Account # Â Â Â Â Â Â USD-100-458475
Value date: Â Â Â Â Â Â 09/11/2010
Posted date: Â Â Â Â Â Â 09/11/2010
Amount: Â Â Â Â Â Â 7,951.60
Currency: Â Â Â Â Â Â US Dollars
Credit / Debit: Â Â Â Â Â Â Credit
Is there an automated way of putting that data into a spreadsheet without having to always copy and paste? The column on the left would be the column headings and the values on the right of the above example would comprise one record (one row - so it transposes) and as each email comes in, some might have more than one of these but the left hand column would always be the same text.
So, as each email comes in, it would fill up this spreadsheet one row at a time. The workbook would be named DirectDepositTransfers.
Transaction # Â Â Â Â Â Â 00000002E7-xxx
Client: Â Â Â Â Â Â SML.
Account # Â Â Â Â Â Â USD-100-458475
Value date: Â Â Â Â Â Â 09/11/2010
Posted date: Â Â Â Â Â Â 09/11/2010
Amount: Â Â Â Â Â Â 7,951.60
Currency: Â Â Â Â Â Â US Dollars
Credit / Debit: Â Â Â Â Â Â Credit
Is there an automated way of putting that data into a spreadsheet without having to always copy and paste? The column on the left would be the column headings and the values on the right of the above example would comprise one record (one row - so it transposes) and as each email comes in, some might have more than one of these but the left hand column would always be the same text.
So, as each email comes in, it would fill up this spreadsheet one row at a time. The workbook would be named DirectDepositTransfers.
ASKER
Thanks, and it looks promising, but I don't want to spend the time working with it if it doesn't work for Office 2007. It states on the website the code was written for Office 2003.
Even then, what I am really looking for is the solution where I wouldn't have to put a lot of time to customize because, right now, I just don't have the time.
Even then, what I am really looking for is the solution where I wouldn't have to put a lot of time to customize because, right now, I just don't have the time.
There is no reason that it should not work in 2007...the code is written using VBA, which has not changed.  therefore the code should work as is for your application, except that the parsing code  for the email body needs to be added.  If you are not willing to spend the time needed for your own application, then I  don't think anybody is going to be able to help you.
if you are interested, see this link for a vba parsing routine on the email body that be adapted to your specifics, and integrated with the code I gave you previously.
    https://www.experts-exchange.com/questions/24908662/Parse-Text-From-Outlook-Body-Using-VBA.html
    https://www.experts-exchange.com/questions/24908662/Parse-Text-From-Outlook-Body-Using-VBA.html
Here is a code to read mail from the Inbox (or can be coded to read for a specific folder if need be... the concerned mails can be routed to a specific folder using Outlook filters).
Each of the mail would be scanned for a "SubjectHint" (set this variable in the code)
Once run, the macro would scan all mails in that folder and if meets the criteria, parse the body of the mail and extract the required details. It would then populate the excel file accordingly. Note that 2 new columns have been added... Mail ID and Mail Received Date. Mail ID is stored so that no mail is extracted twice (using the unique ID of the mails).
Each of the mail would be scanned for a "SubjectHint" (set this variable in the code)
Once run, the macro would scan all mails in that folder and if meets the criteria, parse the body of the mail and extract the required details. It would then populate the excel file accordingly. Note that 2 new columns have been added... Mail ID and Mail Received Date. Mail ID is stored so that no mail is extracted twice (using the unique ID of the mails).
Option Explicit
Const sSubjectHint As String = "Deposit"
Public Sub FetchMails()
Dim olApp As Object, sIn As String
Set olApp = CreateObject("Outlook.Application")
Dim olNs 'As Namespace
Dim Fldr 'As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(6)
i = 1
For Each olMail In Fldr.Items
If InStr(olMail.body, "Transaction #") > 0 Or _
InStr(olMail.Subject, sSubjectHint) > 0 Then
If Application.WorksheetFunction.CountIf(Application.Range("I:I"), olMail.entryid) = 0 Then
sIn = olMail.body
ActiveSheet.Cells(i + 1, 1).Value = ReturnTagValue(sIn, "Transaction #")
ActiveSheet.Cells(i + 1, 2).Value = ReturnTagValue(sIn, "Client:")
ActiveSheet.Cells(i + 1, 3).Value = ReturnTagValue(sIn, "Account #")
ActiveSheet.Cells(i + 1, 4).Value = ReturnTagValue(sIn, "Value date:")
ActiveSheet.Cells(i + 1, 5).Value = ReturnTagValue(sIn, "Posted date:")
ActiveSheet.Cells(i + 1, 6).Value = ReturnTagValue(sIn, "Amount:")
ActiveSheet.Cells(i + 1, 7).Value = ReturnTagValue(sIn, "Currency:")
ActiveSheet.Cells(i + 1, 8).Value = ReturnTagValue(sIn, "Credit / Debit:")
ActiveSheet.Cells(i + 1, 9).Value = olMail.entryid
ActiveSheet.Cells(i + 1, 10).Value = Format(olMail.ReceivedTime, "dd-mmm-yy hh:mm AM/PM")
i = i + 1
End If
End If
Next olMail
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Public Function ReturnTagValue(sIn As String, sTag As String)
Dim nTemp As Long
nTemp = InStr(1, sIn, sTag, vbTextCompare)
If nTemp = 0 Then Exit Function
ReturnTagValue = Trim(Mid(sIn, nTemp + Len(sTag) + 1))
nTemp = InStr(1, ReturnTagValue, vbCrLf, vbTextCompare)
If nTemp = 0 Then Exit Function
ReturnTagValue = Trim(Mid(ReturnTagValue, 1, nTemp - 1))
End Function
ASKER
Looks promissing gbanik, I'll give it a try soon, but how does the code get initiated? What makes it do its thing?
Check the attached Excel file... run the macro "FetchMails" and step thru the code (F8) to understand more.
Note: If you run the macro directly without a breakpoint u might not get any results in return. Thats b'cos, first you have to configure the sSubjectHint variable to set the hint in the subject line. Example if the subject contains "Transaction - Direct Deposit to Account XXX" you could use "Direct Deposit" as the Subject Hint. The Subject hint will allow you to separate your chosen mails from the rest in the Inbox.
Also please read through my earlier post very carefully first.
Note: If you run the macro directly without a breakpoint u might not get any results in return. Thats b'cos, first you have to configure the sSubjectHint variable to set the hint in the subject line. Example if the subject contains "Transaction - Direct Deposit to Account XXX" you could use "Direct Deposit" as the Subject Hint. The Subject hint will allow you to separate your chosen mails from the rest in the Inbox.
Also please read through my earlier post very carefully first.
To answer how it could be initiated...
Add the subroutine FetchMails in the Workbook_Open event. That way when the workbook is opened, automatically the mails in your mailbox would be scanned. Also, since each record maintains the Mail ID, it parses only NEW mails and skips the already parsed ones!
Add the subroutine FetchMails in the Workbook_Open event. That way when the workbook is opened, automatically the mails in your mailbox would be scanned. Also, since each record maintains the Mail ID, it parses only NEW mails and skips the already parsed ones!
Private Sub Workbook_Open()
FetchMails
End Sub
ASKER
Looks good gbanik. How do I tell it to look in my folder named "EP Direct Deposits"?
ASKER
Just so you can see my folder scheme, see attached. And also know my Outlook account in IMAPed to our company gmail account if that matters. 
Change line
Set Fldr = olNs.GetDefaultFolder(6)
to
Set Fldr = olNs.Folders("support@offs
Set Fldr = olNs.GetDefaultFolder(6)
to
Set Fldr = olNs.Folders("support@offs
ASKER
Getting an error, bganik. Here's the code and attached is the error.
Â
Â
Option Explicit
Const sSubjectHint As String = "Deposit"
Private Sub Workbook_Open()
FetchMails
End Sub
Public Sub FetchMails()
Dim olApp As Object, sIn As String
Set olApp = CreateObject("Outlook.Application")
Dim olNs 'As Namespace
Dim Fldr 'As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.Folders("support@offshore.xxxxxx").Folders("EP Direct Deposits")
i = 1
For Each olMail In Fldr.Items
If InStr(olMail.body, "Transaction #") > 0 Or _
InStr(olMail.Subject, sSubjectHint) > 0 Then
If Application.WorksheetFunction.CountIf(Application.Range("I:I"), olMail.entryid) = 0 Then
sIn = olMail.body
'sIn = "Transaction # 00000002E7-xxx" & vbCrLf & _
"Client: SML." & vbCrLf & _
"Account # USD-100-458475" & vbCrLf & _
"Value date: 09/11/2010" & vbCrLf & _
"Posted date: 09/11/2010" & vbCrLf & _
"Amount: 7,951.60" & vbCrLf & _
"Currency: US Dollars" & vbCrLf & _
"Credit / Debit: Credit"
ActiveSheet.Cells(i + 1, 1).Value = ReturnTagValue(sIn, "Transaction #")
ActiveSheet.Cells(i + 1, 2).Value = ReturnTagValue(sIn, "Client:")
ActiveSheet.Cells(i + 1, 3).Value = ReturnTagValue(sIn, "Account #")
ActiveSheet.Cells(i + 1, 4).Value = ReturnTagValue(sIn, "Value date:")
ActiveSheet.Cells(i + 1, 5).Value = ReturnTagValue(sIn, "Posted date:")
ActiveSheet.Cells(i + 1, 6).Value = ReturnTagValue(sIn, "Amount:")
ActiveSheet.Cells(i + 1, 7).Value = ReturnTagValue(sIn, "Currency:")
ActiveSheet.Cells(i + 1, 8).Value = ReturnTagValue(sIn, "Credit / Debit:")
ActiveSheet.Cells(i + 1, 9).Value = olMail.entryid
ActiveSheet.Cells(i + 1, 10).Value = Format(olMail.ReceivedTime, "dd-mmm-yy hh:mm AM/PM")
i = i + 1
End If
End If
Next olMail
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Public Function ReturnTagValue(sIn As String, sTag As String)
Dim nTemp As Long
nTemp = InStr(1, sIn, sTag, vbTextCompare)
If nTemp = 0 Then Exit Function
ReturnTagValue = Trim(Mid(sIn, nTemp + Len(sTag) + 1))
nTemp = InStr(1, ReturnTagValue, vbCrLf, vbTextCompare)
If nTemp = 0 Then Exit Function
ReturnTagValue = Trim(Mid(ReturnTagValue, 1, nTemp - 1))
End Function
Sorry, I should have been more explicit...
Replace this
support@offshore.xxxxxx
by the actual folder name
You had blurred the image.
Replace this
support@offshore.xxxxxx
by the actual folder name
You had blurred the image.
ASKER
Beautiful! Just great!
However it didn't initiate when I opened the spreadsheet. Not a big deal really. And the Mail ID didn't have numbers. See attached.
And, I will be adding Credit Card Number and Reference Number as labels and their values to the incoming email. How do I add those to the code and import tojavascript:void(0); the spreadsheet? And I may rather have it initiate automatically with each coming email that has a specific word in the subject.
Ooops! Big problem. I tested with another email coming in and it erased the previous entry. See attached.
However it didn't initiate when I opened the spreadsheet. Not a big deal really. And the Mail ID didn't have numbers. See attached.
And, I will be adding Credit Card Number and Reference Number as labels and their values to the incoming email. How do I add those to the code and import tojavascript:void(0); the spreadsheet? And I may rather have it initiate automatically with each coming email that has a specific word in the subject.
Ooops! Big problem. I tested with another email coming in and it erased the previous entry. See attached.
First, I deliberately did not code it to fire as soon as you open the workbook. Thats because, you need to perfect it first. To initiate it on Workbook open, see my comment above... ID:34125091.
Now about the Mail ID, the mail ID is too long and hence I had set the "Shrink to Fit" property of the cell. To see the value select the cell and see the formula bar.
In order to initiate the process on every incoming mail, modify the line
    If InStr(olMail.body, "Transaction #") > 0 Or _
      InStr(olMail.Subject, sSubjectHint) > 0 Then
to
    If InStr(olMail.body, "Transaction #") > 0 Then
Finally, about the entries getting deleted.... indeed that was an error on my part. Change the following line
  i = 1
to
  i = Application.Range("A1").Cu
Now it should be fine!
Now about the Mail ID, the mail ID is too long and hence I had set the "Shrink to Fit" property of the cell. To see the value select the cell and see the formula bar.
In order to initiate the process on every incoming mail, modify the line
    If InStr(olMail.body, "Transaction #") > 0 Or _
      InStr(olMail.Subject, sSubjectHint) > 0 Then
to
    If InStr(olMail.body, "Transaction #") > 0 Then
Finally, about the entries getting deleted.... indeed that was an error on my part. Change the following line
  i = 1
to
  i = Application.Range("A1").Cu
Now it should be fine!
ASKER
Thank you, gbanik. Please look at the attached. Started out good. Had two emails in the designated folder and didn't quite bring in the second one. 
Can u check whether the 2nd mail passes the if criterra that the body contains "Transaction #"? If so, please post the final code of yours. This is a very minor code glitch that is stopping u now.
ASKER
I don't know. Here's the body of the 2nd email: 
Option Explicit
Const sSubjectHint As String = "Deposit"
Private Sub Workbook_Open()
FetchMails
End Sub
Public Sub FetchMails()
Dim olApp As Object, sIn As String
Set olApp = CreateObject("Outlook.Application")
Dim olNs 'As Namespace
Dim Fldr 'As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.Folders("support@offshore-protection.com").Folders("EP Direct Deposits")
i = Application.Range("A1").CurrentRegion.Rows.Count + 1
For Each olMail In Fldr.Items
If InStr(olMail.body, "Transaction #") > 0 Or _
InStr(olMail.Subject, sSubjectHint) > 0 Then
If Application.WorksheetFunction.CountIf(Application.Range("I:I"), olMail.entryid) = 0 Then
sIn = olMail.body
'sIn = "Transaction # 00000002E7-xxx" & vbCrLf & _
"Client: SML." & vbCrLf & _
"Account # USD-100-458475" & vbCrLf & _
"Value date: 09/11/2010" & vbCrLf & _
"Posted date: 09/11/2010" & vbCrLf & _
"Amount: 7,951.60" & vbCrLf & _
"Currency: US Dollars" & vbCrLf & _
"Credit / Debit: Credit"
ActiveSheet.Cells(i + 1, 1).Value = ReturnTagValue(sIn, "Transaction #")
ActiveSheet.Cells(i + 1, 2).Value = ReturnTagValue(sIn, "Client:")
ActiveSheet.Cells(i + 1, 3).Value = ReturnTagValue(sIn, "Account #")
ActiveSheet.Cells(i + 1, 4).Value = ReturnTagValue(sIn, "Value date:")
ActiveSheet.Cells(i + 1, 5).Value = ReturnTagValue(sIn, "Posted date:")
ActiveSheet.Cells(i + 1, 6).Value = ReturnTagValue(sIn, "Amount:")
ActiveSheet.Cells(i + 1, 7).Value = ReturnTagValue(sIn, "Currency:")
ActiveSheet.Cells(i + 1, 8).Value = ReturnTagValue(sIn, "Credit / Debit:")
ActiveSheet.Cells(i + 1, 9).Value = olMail.entryid
ActiveSheet.Cells(i + 1, 10).Value = Format(olMail.ReceivedTime, "dd-mmm-yy hh:mm AM/PM")
i = i + 1
End If
End If
Next olMail
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Public Function ReturnTagValue(sIn As String, sTag As String)
Dim nTemp As Long
nTemp = InStr(1, sIn, sTag, vbTextCompare)
If nTemp = 0 Then Exit Function
ReturnTagValue = Trim(Mid(sIn, nTemp + Len(sTag) + 1))
nTemp = InStr(1, ReturnTagValue, vbCrLf, vbTextCompare)
If nTemp = 0 Then Exit Function
ReturnTagValue = Trim(Mid(ReturnTagValue, 1, nTemp - 1))
End Function
ASKER
Also, I still have that previous question:
I will be adding Credit Card Number and Reference Number as labels and their values will be in the the incoming email. How do I add those to the code and import them to the spreadsheet?
I will be adding Credit Card Number and Reference Number as labels and their values will be in the the incoming email. How do I add those to the code and import them to the spreadsheet?
Adding new fields like Credit Card Number and Reference Number should be easy enough. Just keep adding tag parsing statements...
ActiveSheet.Cells(i + 1, 8).Value = ReturnTagValue(sIn, "Credit / Debit:")
ActiveSheet.Cells(i + 1, 9).Value = ReturnTagValue(sIn, "Credit Card Number:")
ActiveSheet.Cells(i + 1, 10).Value = ReturnTagValue(sIn, "Reference Number:")
ActiveSheet.Cells(i + 1, 11).Value = olMail.entryid
ActiveSheet.Cells(i + 1, 12).Value = Format(olMail.ReceivedTime
Regarding the 2nd mail error, check the subject of the 2nd mail... it says "EP 2 - test" rather than something like "XXX Deposit XXX". Thats what the code is checking for. Please MODIFY the sSubjectHint to suit your conditions... or eliminate it altogether if need be.
ActiveSheet.Cells(i + 1, 8).Value = ReturnTagValue(sIn, "Credit / Debit:")
ActiveSheet.Cells(i + 1, 9).Value = ReturnTagValue(sIn, "Credit Card Number:")
ActiveSheet.Cells(i + 1, 10).Value = ReturnTagValue(sIn, "Reference Number:")
ActiveSheet.Cells(i + 1, 11).Value = olMail.entryid
ActiveSheet.Cells(i + 1, 12).Value = Format(olMail.ReceivedTime
Regarding the 2nd mail error, check the subject of the 2nd mail... it says "EP 2 - test" rather than something like "XXX Deposit XXX". Thats what the code is checking for. Please MODIFY the sSubjectHint to suit your conditions... or eliminate it altogether if need be.
ASKER CERTIFIED SOLUTION
membership
Create a free account to see this answer
Signing up is free and takes 30 seconds. No credit card required.
ASKER
Thank you, gbank. This will save me tons of time. I really appreciate your help. A++
Thanks Morya1. I appreciate your compliments and your A++. But for some reason, the rating came only as 5.8
I would again appreciate if you would oblige with a rating correction if you please.
I would again appreciate if you would oblige with a rating correction if you please.
ASKER
how do I do that, gbanik?
And not sure what I do to the code:
If Application.WorksheetFunct
Below you can see I've added a Description column. Did I do it right and what do I change the I:I to?
If Application.WorksheetFunct
        sIn = olMail.body
       Â
        'sIn = "Transaction #    00000002E7-xxx" & vbCrLf & _
            "Client:    SML." & vbCrLf & _
            "Account #    USD-100-458475" & vbCrLf & _
            "Value date:    09/11/2010" & vbCrLf & _
            "Posted date:    09/11/2010" & vbCrLf & _
            "Amount:    7,951.60" & vbCrLf & _
            "Currency:    US Dollars" & vbCrLf & _
            "Credit / Debit:    Credit" & _
            "Description:  Description"
   Â
        ActiveSheet.Cells(i + 1, 1).Value = ReturnTagValue(sIn, "Transaction #")
        ActiveSheet.Cells(i + 1, 2).Value = ReturnTagValue(sIn, "Client:")
        ActiveSheet.Cells(i + 1, 3).Value = ReturnTagValue(sIn, "Account #")
        ActiveSheet.Cells(i + 1, 4).Value = ReturnTagValue(sIn, "Value date:")
        ActiveSheet.Cells(i + 1, 5).Value = ReturnTagValue(sIn, "Posted date:")
        ActiveSheet.Cells(i + 1, 6).Value = ReturnTagValue(sIn, "Amount:")
        ActiveSheet.Cells(i + 1, 7).Value = ReturnTagValue(sIn, "Currency:")
        ActiveSheet.Cells(i + 1, 8).Value = ReturnTagValue(sIn, "Credit / Debit:")
        ActiveSheet.Cells(i + 1, 9).Value = ReturnTagValue(sIn, "Description:")
        ActiveSheet.Cells(i + 1, 10).Value = olMail.entryid
        ActiveSheet.Cells(i + 1, 11).Value = Format(olMail.ReceivedTime
        i = i + 1
      End If
And not sure what I do to the code:
If Application.WorksheetFunct
Below you can see I've added a Description column. Did I do it right and what do I change the I:I to?
If Application.WorksheetFunct
        sIn = olMail.body
       Â
        'sIn = "Transaction #    00000002E7-xxx" & vbCrLf & _
            "Client:    SML." & vbCrLf & _
            "Account #    USD-100-458475" & vbCrLf & _
            "Value date:    09/11/2010" & vbCrLf & _
            "Posted date:    09/11/2010" & vbCrLf & _
            "Amount:    7,951.60" & vbCrLf & _
            "Currency:    US Dollars" & vbCrLf & _
            "Credit / Debit:    Credit" & _
            "Description:  Description"
   Â
        ActiveSheet.Cells(i + 1, 1).Value = ReturnTagValue(sIn, "Transaction #")
        ActiveSheet.Cells(i + 1, 2).Value = ReturnTagValue(sIn, "Client:")
        ActiveSheet.Cells(i + 1, 3).Value = ReturnTagValue(sIn, "Account #")
        ActiveSheet.Cells(i + 1, 4).Value = ReturnTagValue(sIn, "Value date:")
        ActiveSheet.Cells(i + 1, 5).Value = ReturnTagValue(sIn, "Posted date:")
        ActiveSheet.Cells(i + 1, 6).Value = ReturnTagValue(sIn, "Amount:")
        ActiveSheet.Cells(i + 1, 7).Value = ReturnTagValue(sIn, "Currency:")
        ActiveSheet.Cells(i + 1, 8).Value = ReturnTagValue(sIn, "Credit / Debit:")
        ActiveSheet.Cells(i + 1, 9).Value = ReturnTagValue(sIn, "Description:")
        ActiveSheet.Cells(i + 1, 10).Value = olMail.entryid
        ActiveSheet.Cells(i + 1, 11).Value = Format(olMail.ReceivedTime
        i = i + 1
      End If
ASKER
And, I can't say it is working. I get the first email that has only one record in it, but the second email has five records to import and it comes out like the attached. I will attach you code I updated as you directed. 
And here's two records out of the email that didn't import:
Transaction # Â Â Â Â Â Â 00000002F9-772
Client: Â Â Â Â Â Â Sovereign Management &Â Legal S.A.
Account # Â Â Â Â Â Â EUR-100-458209-3
Value date: Â Â Â Â Â Â 12/11/2010
Posted date: Â Â Â Â Â Â 12/11/2010
Amount: Â Â Â Â Â Â 100.00
Currency: Â Â Â Â Â Â Euro
Credit / Debit: Â Â Â Â Â Â Credit
Description: Â Â Â Â Â Â Incoming deposit Card#4381xxxxx01 - Pela, Satu
Transaction # Â Â Â Â Â Â 00000002FF-784
Client: Â Â Â Â Â Â Sovereign Management &Â Legal S.A.
Account # Â Â Â Â Â Â EUR-100-458209-3
Value date: Â Â Â Â Â Â 15/11/2010
Posted date: Â Â Â Â Â Â 15/11/2010
Amount: Â Â Â Â Â Â 1,000.00
Currency: Â Â Â Â Â Â Euro
Credit / Debit: Â Â Â Â Â Â Credit
Description: Â Â Â Â Â Â Incoming deposit Card#438101xxxxx04 - Bria, David
And here's two records out of the email that didn't import:
Transaction # Â Â Â Â Â Â 00000002F9-772
Client: Â Â Â Â Â Â Sovereign Management &Â Legal S.A.
Account # Â Â Â Â Â Â EUR-100-458209-3
Value date: Â Â Â Â Â Â 12/11/2010
Posted date: Â Â Â Â Â Â 12/11/2010
Amount: Â Â Â Â Â Â 100.00
Currency: Â Â Â Â Â Â Euro
Credit / Debit: Â Â Â Â Â Â Credit
Description: Â Â Â Â Â Â Incoming deposit Card#4381xxxxx01 - Pela, Satu
Transaction # Â Â Â Â Â Â 00000002FF-784
Client: Â Â Â Â Â Â Sovereign Management &Â Legal S.A.
Account # Â Â Â Â Â Â EUR-100-458209-3
Value date: Â Â Â Â Â Â 15/11/2010
Posted date: Â Â Â Â Â Â 15/11/2010
Amount: Â Â Â Â Â Â 1,000.00
Currency: Â Â Â Â Â Â Euro
Credit / Debit: Â Â Â Â Â Â Credit
Description: Â Â Â Â Â Â Incoming deposit Card#438101xxxxx04 - Bria, David
'Option Explicit
'Const sSubjectHint As String = "Deposit"
Private Sub Workbook_Open()
FetchMails
End Sub
Public Sub FetchMails()
Dim olApp As Object, sIn As String
Set olApp = CreateObject("Outlook.Application")
Dim olNs 'As Namespace
Dim Fldr 'As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.Folders("support@offshore-protection.com").Folders("EP Direct Deposits")
i = Application.Range("A1").CurrentRegion.Rows.Count + 1
For Each olMail In Fldr.Items
If InStr(olMail.body, "Transaction #") > 0 Or _
InStr(olMail.Subject, sSubjectHint) > 0 Then
If Application.WorksheetFunction.CountIf(Application.Range("J:J"), olMail.entryid) = 0 Then
sIn = olMail.body
'sIn = "Transaction # 00000002E7-xxx" & vbCrLf & _
"Client: SML." & vbCrLf & _
"Account # USD-100-458475" & vbCrLf & _
"Value date: 09/11/2010" & vbCrLf & _
"Posted date: 09/11/2010" & vbCrLf & _
"Amount: 7,951.60" & vbCrLf & _
"Currency: US Dollars" & vbCrLf & _
"Credit / Debit: Credit" & _
"Description: Description"
ActiveSheet.Cells(i + 1, 1).Value = ReturnTagValue(sIn, "Transaction #")
ActiveSheet.Cells(i + 1, 2).Value = ReturnTagValue(sIn, "Client:")
ActiveSheet.Cells(i + 1, 3).Value = ReturnTagValue(sIn, "Account #")
ActiveSheet.Cells(i + 1, 4).Value = ReturnTagValue(sIn, "Value date:")
ActiveSheet.Cells(i + 1, 5).Value = ReturnTagValue(sIn, "Posted date:")
ActiveSheet.Cells(i + 1, 6).Value = ReturnTagValue(sIn, "Amount:")
ActiveSheet.Cells(i + 1, 7).Value = ReturnTagValue(sIn, "Currency:")
ActiveSheet.Cells(i + 1, 8).Value = ReturnTagValue(sIn, "Credit / Debit:")
ActiveSheet.Cells(i + 1, 9).Value = ReturnTagValue(sIn, "Description:")
ActiveSheet.Cells(i + 1, 10).Value = olMail.entryid
ActiveSheet.Cells(i + 1, 11).Value = Format(olMail.ReceivedTime, "dd-mmm-yy hh:mm AM/PM")
i = i + 1
End If
End If
Next olMail
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Public Function ReturnTagValue(sIn As String, sTag As String)
Dim nTemp As Long
nTemp = InStr(1, sIn, sTag, vbTextCompare)
If nTemp = 0 Then Exit Function
ReturnTagValue = Trim(Mid(sIn, nTemp + Len(sTag) + 1))
nTemp = InStr(1, ReturnTagValue, vbCrLf, vbTextCompare)
If nTemp = 0 Then Exit Function
ReturnTagValue = Trim(Mid(ReturnTagValue, 1, nTemp - 1))
End Function
I:I gets changed to whatever the new mail ID Column is...
I am guessing your mail ID column now is J, as you have added a new parameter "Description". Hence use J:J
By the way, to change the rating u will have to just post "Change rating" as a new question to the General Area. Someone will attend to it.
https://www.experts-exchange.com/Community_Support/General/newQuestionWizard.jsp
I am guessing your mail ID column now is J, as you have added a new parameter "Description". Hence use J:J
By the way, to change the rating u will have to just post "Change rating" as a new question to the General Area. Someone will attend to it.
https://www.experts-exchange.com/Community_Support/General/newQuestionWizard.jsp
The code expects only one block of info per mail (check your example). I do not see you mention this earlier that a single mail could have multiple blocks of info??
To manage the multiple blocks of info within a mail, the code needs to first split into blocks, and then run the parsing logic one block at a time (loop).
Another piece of advice Morya1, expect the Experts to provide you directions... be prepared to connect the final dots.
"And, I can't say it is working....." may be too harsh.
To manage the multiple blocks of info within a mail, the code needs to first split into blocks, and then run the parsing logic one block at a time (loop).
Another piece of advice Morya1, expect the Experts to provide you directions... be prepared to connect the final dots.
"And, I can't say it is working....." may be too harsh.
Let me work on the code for you.... give me few moments.....
Option Explicit
Const sSubjectHint As String = "Deposit"
Public Sub FetchMails()
Dim olApp As Object, sInVar As Variant, sIn As String, jCtr As Integer
Set olApp = CreateObject("Outlook.Application")
Dim olNs 'As Namespace
Dim Fldr 'As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(6)
i = Application.Range("A1").CurrentRegion.Rows.Count + 1
For Each olMail In Fldr.Items
If InStr(olMail.body, "Transaction #") > 0 Or _
InStr(olMail.Subject, sSubjectHint) > 0 Then
If Application.WorksheetFunction.CountIf(Application.Range("I:I"), olMail.entryid) = 0 Then
sInVar = Split(olMail.body, "Transaction #")
For jCtr = LBound(sInVar) + 1 To UBound(sInVar)
sIn = "Transaction # " & sInVar(jCtr)
ActiveSheet.Cells(i + 1, 1).Value = ReturnTagValue(sIn, "Transaction #")
ActiveSheet.Cells(i + 1, 2).Value = ReturnTagValue(sIn, "Client:")
ActiveSheet.Cells(i + 1, 3).Value = ReturnTagValue(sIn, "Account #")
ActiveSheet.Cells(i + 1, 4).Value = ReturnTagValue(sIn, "Value date:")
ActiveSheet.Cells(i + 1, 5).Value = ReturnTagValue(sIn, "Posted date:")
ActiveSheet.Cells(i + 1, 6).Value = ReturnTagValue(sIn, "Amount:")
ActiveSheet.Cells(i + 1, 7).Value = ReturnTagValue(sIn, "Currency:")
ActiveSheet.Cells(i + 1, 8).Value = ReturnTagValue(sIn, "Credit / Debit:")
ActiveSheet.Cells(i + 1, 9).Value = olMail.entryid
ActiveSheet.Cells(i + 1, 10).Value = Format(olMail.ReceivedTime, "dd-mmm-yy hh:mm AM/PM")
i = i + 1
Next
End If
End If
Next olMail
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Public Function ReturnTagValue(sIn As String, sTag As String)
Dim nTemp As Long
nTemp = InStr(1, sIn, sTag, vbTextCompare)
If nTemp = 0 Then Exit Function
ReturnTagValue = Trim(Mid(sIn, nTemp + Len(sTag) + 1))
nTemp = InStr(1, ReturnTagValue, vbCrLf, vbTextCompare)
If nTemp = 0 Then Exit Function
ReturnTagValue = Trim(Mid(ReturnTagValue, 1, nTemp - 1))
End FunctionASKER
My apologies. Guess I was in a hurry to respond as I was needing it to work this am. What you've done has been great.
On multiple blocks: "The column on the left would be the column headings and the values on the right of the above example would comprise one record (one row - so it transposes) and as each email comes in, some might have more than one of these but the left hand column would always be the same text. "
Guess that wasn't explained too well,
Thank you for the extra effort.
On multiple blocks: "The column on the left would be the column headings and the values on the right of the above example would comprise one record (one row - so it transposes) and as each email comes in, some might have more than one of these but the left hand column would always be the same text. "
Guess that wasn't explained too well,
Thank you for the extra effort.
Sorry ... I used the code that I had at my end... u may have to edit back the changes u made like ...
Set Fldr = olNs.Folders("support@offs
and the new column
Description.
Set Fldr = olNs.Folders("support@offs
and the new column
Description.
Also may I ask you to add a zone "Outlook" to the question?
ASKER
Wow!!! I can't tell you how great that is!!!
I do have another thing that needs to be done with it but I will post another related question.
But to give you a heads up, if you would like to work on it, it seems that the Description column VALUE is coming in like this:
Description: Â Â Â Â Â Â Incoming deposit Card#438101xxxxx104 - Brita, David
So, Col B has the "Incoming deposit Card#" as a consistent label. Since it is consistent, but in Col B, Â can we break that string up and put "Incoming deposit Card#" as one column header and Cardholder Name in another column, effectively breaking up the string where there is the - before the name and putting the card number in one column and the name in another?
Let me know if you want to work on that and I'll post it repeating the above info.
Thank you again. Great work!
I do have another thing that needs to be done with it but I will post another related question.
But to give you a heads up, if you would like to work on it, it seems that the Description column VALUE is coming in like this:
Description: Â Â Â Â Â Â Incoming deposit Card#438101xxxxx104 - Brita, David
So, Col B has the "Incoming deposit Card#" as a consistent label. Since it is consistent, but in Col B, Â can we break that string up and put "Incoming deposit Card#" as one column header and Cardholder Name in another column, effectively breaking up the string where there is the - before the name and putting the card number in one column and the name in another?
Let me know if you want to work on that and I'll post it repeating the above info.
Thank you again. Great work!
yeah ... lemme do it for you...
Post your latest code that u r working on (so that u dont have to reformat again) and gimme a few minutes....
meanwhile please add the Outlook Zone to this question.
Post your latest code that u r working on (so that u dont have to reformat again) and gimme a few minutes....
meanwhile please add the Outlook Zone to this question.
this is very much within this question :)
please post your code
please post your code
     http://blogs.techrepublic.com.com/msoffice/?p=744