Solved

Part 4 to: Import more data into spreadsheet

Posted on 2013-05-30
57
264 Views
Last Modified: 2013-06-07
This is a continuation of http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28133253.html (Part 3 to: Import more data into spreadsheet)

In addition to the xls formatted file I need imported from Outlook 2010 I also need the function to import a .csv file. The scrubbed email with its csv attachment is attached.

I need the function to extract the same data from the attachment and email as is extracted from the Public Sub SaveAttachments() function.

Sovereign-Gold-Card---Order-446-.msg
0
Comment
Question by:JaseSt
  • 31
  • 26
57 Comments
 

Author Comment

by:JaseSt
ID: 39207982
uploading attachment again.FW-Sovereign-Gold-Card---Order-4.msg
0
 

Author Comment

by:JaseSt
ID: 39207988
hmmm... when I click on the attachment it doesn't open as an email for me. Does it for you?
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39208189
yes the attachment opens in Excel as it is CSV but it does not open it in columns all goes in Col A
gowflow
0
 

Author Comment

by:JaseSt
ID: 39208262
yes, that's how I receive it, but when I open up the csv it looks like the attached.

csv
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39210050
yes correct, and this makes it a bit more manipulation than Excel as we need to go thru the items seuquentially to locate what we want.

Is this a real example ?? or just a file you made up ?? I cannot write a macro on suppositions I need a final format with some data there to be able to get you the correct data out.

Can you post some examples so I can work on ?

Also what would happen if you have both .xls and .csv in the attachment which one we look for to update the record ???

gowflow
0
 

Author Comment

by:JaseSt
ID: 39210469
we should only get either the csv OR the xls file in one email, not both in the same email.( The csv file comes from a web order and the xls file comes in reply to me sending it out for the applicant to fill out and return.)

the example sent is a real example where I just changed names and numbers

what further examples are you needing? I posted the csv file.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39210772
ok here it is this should deal with both scenarios. The only thing remaining is that in csv I do not know where the Card number come at what location as the code you posted had not this info.

check it out and let me know.

1) Make a copy of ur latest file and give it a new name.
2) goto vba and delete SaveAttachements and replace it by the below version.

