?
Solved

slight tweak to previous solution

Posted on 2013-02-04
8
Medium Priority
?
196 Views
Last Modified: 2013-02-11
In a previous solution gowflow created a function that scans the inbox of my Outlook 2010 and imports data that meets a certain criteria into the WU-Staging-FBME sheet of my Visa workbook. It works great.

However, there is one problem: It also tries to import emails that have the criteria in the HISTORY of the email.  

Attached is a scrubbed example of the type of email that should (and does) import. (JEN-ExampleofCardNumber)JEN-ExampleofCardNumberThatDoesI.msg

There is also attached an example of a scrubbed email that has the Western Union data, but it is in the history of a email and should not be sent. (Re-Shawn-112112-1)
RE-Shawn-112112-1-----2235.msg
0
Comment
Question by:JaseSt
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 5
  • 3
8 Comments
 
LVL 31

Expert Comment

by:gowflow
ID: 38851236
You mean to say only import original mail sent not replies to old mails ?
gowflow
0
 
LVL 31

Accepted Solution

by:
gowflow earned 2000 total points
ID: 38851297
ok here it is.

1) Make a copy of your latest Visa file and give it a new name
2) Goto VBA and doubleclick on mudule1 and view each sub at a time.
3) Locate the sub ImportWesternUnion and delete the whole code that is there.
4) Paste the below code after any End Sub.

Sub ImportWesternUnion()
Dim WS As Worksheet
Dim objOutlook As Object
Dim Rng As Range, RngCardHolder As Range
Dim arrRows() As String
Dim arrRow() As String
Dim elem As Variant
Dim FMonitor, FTransfer
Dim FoundDivider As Boolean, FirstItemInMail As Boolean, StartDivider As Boolean
Dim CardNumber As String, CardHolder As String, TmpCardHolder As String
Dim SenderEmail As String
Dim Divider As String
Dim I As Long, J As Long, K As Long, L As Long
Dim C, FirstAddress, Items
Dim TmpAmount As String
Dim Fields As String, Possibility As String
Dim LenItem As Long, ColJRow As Long, ColARow As Long
Dim eType As String

