![]() |
#10
|
||||
|
||||
![]()
It can't work from a rule if you run the code from Excel. However let's start again as there is a potential issue with the earlier code, which causes the master file not to be created under some circumstances and the error handler scraps the process.
The following has been tested and does work, either from a rule that processes incoming messages, or you can run ProcessCSVFiles on a Windows folder full of files. I have checked and both processes with create the master file if it doesn't exist and should only add the header from the first attachment when the master is created. Replace all the original code with the following, in an ordinary module. Change the name of the script that the rule uses to match the change. When processing from a rule, the macro creates a temporary file from the attachment to process. It doesn't save the attachment. Code:
Option Explicit Const strMasterPath As String = "\\fngn.com\us\Projects\Print Production\Reports\Master.csv" 'The full name of the master csv Const strPath As String = "\\fngn.com\us\Projects\Print Production\Reports\DSG Drop reports\" Sub CSVAttachment(olItem As Outlook.MailItem) 'Graham Mayor - www.gmayor.com Dim strTempPath As String Dim strFileName As String Dim olAtt As Attachment Dim lngCount As Long Dim bAttached As Boolean strTempPath = Environ("Temp") & Chr(92) lngCount = 0 On Error GoTo err_handler If olItem.Attachments.Count > 0 Then For Each olAtt In olItem.Attachments If Right(olAtt.FileName, 4) = ".csv" Then bAttached = True If FileExists(strMasterPath) Then lngCount = lngCount + 1 strFileName = strTempPath & olAtt.FileName olAtt.SaveAsFile strFileName Exit For End If Next olAtt End If If lngCount = 1 Then GetCSVData strFileName Else GetCSVData strFileName, True End If If bAttached Then Kill strFileName 'Delete the temporary file lbl_Exit: Exit Sub err_handler: Err.Clear GoTo lbl_Exit End Sub Sub ProcessCSVFiles() 'Graham Mayor - www.gmayor.com 'The lngCount variable is used to determine whether to add the header row to the master file Dim strFile As String Dim lngCount As Long lngCount = 0 If FileExists(strMasterPath) Then lngCount = lngCount + 1 strFile = Dir$(strPath & "*.csv") While strFile <> "" lngCount = lngCount + 1 If lngCount = 1 Then GetCSVData strPath & strFile, True Else GetCSVData strPath & strFile End If DoEvents strFile = Dir$() Wend MsgBox "Finished" lbl_Exit: Exit Sub End Sub Sub GetCSVData(sfName As String, Optional bHeader As Boolean = False) 'Graham Mayor - www.gmayor.com 'If bHeader = true then write the header row 'The header row is a row that contains the text "Job No" Dim sTextRow As String Dim iFileNo As Integer iFileNo = FreeFile Open sfName For Input As #iFileNo Do While Not EOF(iFileNo) Line Input #iFileNo, sTextRow If bHeader Then AddToMaster sTextRow Else If InStr(1, sTextRow, "Job No") = 0 Then AddToMaster sTextRow End If End If Loop Close #iFileNo lbl_Exit: Exit Sub End Sub Sub AddToMaster(strLine As String) 'Graham Mayor - www.gmayor.com 'strline is the line of text to be added Dim oFSO As Object Dim oFile As Object Set oFSO = CreateObject("Scripting.FileSystemObject") Set oFile = oFSO.OpenTextFile(strMasterPath, 8, True, 0) oFile.Write strLine & vbCrLf oFile.Close lbl_Exit: Set oFSO = Nothing Set oFile = Nothing Exit Sub End Sub Private Function FileExists(strFullName As String) As Boolean 'Graham Mayor - www.gmayor.com 'strFullName is the name with path of the file to check Dim oFSO As Object Set oFSO = CreateObject("Scripting.FileSystemObject") If oFSO.FileExists(strFullName) Then FileExists = True Else FileExists = False End If lbl_Exit: Set oFSO = Nothing Exit Function End Function
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
aaronbauer1980 | Excel Programming | 1 | 04-15-2016 05:53 PM |
![]() |
gbaker | Excel Programming | 2 | 04-08-2016 08:44 AM |
![]() |
sidbisk | Excel | 2 | 09-01-2015 02:11 PM |
![]() |
spiderman1369 | Word VBA | 2 | 10-15-2014 08:30 AM |
Can't Copy and Paste until new message is open | tabletop | Outlook | 0 | 12-04-2009 11:38 AM |