Public Sub SaveAttachments()
On Error GoTo ErrHandler

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim I As Long, J As Long, K As Long
Dim lngCount As Long
Dim LastRow As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim cCell As Range
Dim WS As Worksheet
Dim FileExt As String
Dim AttachRange As Range
Dim WB As Workbook
Dim WSAttach As Worksheet
Dim X, sFields
Dim ValidFile As Boolean

    Set WS = ActiveSheet
        
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    'On Error Resume Next
 
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
 
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    'Set objSelection = objOL.GetNamespace("MAPI").Folders("CM Template")
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
 
    ' Set the Attachment folder to be this specific path as per Jaset request on Apr 29, 2013
    strFolderpath = strFolderpath & "\OLAttachments"
    'strFolderpath = "C:\Users\Michael\Sovereign Archives"
    
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
 
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
         
        '---> Choose the color of the row
        Set cCell = ActiveCell
        LastRow = cCell.Row + 1
        Do
            '---> Locate the cell color of the last row above the current one
            LastRow = LastRow - 1
            LastRow = WS.Range("A" & LastRow).End(xlUp).Row
            
        Loop Until WS.Range("A" & LastRow).Interior.Color <> 16777215 Or LastRow = 1
        
        '---> Color the new row based on the results
        If WS.Range("A" & LastRow).Interior.Color = 14545386 Then
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 10147522
        Else
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 14545386
        End If
         
        If lngCount > 0 Then
            ' Use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            K = 0
            For I = lngCount To 1 Step -1
             
                ' Get the file name.
                strFile = objAttachments.Item(I).FileName
                 
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & "\" & strFile
                 
                ' Save the attachment as a file.
                Application.DisplayAlerts = False
                
                On Error Resume Next
                Do
                    objAttachments.Item(I).SaveAsFile strFile
                    
                    If Err <> 0 Then
                        MkDir (Left(strFile, InStrRev(strFile, "\")))
                    Else
                        On Error GoTo 0
                    End If
                Loop Until Err = 0
                
                        
                '---> Insert data in coresponding cells
                Do Until WS.Cells(cCell.Row, K + 5) = ""
                    If K + 6 = 9 Then
                        '---> Copy Insert the new row and contine in Cell E
                        WS.Cells(cCell.Row, K + 5).EntireRow.Copy
                        WS.Cells(cCell.Row, K + 5).EntireRow.Insert
                        WS.Range("E" & cCell.Row & ":H" & cCell.Row).ClearContents
                        K = -1
                    End If
                    K = K + 1
                Loop
                WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
                WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
                
                WS.Range(WS.Cells(cCell.Row, K + 5), WS.Cells(cCell.Row, K + 5)).Formula = "=hyperlink(" & Chr(34) & strFile & Chr(34) & "," & Chr(34) & Right(strFile, Len(strFile) - InStrRev(strFile, "\")) & Chr(34) & ")"
                
                FileExt = LCase(Right(strFile, Len(strFile) - InStrRev(LCase(strFile), ".", Len(strFile))))
                
                '---> Check to See if Valid Excel File
                If InStr(1, FileExt, "xls") <> 0 Or InStr(1, FileExt, "xlsm") <> 0 Or InStr(1, FileExt, "xltx") <> 0 Or InStr(1, FileExt, "xlsx") <> 0 Then
                    '---> Open Workbook
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                    Set WB = Workbooks.Open(strFile)
                    Set WSAttach = WB.ActiveSheet
                                
                    '---> Test to see if Valid CC File
                    'If WSAttach.Range("P1") <> "" Then
                    If WSAttach.Range("A1") = "First Name" And WSAttach.Range("B1") = "Last Name" And WSAttach.Range("O1") = "Email Address" Then
                        '---> We are Dealing with Horizontal Spreadsheet
                        '     Assign Col A to Col C as First Name
                        '     Assign Col B to Col B as Last Name
                        WS.Range("C" & cCell.Row) = WSAttach.Range("A2")
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")

                        
                        '---> Depending on Value of Col P affect Col T
                        If WSAttach.Range("P1") = "Card Number" Then
                            WS.Range("T" & cCell.Row).NumberFormat = "Text"
                            WS.Range("T" & cCell.Row) = WSAttach.Range("P2")
                        Else
                            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        End If
                    Else
                        '---> We are Dealing with Vertical Spreadsheet
                        '     Assign B1 to Col C as First Name
                        '     Assign B2 to Col B as Last Name
                        '     Col T = 'Not Yet Assigned'
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        WS.Range("C" & cCell.Row) = WSAttach.Range("B1")
                        WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                    End If
                
                    '---> Close Workbook
                    WB.Close SaveChanges:=False
                    Set WSAttach = Nothing
                    Set WB = Nothing
        
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                
                Else
                
                    '---> Check to see if Valid .csv file
                    If InStr(1, FileExt, "csv") <> 0 Then
                        '---> Open Workbook
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
            
                        Open strFile For Input As #1
                        
                        '---> Read the Header
                        Line Input #1, X
                        sFields = Split(X, ",")
                        
                        '---> Test to see if Valid File
                        If InStr(1, sFields(0), "First Name") <> 0 And InStr(1, sFields(1), "Last Name") <> 0 And InStr(1, sFields(7), "Email Address") <> 0 Then
                            Line Input #1, X
                            sFields = Split(X, ",")
                            
                            '---> Strip quotes prior affecting
                            X = ""
                            For J = 1 To Len(sFields(0))
                                If Mid(sFields(0), J, 1) <> Chr(34) Then
                                    X = X & Mid(sFields(0), J, 1)
                                End If
                            Next J
                            sFields(0) = X
                            
                            X = ""
                            For J = 1 To Len(sFields(1))
                                If Mid(sFields(1), J, 1) <> Chr(34) Then
                                    X = X & Mid(sFields(1), J, 1)
                                End If
                            Next J
                            sFields(1) = X
                            
                            WS.Range("C" & cCell.Row) = sFields(0)
                            WS.Range("B" & cCell.Row) = sFields(1)
                        End If
                        
                        '---> Close the File
                        Close #1
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
                    End If
                    
                End If
                
                
            Next I
            
            '---> Check after all Attachements if Still Col T Empty
            '     then update with Not Yet Assigned.
            '     to ensure Col T always Updated with value
            If WS.Range("T" & cCell.Row) = "" Then
                WS.Range("T" & cCell.Row) = "Not Yet Assigned"
            End If
            
        Else
            '---> Update Email, Date, CC Even if no attachements
            WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
            WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
        End If
        
        '---> Move ActiveCell 1 row
        WS.Cells(cCell.Row + 1, 1).Select
        
    Next objMsg

Application.DisplayAlerts = True
Application.ScreenUpdating = True
DoEvents
MsgBox (lngCount & " Attachments were saved on C drive")


ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Exit Sub

ErrHandler:
X = MsgBox("This Routine will Exit due to following Error:" & Chr(10) & Chr(10) & Error(Err), vbCritical)
GoTo ExitSub


End Sub

 

Open in new window


3) SAVE and Exit the workbook
4) Try it

let me know
gowflow
0
 

Author Comment

by:JaseSt
ID: 39210869
thanks gowflow, will try it out. the csv format will not have a card number
0
 

Author Comment

by:JaseSt
ID: 39216166
just tried 4 orders, 3 with with csv formatted and 1 with xls formatted spreadsheets and unfortunately none of them imported the first and last name
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39216179
pls post them as it works fine here. post as .msg
gowflow
0
 

Author Comment

by:JaseSt
ID: 39216320
I'm posting a screenshot, scrubbed, of one of the csv files to see if this will show you something you need to see before I have to go thru the emails and scrub . Let me know if this will work or if you need the actual emails.
csv
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39216494
I need the mails.
gowflow
0
 

Author Comment

by:JaseSt
ID: 39217450
what is a personal email address I can these emails to?
0
 

Author Comment

by:JaseSt
ID: 39217596
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39218530
I have tried all of them and they worked perfectly fine. It seems you are messed up with the versions. Recopy the last sub I posteted above.
gowflow
0
 

Author Comment

by:JaseSt
ID: 39219353
deleted previous code and inserted the code above. closed and reopened. ran the code and got the errors posted. the error popped up after trying to process the email that had one of the above emails attached, which I attach again.

It imported the files correctly, but not the first and last name nor the 'not assigned yet' value before it choked.error1error2FW-Sovereign-Gold-Card---Order-4.msg
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39221283
Weired !!!! I tried it several times as you can see in the snapshot and it import fine and works fine.

ScreenShot
What version of Excel are you using maybe some other incompatibility !!! ???
gowflow
0
 

Author Comment

by:JaseSt
ID: 39222174
2010 - I'll try it again - have to step out for an hour
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39223548
I tried it on 2003 and 2007 and no problem. This was my fear so many incompatibilities on several levels in 2010. Give it an other try and let me know. I presently do not hv 2010 but just purchased it recently. If needed I will install it and check it out.

gowflow
0
 

Author Comment

by:JaseSt
ID: 39223675
just tried function again on another email, getting same error as above

  '---> Test to see if Valid File
                        If InStr(1, sFields(0), "First Name") <> 0 And InStr(1, sFields(1), "Last Name") <> 0 And InStr(1, sFields(7), "Email Address") <> 0 Then
                            Line Input #1, X
                            sFields = Split(X, ",")
0
 

Author Comment

by:JaseSt
ID: 39224448
12
0
 

Author Comment

by:JaseSt
ID: 39225892
got anything for me gowflow? or maybe I should go back to the earlier function
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39225941
Well did not install 2010 yet as seems its an issue with that. Do you hv 2007 or 2003 on ur pc ? if yes can you just test this file with one of the 2 versions and see if you still hv the same issue ?
gowflow
0
 

Author Comment

by:JaseSt
ID: 39225967
no, don't have those anymore. so what do you think of the error I'm getting? nothing can be done with that?
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39225985
I do not get this error !!!! this error means that we are executing a read after the end of file which is absurd as we open the file then make 1 read to read the header then when reading the next line we got that it is past end of file although we know that the file has 2 lines !!!!

Let me try something else here and will get back.
gowflow
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226042
I don't know if this will do it but we can try it its no harm. Do the folllowing:

1) open the file
2) goto vba
3) locate the sub SaveAttachements
4) locate this line:
Open strFile For Input As #1