Set objOutlook = CreateObject("Outlook.application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set WS = Sheets("WU-Staging-FBME")


FMonitor = Split(Mid(gstFolderToMonitor, 2), "\")
If Not SetMonitorFolder(FMonitor) Then Exit Sub
wsMain.Range("L" & CRow) = "Import Western Union - FMonitor: " & objFolderToMonitor
CRow = CRow + 1

'Disabled in this procedure as user do not want to move emails.
'FTransfer = Split(Mid(gstFolderToTransfer, 2), "\")
'If Not SetTransferFolder(FTransfer) Then Exit Sub
'wsMain.Range("L" & CRow) = "Locate Emails - FTransfer: " & objFolderToTransfer
'CRow = CRow + 1

Dim VItem As Outlook.MailItem

Set VisaItems = objFolderToMonitor.Items.Restrict("[Subject] <> 'Payment Received'")
VisaItems.Sort "receivedtime", False

'Setting Value of I depending on last item in Col J
ColJRow = WS.Range("J:J").Rows(WS.Range("J:J").Rows.Count).End(xlUp).Row
ColARow = WS.Range("A:A").Rows(WS.Range("A:A").Rows.Count).End(xlUp).Row
WS.Range("D:D").NumberFormat = "@"

If ColARow = ColJRow Then
    I = 1
Else
    I = WS.Cells(ColARow, 1) + 1
End If

Application.EnableEvents = False

For Each VItem In VisaItems
    wsMain.Range("L" & CRow) = "Import WU/MG - Items: " & I & " " & VItem.SenderEmailAddress & " " & VItem
    CRow = CRow + 1

    Set objMail = VItem
    ' use Instr here to check subject or body
    'MsgBox objMail.Subject
    '---> Do not process replied mails.
    If Left(objMail.Subject, 3) <> "RE:" Then
    
        Body = objMail.Body
        Etime = objMail.ReceivedTime
        CardNumber = ""
        FoundDivider = False
        StartDivider = False
        FirstItemInMail = True
        SenderEmail = objMail.SenderEmailAddress
        
        
        'Split Email address
        Select Case Trim(UCase(SenderEmail))
            Case "WHITE@SECURENYM.NET"
                CardHolder = "Jen" & Format(Etime, "mmddyy")
            Case "LENNOX@SECURENYM.NET"
                CardHolder = "Adam" & Format(Etime, "mmddyy")
            Case "KONG@SECURENYM.NET"
                CardHolder = "Shawn" & Format(Etime, "mmddyy")
            Case "INFO@HOLMSENTREPRISES.COM"
                CardHolder = "Holms" & Format(Etime, "mmddyy")
            Case Else
                CardHolder = SenderEmail & Format(Etime, "mmddyy")
        End Select
        
        'Check to see if Combination CardHolder + Col C date already exist then increment CardHolder by 1
        With WS.Range("M:M")
            TmpCardHolder = CardHolder
            K = 2
            Do
                Set C = .Find(TmpCardHolder, LookIn:=xlValues, lookat:=xlPart)
                If Not C Is Nothing Then
                    TmpCardHolder = CardHolder & "-" & Format(K)
                    K = K + 1
                End If
            Loop Until C Is Nothing
            CardHolder = TmpCardHolder
    
        End With
    
        
        '---> Trap WU or MG Emails
        If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 Or InStr(1, UCase(Body), "MG", vbTextCompare) > 0 Then
            
            '---> Set Type of Email for future use
            If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 And InStr(1, UCase(Body), "MG", vbTextCompare) > 0 Then
                eType = "MIX"
            Else
                If InStr(1, UCase(Body), "MTCN", vbTextCompare) > 0 Then eType = "WU"
                If InStr(1, UCase(Body), "MG", vbTextCompare) > 0 Then eType = "MG"
            End If
            
            If Rng Is Nothing Then
                Set Rng = WS.Range("B" & WS.UsedRange.Rows.Count).Offset(1, 0)
                Rng.Offset(1, 0).EntireRow.Insert
                WS.Range(Rng.Offset(0, -1), Rng.Offset(0, 39)).Interior.ColorIndex = 6
                'Made to trap yellow lines for Export Email
                Rng.Offset(0, 2).Value = " "
            Else
                Rng.Offset(1, 0).EntireRow.Insert
                WS.Range(Rng.Offset(1, -1), Rng.Offset(1, 39)).Interior.ColorIndex = 6
                'Made to trap yellow lines for Export Email
                Rng.Offset(1, 2).Value = " "
                Set Rng = Rng.Offset(1, 0)
            End If
            arrRows = Split(Body, vbCrLf, , vbTextCompare)
            For Each elem In arrRows
        
                'Spot Card Number as 'CARD #'
                If (InStr(1, UCase(elem), "CARD #", vbTextCompare) > 0 Or InStr(1, UCase(elem), "CARD#", vbTextCompare) > 0) And CardNumber = "" Then
                    If InStr(1, UCase(elem), "CARD #", vbTextCompare) > 0 Then CardNumber = Trim(Mid(elem, InStr(1, UCase(elem), "CARD #", vbTextCompare) + 6))
                    If InStr(1, UCase(elem), "CARD#", vbTextCompare) > 0 Then CardNumber = Trim(Mid(elem, InStr(1, UCase(elem), "CARD#", vbTextCompare) + 5))
                    
                    If Not IsNumeric(CardNumber) Then
                        TmpCardNumber = ""
                        For J = 1 To Len(CardNumber)
                            If IsNumeric(Mid(CardNumber, J, 1)) Then TmpCardNumber = TmpCardNumber & Mid(CardNumber, J, 1)
                        Next J
                        CardNumber = TmpCardNumber
                    End If
                    'To prevent other routines to interact
                    elem = ""
                End If
                    
                'Spot when block does not have semicolumn as divider in semicolumn ':' or else use space ' '
                If Left(Trim(elem), 1) <> "-" And Left(Trim(elem), 1) <> "=" And Left(Trim(elem), 1) <> "*" And Trim(elem) <> "" Then
                    If InStr(elem, ":") > 0 Then
                        If InStr(InStr(elem, ":") + 1, elem, ":") > 0 Then
                            Divider = " "
                        Else
                            Divider = ":"
                        End If
                    Else
                        If InStr(elem, ";") > 0 Then
                            If InStr(InStr(elem, ";") + 1, elem, ";") > 0 Then
                                Divider = " "
                            Else
                                Divider = ";"
                            End If
                        Else
                            If InStr(elem, " ") > 0 Then
                                Divider = " "
                            Else
                                Divider = ""
                            End If
                        End If
                    End If
                End If
                    
                'Spot beginning of Items
                If Left(elem, 1) = "-" Or Left(elem, 1) = "=" Then
                    FoundDivider = True
                    StartDivider = True
                End If
                
                
                'Spot Dividers in semicolumn ':' or else use space ' '
                LenItem = 0
                Possibility = ""
                If eType = "MIX" And FoundDivider Then
                    If InStr(1, UCase(elem), "MTCN", vbTextCompare) > 0 Then eType = "WU"
                    If InStr(1, UCase(elem), "MG", vbTextCompare) > 0 Then eType = "MG"
                End If
                
                If eType = "WU" Then Fields = "MTCN|MTCN#|MCTN|MCTN#|MTCN #|MTC#|MTCN;"
                If eType = "MG" Then Fields = "MG|MG#|MG #|MG;"
                
                Items = Split(Fields, "|")
                For L = 0 To UBound(Items)
                    If InStr(1, elem, Items(L), vbTextCompare) > 0 Then
                        If Len(Items(L)) > LenItem Then
                            Possibility = Items(L)
                            LenItem = Len(Items(L))
                        End If
                    End If
                Next L
                If Possibility <> "" Then
                    If Not FoundDivider Then FoundDivider = True
                    If Divider = "" Then
                        Divider = " "
                        elem = Possibility & Divider & Mid(elem, Len(Possibility) + 1)
                    End If
                End If
                    
                If InStr(elem, Divider) > 0 And Divider <> "" Then
                    arrRow = Split(elem, Divider)
                    'Select Case Trim(UCase(CStr(arrRow(0))))
                    '    Case "MTCN", "MTCN#", "MCTN", "MCTN#", "MTCN #", "MTC#", "MTCN;"
                    '        If Not FoundDivider Then FoundDivider = True
                    '
                    'End Select
                
                    
                    If FoundDivider And StartDivider Then
                        'Delete Row if no values
                        If WS.Range(Rng.Offset(0, -1), Rng.Offset(0, 39)).Interior.ColorIndex <> 6 And Rng.Offset(0, 0).Value = "" And Rng.Offset(0, 2).Value = "" And Rng.Offset(0, 3).Value = "" And Rng.Offset(0, 5).Value = "" Then
                            RngDeletd = WS.Cells(Rng.Row - 1, Rng.Column).Address
                            WS.Range(Rng.Row & ":" & Rng.Row).EntireRow.Delete
                            Set Rng = WS.Range(RngDeletd)
                            I = I - 1
                        End If
                        Set Rng = Rng.Offset(1, 0)
                        Rng.Offset(0, 1) = Format(Etime, "dd mmm yyyy")
                        Rng.Offset(0, -1) = I
                        Rng.Offset(0, 11) = CardHolder
                        If FirstItemInMail Then
                            Rng.Offset(0, 16) = CardNumber
                            If Left(CardNumber, 1) = "4" Then Rng.Offset(0, 17) = "EUR"
                            If Left(CardNumber, 1) = "5" Then Rng.Offset(0, 17) = "USD"
                            FirstItemInMail = False
                        End If
                        wsMain.Range("L" & CRow) = "    Item: " & I & " " & VItem.SenderEmailAddress
                        CRow = CRow + 1
                        I = I + 1
                        FoundDivider = False
                    End If
                    
                    
                    If Divider = " " And (CardNumber <> "" Or StartDivider = True) Then
                         X = UpdateItemFound(Rng, elem, eType)
                    Else
                        Select Case Trim(UCase(CStr(arrRow(0))))
                            Case "MTCN", "MTCN#", "MCTN", "MCTN#", "MTCN #", "MTC#", "MTCN;"
                                'Fix to importing MCTN with all characters including leading and trailing zeros
                                If Trim(arrRow(1)) <> "" Then
                                    Rng.Offset(0, 2) = Trim(Format(arrRow(1), "@"))
                                Else
                                    If UBound(arrRow) > 1 Then
                                        Rng.Offset(0, 2) = Trim(Format(arrRow(2), "@"))
                                    End If
                                End If
                            Case "MG", "MG#", "MG #", "MG;"
                                'Fix to importing MG with all characters including leading and trailing zeros
                                If Trim(arrRow(1)) <> "" Then
                                    Rng.Offset(0, 2) = Trim(Format(arrRow(1), "@"))
                                Else
                                    If UBound(arrRow) > 1 Then
                                        Rng.Offset(0, 2) = Trim(Format(arrRow(2), "@"))
                                    End If
                                End If
                            Case "RECEIVER", "RECIEVER INFO", "RECEIVER NAME", "RECIEVER", "RECEVIER", "RECIVER", "RCVR"
                                Rng = Trim(arrRow(1))
                            Case "SENDER LOCATION", "LOCATION", "SENDER'S W.U. LOCATION", "SENDER'S W.U. LOCATION(CITY & STATE)", "SENDERS W.U. LOCATION", "SENDER'S W.U. LOCATION (CITY AND STATE)", "SENDER'S LOCATION", "SENDER INFO", "SENDER LOC ", "W U LOCATION", "SENDER WU LOCATION", "SEND LOC ", "SENDER LOC", "SENDER LOC", "SENDERS WU LOCATIONS", "SENDERS W.U'S LOCATION", "SENDERS W/U LOCATION", "ADDRESS", "SENDERS W.U. LOCATION", "SENDERS LOCATION", "SENDER WU LOCATION", "SENDER LOCATION SENT", "SENDER W/U LOCATION", "SENDER W.U. LOCATION", "W.U. LOCATION", "W/U LOCATION", "W.U. LOCTION", "SENDER LOC.", "AMT SENT", "SENT FROM", "WU LOCATION", "LOCATION.", "LOC.", "SENDING WU LOCATION", "CITY"
                                Rng.Offset(0, 4) = Trim(arrRow(1))
                            Case "AMOUNT", "AMT", "AMOUNT SENT", "TOTAL", "TOTAL AMOUNT", "AOUNT", "MOUNT", "AMMOUNT", "AMNT", "AMOUNT $"
                                'Fix to importing amount as a number formated as $currency with double digits and
                                'Red if negatives
                                If Not IsNumeric(arrRow(1)) Then
                                    TmpAmount = ""
                                    For J = 1 To Len(elem)
                                        If IsNumeric(Mid(elem, J, 1)) Or Mid(elem, J, 1) = "." Then TmpAmount = TmpAmount & Mid(elem, J, 1)
                                    Next J
                                    arrRow(1) = TmpAmount
                                End If
                                If arrRow(1) <> "" Then Rng.Offset(0, 5) = CDbl(arrRow(1))
                                Rng.Offset(0, 5).NumberFormat = "$#,##0.00;[Red]($#,##0.00)"
                            Case "SENDER", "ENDER"
                                Rng.Offset(0, 3) = Trim(arrRow(1))
                            Case Else
                        End Select
                        
                    End If
                End If
                
            Next elem
        End If
    Else
        wsMain.Range("L" & CRow) = "Import WU/MG - Items: " & I & " Not Processed as History Mail."
        CRow = CRow + 1
    End If
Next VItem

Application.EnableEvents = True

'WS.UsedRange.EntireColumn.AutoFit
X = MsgBox("Total of " & I & " WU/MG detailed transfer imported successfully." & Chr(10) _
    & "Please check data in sheet 'WU-Staging-FBME' and make necessary corrections if any before proceeding to Step 2 - [Generate WU File]", vbInformation, "Step 1 - Import WU Emails")

End Sub

Open in new window


5) SAVE and Exit the workbook.
6) Open it and Try it having a mail not desired in hte inbox try having more than one.
7) When you run the Import WU/MG Emails button it create a trace in the sheet Main look for the items imported and if an item is not Imported it will tell you.