5) comment it out (put a single quote just before the open so it become like this
'Open strFile For Input As #1

6) Paste the below line just after the previous one
Open strFile For Binary As #1

7) SAVE and Exit the workbook.
8) open it and try it and see if you still have the same error.

gowflow
0
 

Author Comment

by:JaseSt
ID: 39226171
well it worked for the xls file, even for an email that had two of them, but still same error with csv file
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226215
ok I will research the net ull hv to be patient. will revert. Tough when u don't get the error diffcult to reproduce it. Will revert.
gowflow
0
Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

 

Author Comment

by:JaseSt
ID: 39226227
do you want me to send my spreadsheet?
0
 

Author Comment

by:JaseSt
ID: 39226255
it is posted. as you can see I have 3 sheets in the workbook. not sure if that makes any difference.

Scrubbed-APPLICANT-STATUS-6-6-13.xls
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226346
doesn't make a diffrence. It still works here on your file. I am sure it is something with a caracter that is taking both lines in 1 reason why it is hitting end of file on the second read. But can't troubleshoot it with you as it need to make a stop in the code and get the value which is difficult to do remotly.

One last question the email you are trying to import is exactly the same as you have send me or you manipulated the one you send me earlier ??? as this may be the issue. I need the exact same email you are working on to see what is the problem.

gowflow
0
 

Author Comment

by:JaseSt
ID: 39226363
I will send you an unadulterated email with no alterations, but I have to send it your private email address. I can't post it here.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226372
try this

1) Make a new copy of the workbook giving it a new name
2) goto vba and delete SaveAttachements
3) Paste the below code after any End Sub

Public Sub SaveAttachments()
On Error GoTo ErrHandler

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim I As Long, J As Long, K As Long
Dim lngCount As Long
Dim LastRow As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim cCell As Range
Dim WS As Worksheet
Dim FileExt As String
Dim AttachRange As Range
Dim WB As Workbook
Dim WSAttach As Worksheet
Dim X, sFields
Dim ValidFile As Boolean
Dim sLine As String

    Set WS = ActiveSheet
        
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    'On Error Resume Next
 
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
 
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    'Set objSelection = objOL.GetNamespace("MAPI").Folders("CM Template")
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
 
    ' Set the Attachment folder to be this specific path as per Jaset request on Apr 29, 2013
    strFolderpath = strFolderpath & "\OLAttachments"
    'strFolderpath = "C:\Users\Michael\Sovereign Archives"
    
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
 
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
         
        '---> Choose the color of the row
        Set cCell = ActiveCell
        LastRow = cCell.Row + 1
        Do
            '---> Locate the cell color of the last row above the current one
            LastRow = LastRow - 1
            LastRow = WS.Range("A" & LastRow).End(xlUp).Row
            
        Loop Until WS.Range("A" & LastRow).Interior.Color <> 16777215 Or LastRow = 1
        
        '---> Color the new row based on the results
        If WS.Range("A" & LastRow).Interior.Color = 14545386 Then
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 10147522
        Else
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 14545386
        End If
         
        If lngCount > 0 Then
            ' Use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            K = 0
            For I = lngCount To 1 Step -1
             
                ' Get the file name.
                strFile = objAttachments.Item(I).Filename
                 
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & "\" & strFile
                 
                ' Save the attachment as a file.
                Application.DisplayAlerts = False
                
                On Error Resume Next
                Do
                    objAttachments.Item(I).SaveAsFile strFile
                    
                    If Err <> 0 Then
                        MkDir (Left(strFile, InStrRev(strFile, "\")))
                    Else
                        On Error GoTo 0
                    End If
                Loop Until Err = 0
                
                        
                '---> Insert data in coresponding cells
                Do Until WS.Cells(cCell.Row, K + 5) = ""
                    If K + 6 = 9 Then
                        '---> Copy Insert the new row and contine in Cell E
                        WS.Cells(cCell.Row, K + 5).EntireRow.Copy
                        WS.Cells(cCell.Row, K + 5).EntireRow.Insert
                        WS.Range("E" & cCell.Row & ":H" & cCell.Row).ClearContents
                        K = -1
                    End If
                    K = K + 1
                Loop
                WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
                WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
                
                WS.Range(WS.Cells(cCell.Row, K + 5), WS.Cells(cCell.Row, K + 5)).Formula = "=hyperlink(" & Chr(34) & strFile & Chr(34) & "," & Chr(34) & Right(strFile, Len(strFile) - InStrRev(strFile, "\")) & Chr(34) & ")"
                
                FileExt = LCase(Right(strFile, Len(strFile) - InStrRev(LCase(strFile), ".", Len(strFile))))
                
                '---> Check to See if Valid Excel File
                If InStr(1, FileExt, "xls") <> 0 Or InStr(1, FileExt, "xlsm") <> 0 Or InStr(1, FileExt, "xltx") <> 0 Or InStr(1, FileExt, "xlsx") <> 0 Then
                    '---> Open Workbook
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                    Set WB = Workbooks.Open(strFile)
                    Set WSAttach = WB.ActiveSheet
                                
                    '---> Test to see if Valid CC File
                    'If WSAttach.Range("P1") <> "" Then
                    If WSAttach.Range("A1") = "First Name" And WSAttach.Range("B1") = "Last Name" And WSAttach.Range("O1") = "Email Address" Then
                        '---> We are Dealing with Horizontal Spreadsheet
                        '     Assign Col A to Col C as First Name
                        '     Assign Col B to Col B as Last Name
                        WS.Range("C" & cCell.Row) = WSAttach.Range("A2")
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")

                        
                        '---> Depending on Value of Col P affect Col T
                        If WSAttach.Range("P1") = "Card Number" Then
                            WS.Range("T" & cCell.Row).NumberFormat = "Text"
                            WS.Range("T" & cCell.Row) = WSAttach.Range("P2")
                        Else
                            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        End If
                    Else
                        '---> We are Dealing with Vertical Spreadsheet
                        '     Assign B1 to Col C as First Name
                        '     Assign B2 to Col B as Last Name
                        '     Col T = 'Not Yet Assigned'
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        WS.Range("C" & cCell.Row) = WSAttach.Range("B1")
                        WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                    End If
                
                    '---> Close Workbook
                    WB.Close SaveChanges:=False
                    Set WSAttach = Nothing
                    Set WB = Nothing
        
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                
                Else
                
                    '---> Check to see if Valid .csv file
                    If InStr(1, FileExt, "csv") <> 0 Then
                        '---> Open Workbook
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
            
                        Open strFile For Input As #1
                        'Open strFile For Binary As #1
                        '---> Read the Header
                        Line Input #1, sLine
                        sFields = Split(sLine, ",")
                        
                        '---> Test to see if Valid File
                        If InStr(1, sFields(0), "First Name") <> 0 And InStr(1, sFields(1), "Last Name") <> 0 And InStr(1, sFields(7), "Email Address") <> 0 Then
                            Line Input #1, sLine
                            sFields = Split(sLine, ",")
                            
                            '---> Strip quotes prior affecting
                            X = ""
                            For J = 1 To Len(sFields(0))
                                If Mid(sFields(0), J, 1) <> Chr(34) Then
                                    X = X & Mid(sFields(0), J, 1)
                                End If
                            Next J
                            sFields(0) = X
                            
                            X = ""
                            For J = 1 To Len(sFields(1))
                                If Mid(sFields(1), J, 1) <> Chr(34) Then
                                    X = X & Mid(sFields(1), J, 1)
                                End If
                            Next J
                            sFields(1) = X
                            
                            WS.Range("C" & cCell.Row) = sFields(0)
                            WS.Range("B" & cCell.Row) = sFields(1)
                        End If
                        
                        '---> Close the File
                        Close #1
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
                    End If
                    
                End If
                
                
            Next I
            
            '---> Check after all Attachements if Still Col T Empty
            '     then update with Not Yet Assigned.
            '     to ensure Col T always Updated with value
            If WS.Range("T" & cCell.Row) = "" Then
                WS.Range("T" & cCell.Row) = "Not Yet Assigned"
            End If
            
        Else
            '---> Update Email, Date, CC Even if no attachements
            WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
            WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
        End If
        
        '---> Move ActiveCell 1 row
        WS.Cells(cCell.Row + 1, 1).Select
        
    Next objMsg

Application.DisplayAlerts = True
Application.ScreenUpdating = True
DoEvents
MsgBox (lngCount & " Attachments were saved on C drive")


ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Exit Sub

ErrHandler:
X = MsgBox("This Routine will Exit due to following Error:" & Chr(10) & Chr(10) & Error(Err), vbCritical)
GoTo ExitSub


End Sub

 

Open in new window


4) SAVE and Exit the workbook
5) Open it and try it.

gowflow
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226376
no do not send to private email please will work at it
gowflow
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226385
Then you are confirming that you altered the csv ??? if yes please tell me you opened it in Excel then removed the sensitive data then closed it again and attached it to the email ? Is that what you did ????
gowflow
0
 

Author Comment

by:JaseSt
ID: 39226393
yes, I had to take out sensitive info in the versions I sent you, but I tried to just alter the names and numbers, but I did that to all of them I sent. and yes, I had to save the csv to my computer and then reattach and resend to myself then post it here
0
 

Author Comment

by:JaseSt
ID: 39226394
let me do this. I'll create an order myself so that it has my bogus data and then forward the email to you directly without changing anything. will that do?
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226396
ok fine and all changes were done in the Excel right like when you doubleclicked on the file it opened it in Excel and this is where you made your changes and saved it back to csv right ???
gowflow
0
 

Author Comment

by:JaseSt
ID: 39226426
right - all done in excel

I will send you an untouched email soon
0
 

Author Comment

by:JaseSt
ID: 39226431
tried new code, get same error right away with csv file
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226436
DO NOT SEND ON MY PRIVATE MAIL !!!!! PLEASE
gowflow
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226443
please confirm you will not send to my mail so I continue with the troubleshoting steps or else I will stop assistance rightaway.
gowflow
0
 

Author Comment

by:JaseSt
ID: 39226444
will not do. I'll just post it here.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226447
no need. I will give you following steps to do
gowflow
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226477
First open your file and goto vba and display the Saveattachments sub and goto the line in the below picture that is in brown and click on that line and then press F9 it will turn brown

F9
Then goback to your worksheet and make sure the culprit email is highlighted in outlook and then click on the button Save Links.

The program will stop at this line and it will turn yellow thats ok. Now as you can see in the following picture under the code there is a window called Immediate window if it is not displayed like in the attached picture then go on the View Menu and choose Immediate Window and it will be displayed. Type what ever you see in the picture
? sLine
then press enter
it is supposed to display the first line of the file. Please look at the data and see if it is the first line or both lines ???

? sLine
Now again look at the below picture you will see an other instruction I need you to revert with the results
?instr(1,sLine,Chr(13))
then press Enter

do you get 0 ? do you get and other figure what is it ?

?instr(1,sLine,Chr(13))

Will wait for your answers.
gowflow
0
 

Author Comment

by:JaseSt
ID: 39226514
first command: 2 lines, both lines
second command: 0
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226546
thought so !!!! and this is the problem and reason why you get past end of file as when it hits the next Line Input you are already at the end of the file.

OK I need the following now

your yellow line is still at the instruction
sFields = Split(sLine, ",")

I want you to try this instruction
?instr(1,sLine,chr(10))

and tell me what you get ?
gowflow
0
 

Author Comment

by:JaseSt
ID: 39226572
comes back: 212
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226617
mmmm GREAT !!!!

now try your end
?mid(sLine,1,212)

it should give you the header

then
?mid(sLine,212,Len(sLine)-212))

it should give you the data or the second line (+/- 1 character or so but roughly this)

pls advise
gowflow
0
 

Author Comment

by:JaseSt
ID: 39226638
?mid(sLine,1,212)  gives me the header

?mid(sLine,212,Len(sLine)-212)) gives me  "compile error: Expected: expression"
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39226716
ok then try