Also check the data if it was imported or not.
gowflow
0
 

Author Comment

by:JaseSt
ID: 38862471
Sorry for the delay but had to wait for a real email that met the criteria to test against.

Tried to import the attached but nothing copied to the spreadsheet.

It does, however, import the original WU pickup request emails just fine.RE-Pickup-request-transfer-Weste.msg
0
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 
LVL 31

Expert Comment

by:gowflow
ID: 38863608
Well it is not that that you want ???? This mail is not original and it is a replied to an other Email !!!! then it is not imported. That is not what you have asked ???
gowflow
0
 

Author Comment

by:JaseSt
ID: 38863639
I see. You are basing the function on a reply email?

However, there are times when they put a current and valid pick up request at the top of a replied to email which contains previous pickup requests already imported to the spreadsheet as in the posted example. But those are rare. For now let's just keep it as is.

I will accept this solution and if I find I need further tweaking I will let you know.
0
 

Author Closing Comment

by:JaseSt
ID: 38863730
Works as requested. Great work. Thank you gowflow!

Another one coming up - more involved - if willing.
0
 

Author Comment

by:JaseSt
ID: 38878729
gowflow, this function choked with on the attached email. Can it be modified to work with emails of this sort?Re-SGC-Mastercard-Application--a.msg
0

Featured Post

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.

800 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question