?Len(sLine)

gowflow
0
 

Author Comment

by:JaseSt
ID: 39226723
get: 393
0
 

Author Comment

by:JaseSt
ID: 39226775
Sovereign-Gold-Card---Order-485-.msg

attached is an original email unaltered. don't know if it will help
0
 
LVL 29

Accepted Solution

by:
gowflow earned 500 total points
ID: 39226960
ok try this code, it should work wether you have an csv original or a csv that you have manipulated thru excel.

1) Make a copy of your latest file and give it a new name.
2) goto vba and delete the sub SaveAttachements
3) Paste the below code after any End Sub

Public Sub SaveAttachments()
On Error GoTo ErrHandler

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim I As Long, J As Long, K As Long, L As Long, lTo As Long
Dim lngCount As Long
Dim LastRow As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim cCell As Range
Dim WS As Worksheet
Dim FileExt As String
Dim AttachRange As Range
Dim WB As Workbook
Dim WSAttach As Worksheet
Dim X, sFields, sLine
Dim ValidFile As Boolean
Dim sFile As String

    Set WS = ActiveSheet
        
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    'On Error Resume Next
 
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
 
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    'Set objSelection = objOL.GetNamespace("MAPI").Folders("CM Template")
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
 
    ' Set the Attachment folder to be this specific path as per Jaset request on Apr 29, 2013
    strFolderpath = strFolderpath & "\OLAttachments"
    'strFolderpath = "C:\Users\Michael\Sovereign Archives"
    
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
 
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
         
        '---> Choose the color of the row
        Set cCell = ActiveCell
        LastRow = cCell.Row + 1
        Do
            '---> Locate the cell color of the last row above the current one
            LastRow = LastRow - 1
            LastRow = WS.Range("A" & LastRow).End(xlUp).Row
            
        Loop Until WS.Range("A" & LastRow).Interior.Color <> 16777215 Or LastRow = 1
        
        '---> Color the new row based on the results
        If WS.Range("A" & LastRow).Interior.Color = 14545386 Then
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 10147522
        Else
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 14545386
        End If
         
        If lngCount > 0 Then
            ' Use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            K = 0
            For I = lngCount To 1 Step -1
             
                ' Get the file name.
                strFile = objAttachments.Item(I).Filename
                 
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & "\" & strFile
                 
                ' Save the attachment as a file.
                Application.DisplayAlerts = False
                
                On Error Resume Next
                Do
                    objAttachments.Item(I).SaveAsFile strFile
                    
                    If Err <> 0 Then
                        MkDir (Left(strFile, InStrRev(strFile, "\")))
                    Else
                        On Error GoTo 0
                    End If
                Loop Until Err = 0
                
                        
                '---> Insert data in coresponding cells
                Do Until WS.Cells(cCell.Row, K + 5) = ""
                    If K + 6 = 9 Then
                        '---> Copy Insert the new row and contine in Cell E
                        WS.Cells(cCell.Row, K + 5).EntireRow.Copy
                        WS.Cells(cCell.Row, K + 5).EntireRow.Insert
                        WS.Range("E" & cCell.Row & ":H" & cCell.Row).ClearContents
                        K = -1
                    End If
                    K = K + 1
                Loop
                WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
                WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
                
                WS.Range(WS.Cells(cCell.Row, K + 5), WS.Cells(cCell.Row, K + 5)).Formula = "=hyperlink(" & Chr(34) & strFile & Chr(34) & "," & Chr(34) & Right(strFile, Len(strFile) - InStrRev(strFile, "\")) & Chr(34) & ")"
                
                FileExt = LCase(Right(strFile, Len(strFile) - InStrRev(LCase(strFile), ".", Len(strFile))))
                
                '---> Check to See if Valid Excel File
                If InStr(1, FileExt, "xls") <> 0 Or InStr(1, FileExt, "xlsm") <> 0 Or InStr(1, FileExt, "xltx") <> 0 Or InStr(1, FileExt, "xlsx") <> 0 Then
                    '---> Open Workbook
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                    Set WB = Workbooks.Open(strFile)
                    Set WSAttach = WB.ActiveSheet
                                
                    '---> Test to see if Valid CC File
                    'If WSAttach.Range("P1") <> "" Then
                    If WSAttach.Range("A1") = "First Name" And WSAttach.Range("B1") = "Last Name" And WSAttach.Range("O1") = "Email Address" Then
                        '---> We are Dealing with Horizontal Spreadsheet
                        '     Assign Col A to Col C as First Name
                        '     Assign Col B to Col B as Last Name
                        WS.Range("C" & cCell.Row) = WSAttach.Range("A2")
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")

                        
                        '---> Depending on Value of Col P affect Col T
                        If WSAttach.Range("P1") = "Card Number" Then
                            WS.Range("T" & cCell.Row).NumberFormat = "Text"
                            WS.Range("T" & cCell.Row) = WSAttach.Range("P2")
                        Else
                            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        End If
                    Else
                        '---> We are Dealing with Vertical Spreadsheet
                        '     Assign B1 to Col C as First Name
                        '     Assign B2 to Col B as Last Name
                        '     Col T = 'Not Yet Assigned'
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        WS.Range("C" & cCell.Row) = WSAttach.Range("B1")
                        WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                    End If
                
                    '---> Close Workbook
                    WB.Close SaveChanges:=False
                    Set WSAttach = Nothing
                    Set WB = Nothing
        
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                
                Else
                
                    '---> Check to see if Valid .csv file
                    If InStr(1, FileExt, "csv") <> 0 Then
                        '---> Open Workbook
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
            
                        Open strFile For Input As #1
                        
                        '---> Read the Header
                        Do While Not EOF(1)
                            Line Input #1, sFile
                            
                            '---> Split the File by Line
                            sLine = Split(sFile, Chr(10))
                            
                            If UBound(sLine) = 0 Then
                                lTo = 0
                            Else
                                lTo = 1
                            End If
                            For L = 0 To UBound(sLine) - lTo
                                sFields = Split(sLine(L), ",")
                                
                                '---> Test to see if Valid File
                                If L = 0 And InStr(1, sFields(0), "First Name") <> 0 And InStr(1, sFields(1), "Last Name") <> 0 And InStr(1, sFields(7), "Email Address") <> 0 Then
                                    
                                Else
                                    'Line Input #1, sLine
                                    sFields = Split(sLine(L), ",")
                                    
                                    '---> Strip quotes prior affecting
                                    X = ""
                                    For J = 1 To Len(sFields(0))
                                        If Mid(sFields(0), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(0), J, 1)
                                        End If
                                    Next J
                                    sFields(0) = X
                                    
                                    X = ""
                                    For J = 1 To Len(sFields(1))
                                        If Mid(sFields(1), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(1), J, 1)
                                        End If
                                    Next J
                                    sFields(1) = X
                                    
                                    WS.Range("C" & cCell.Row) = sFields(0)
                                    WS.Range("B" & cCell.Row) = sFields(1)
                                End If
                                
                            Next L
                        Loop
                        
                        '---> Close the File
                        Close #1
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
                    End If
                    
                End If
                
                
            Next I
            
            '---> Check after all Attachements if Still Col T Empty
            '     then update with Not Yet Assigned.
            '     to ensure Col T always Updated with value
            If WS.Range("T" & cCell.Row) = "" Then
                WS.Range("T" & cCell.Row) = "Not Yet Assigned"
            End If
            
        Else
            '---> Update Email, Date, CC Even if no attachements
            WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
            WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
        End If
        
        '---> Move ActiveCell 1 row
        WS.Cells(cCell.Row + 1, 1).Select
        
    Next objMsg

Application.DisplayAlerts = True
Application.ScreenUpdating = True
DoEvents
MsgBox (lngCount & " Attachments were saved on C drive")


ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Exit Sub

ErrHandler:
X = MsgBox("This Routine will Exit due to following Error:" & Chr(10) & Chr(10) & Error(Err), vbCritical)
GoTo ExitSub


End Sub

 

Open in new window


4) SAVE and Exit the workbook
5) Open it and try it out in both scenarios.

gowflow
0
 

Author Closing Comment

by:JaseSt
ID: 39227073
Victory!!!

It now works on csv and xls files!

You worked for this one! Thank you.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 39228182
Welcome and tks. Pls feel free to post and other issue you may need help with in here.
gowflow
0
 

Author Comment

by:JaseSt
ID: 39229321
thank you, gowflow. I really appreciate the help. The next one is going further with the Applicant Status sheet

It is here:

http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28150848.html

Thanks again, gowflow.
0

Featured Post

How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

Join & Write a Comment

This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

757 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

Need Help in Real-Time?

Connect with top rated Experts

22 Experts available now in Live!

Get 1:1 Help Now