Outlook vba match a pattern when attchement is found

[hartyshow]

I'm trying to match a pattern when a spreadsheet attachment is found in outlook. I can trigger the process for a spreadsheet attachment but don't know how to invoke the search through the attachment.

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    saveFolder = "C:\form"

     For Each objAtt In itm.Attachments
     
          
     If InStr(objAtt.DisplayName, ".xls") Then

        
          objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
          
          
          Set objAtt = Nothing
        End If
          
          
          
     Next
     End Sub

thanks for your help

 

[hartyshow]

Sorry! ahhh! I see now, I understand, I never thought about finding a pattern but base on what you are asking I think we can locate a pattern in sheet 2, line D1.
the majority of them have Olus in sheet2 in line D1

 

[ZVI]

...the majority of them have Olus in sheet2 in line D1

Well, the below code saves the XLS attachment, open it in Excel and looks for the word "Olus" as a part of any cells in Sheet2.
If word is not found then the code deletes that attachment from the folder.

Public Sub saveAttachToDisk(itm As Outlook.MailItem)
 
  ' --> Settings. change to suit
  Const MASK = "Olus"       ' Value to be found
  Const SHEET = "Sheet2"    ' Sheet name or its index where to find
  ' <--
 
  ' Excel constants
  Const xlValues = -4163, xlWhole = 1, xlPart = 2
 
  ' Variables
  Dim objExcel As Object, IsNew As Boolean, x As Object
  Dim objAtt As Outlook.Attachment
  Dim saveFolder As String, sFileName As String, sPathName As String
  saveFolder = "C:\form"
 
  If Not TypeName(itm) = "MailItem" Then Exit Sub
  If Dir(saveFolder, vbDirectory) = "" Then MkDir saveFolder
 
  ' Get/Create Excel object
  On Error Resume Next
  Set objExcel = GetObject(, "Excel.Application")
  If Err Then
    Err.Clear
    IsNew = True
    Set objExcel = CreateObject("Excel.Application")
  End If
  objExcel.FindFormat.Clear
 
  ' Main
  For Each objAtt In itm.Attachments
    sFileName = LCase(objAtt.Filename)
    If sFileName Like "*.xls" Or sFileName Like "*.xls?" Then
      sPathName = saveFolder & "\" & sFileName
      objAtt.SaveAsFile sPathName
      With objExcel.Workbooks.Open(sPathName, ReadOnly:=True)
        Set x = .Sheets(SHEET).UsedRange.Find(MASK, LookIn:=xlValues, LookAt:=xlPart)
        If x Is Nothing Then Kill sPathName Else Set x = Nothing
        .Close False
      End With
    End If
  Next
 
  If IsNew Then objExcel.Quit
 
End Sub

 

[hartyshow]

thanks for the reply, I did try the code this time it does save the file but, doesn't match the regex and then after 30s the .xls file is removed from the folder. I did try that with 2 differents .xls one with the regex and one without. Both files got saved but after 30s they get removed.

 

[ZVI]

thanks for the reply, I did try the code this time it does save the file but, doesn't match the regex and then after 30s the .xls file is removed from the folder. I did try that with 2 differents .xls one with the regex and one without. Both files got saved but after 30s they get removed.

Please check that the sheet named as "Sheet2" is present in the attachments.
And the word "Olus" is in any cells of that sheet.
If both conditions meet the attachment is not deleted from the folder.
The sheet name and the searching word is configured in the constants on the top of the code.
The code does not check that the file is already present in the folder.
As a result if the attachment has the same name as already present and conditions are not meet the file will be deleted from the folder. Adding the date-time stamp to the file name will skip such a problem.

 

[ZVI]

This version of the code adds unique date-time stamp to the file name to prevent overwriting files with the same names.

Public Sub SaveAttachToDisk(itm As Outlook.MailItem)
 
  ' --> Settings, change to suit
  Const MASK = "Olus"       ' Value to be found
  Const SHEET = "Sheet2"    ' Sheet name or its index where to find, Use SHEET = 2 for the 2nd sheet index.
  ' <--
 
  ' Excel constants
  Const xlValues = -4163, xlWhole = 1, xlPart = 2
 
  ' Variables
  Dim objExcel As Object, i As Long, IsNew As Boolean, x As Object
  Dim objAtt As Outlook.Attachment
  Dim saveFolder As String, sFileName As String, sPathName As String
  saveFolder = "C:\form"
 
  If Not TypeName(itm) = "MailItem" Then Exit Sub
  If Dir(saveFolder, vbDirectory) = "" Then MkDir saveFolder
 
  ' Get/Create Excel object
  On Error Resume Next
  Set objExcel = GetObject(, "Excel.Application")
  If Err Then
    Err.Clear
    IsNew = True
    Set objExcel = CreateObject("Excel.Application")
  End If
  objExcel.FindFormat.Clear
 
  ' Main
  For Each objAtt In itm.Attachments
    sFileName = LCase(objAtt.Filename)
    i = InStrRev(sFileName, ".xls", Compare:=vbTextCompare)
    If i >= Len(sFileName) - 4 Then
      sFileName = Left(sFileName, i - 1) & "(" & Format(Now, "yymmdd_hhmmss") & ")" & Mid(sFileName, i)
      sPathName = saveFolder & "\" & sFileName
      objAtt.SaveAsFile sPathName
      With objExcel.Workbooks.Open(sPathName, ReadOnly:=True)
        Set x = .Sheets(SHEET).UsedRange.Find(MASK, LookIn:=xlValues, LookAt:=xlPart)
        If x Is Nothing Then Kill sPathName Else Set x = Nothing
        .Close False
      End With
    End If
  Next
 
  If IsNew Then objExcel.Quit
 
End Sub
 
Sub Test()
  ' Open the mail item with xls attachment(s) and run this code. Press F8 for step by step debugging
  SaveAttachToDisk Application.ActiveInspector.CurrentItem
End Sub

I have tested all the posted code and it works as described, but not sure it works as required

 

[hartyshow]

works like a charm, thanks a lot ZVI

will you be up for a second challenge?

 

[hartyshow]

when the regex is found the program will convert the attachment file in a .csv

if WScript.Arguments.Count < 2 Then
    WScript.Echo "Error! Please specify the source path and the destination. Usage: XlsToCsv SourcePath.xls Destination.csv"
    Wscript.Quit
End If
Dim oExcel
Set oExcel = CreateObject("Excel.Application")
Dim oBook
Set oBook = oExcel.Workbooks.Open(Wscript.Arguments.Item(0))
oBook.SaveAs WScript.Arguments.Item(1), 6
oBook.Close False
oExcel.Quit
WScript.Echo "Done"

the problem is the above code takes two arguments Usage: XlsToCsv SourcePath.xls Destination.csv

any idea how to incorporate that in the code

 

[ZVI]

works like a charm, thanks a lot ZVI

Glad you have got the solution

when the regex is found ...

Actually it's not regex, it's pattern - follow the link in the post #7 to learn correct naming. BTW, the RegEx object is not used in any code of this thread.

... the program will convert the attachment file in a .csv

For saving XLS attachments as CSV use this version of the code:

Public Sub SaveAttachToDisk(itm As Outlook.MailItem)
'ZVI:2017-03-18 https://www.mrexcel.com/forum/excel-questions/996456-outlook-visual-basic-applications-match-pattern-when-attchement-found.html#post4781965
 
  ' --> Settings, change to suit
  Const MASK = "Olus"       ' Value to be found (pattern)
  Const SHEET = "Sheet2"    ' Sheet name or its index where to find, Use SHEET = 2 for the 2nd sheet index.
  Const FOLDER = "C:\Form"  ' Folder for saving XLS attachments
  ' <--
 
  ' Excel constants
  Const xlValues = -4163, xlWhole = 1, xlPart = 2, xlCSV = 6
 
  ' Variables
  Static objExcel As Object
  Dim x As Object, objAtt As Outlook.Attachment
  Dim sFileName As String, sPathName As String, sExt As String, sFld As String
  Dim i As Long, j As Long
 
  ' Some checkings
  If Not TypeName(itm) = "MailItem" Then Exit Sub
  If Right(FOLDER, 1) = "\" Then sFld = FOLDER Else sFld = FOLDER & "\"
  If Dir(sFld, vbDirectory) = "" Then MkDir sFld
 
  ' Get/Create Excel object
  On Error Resume Next
  Set objExcel = GetObject(, "Excel.Application")
  If Err Then
    Err.Clear
    Set objExcel = CreateObject("Excel.Application")
  End If
  On Error GoTo 0
  objExcel.FindFormat.Clear
 
  ' Main
  For Each objAtt In itm.Attachments
    j = 0
    sFileName = LCase(objAtt.Filename)
    i = InStrRev(sFileName, ".xls", Compare:=vbTextCompare)
    If i >= Len(sFileName) - 4 Then
      sExt = Mid(sFileName, i)
      sPathName = sFld & "tmp" & sExt
      objAtt.SaveAsFile sPathName
      With objExcel.Workbooks.Open(sPathName, ReadOnly:=True)
        Set x = .Sheets(SHEET).UsedRange.Find(MASK, LookIn:=xlValues, LookAt:=xlPart)
        If Not x Is Nothing Then
          j = 0
          sFileName = Left(sFileName, i - 1) & "(" & Format(Now, "yymmdd_hhmmss")
          sPathName = sFld & sFileName & ").csv"
          While Dir(sPathName) <> ""
            j = j + 1
            sPathName = sFld & sFileName & "-" & j & ").csv"
          Wend
          .SaveAs sPathName, xlCSV
          Set x = Nothing
        End If
        .Close False
        Kill sFld & "tmp" & sExt
      End With
    End If
  Next
 
End Sub
 
Sub Test()
  ' Open the mail item with xls attachment(s) and run this code. Press F8 for step by step debugging
  SaveAttachToDisk Application.ActiveInspector.CurrentItem
End Sub

 

[hartyshow]

thanks for the clarification, Kudos to you the code works well, the only issue is since the pattern match file is in a different format .csv than the rest of the spreadsheet .xls. we can actually keep all spreadsheets, so no need to kill or remove if the file doesn't match the pattern.

I tried to meet that criteria so we can have .xls file where Olus is not found and .csv file where Olus is found but things didn't work well for me.

any ideas how to remove your kill switch for .xls files that don't match the pattern without compromising the code.

thanks

 

[ZVI]

... any ideas how to remove your kill switch for .xls files that don't match the pattern...

Describing of all those requirements for the first time would reduce the amount of iterations
Well, here is the code:

Public Sub SaveAttachToDisk(itm As Outlook.MailItem)
'ZVI:2017-03-19 https://www.mrexcel.com/forum/general-excel-discussion-other-questions/996456-outlook-visual-basic-applications-match-pattern-when-attchement-found.html#post4782061
 
  ' --> Settings, change to suit
  Const MASK = "Olus"       ' Value to be found (pattern)
  Const SHEET = "Sheet2"    ' Sheet name or its index where to find, Use SHEET = 2 for the 2nd sheet index.
  Const FOLDER = "C:\Form"  ' Folder for saving XLS attachments
  ' <--
 
  ' Excel constants
  Const xlValues = -4163, xlWhole = 1, xlPart = 2, xlCSV = 6
 
  ' Variables
  Static objExcel As Object
  Dim x As Object, objAtt As Outlook.Attachment
  Dim sFileName As String, sPathName As String, sExt As String, sFld As String
  Dim i As Long, j As Long
 
  ' Some checkings
  If Not TypeName(itm) = "MailItem" Then Exit Sub
  If Right(FOLDER, 1) = "\" Then sFld = FOLDER Else sFld = FOLDER & "\"
  If Dir(sFld, vbDirectory) = "" Then MkDir sFld
 
  ' Get/Create Excel object
  On Error Resume Next
  Set objExcel = GetObject(, "Excel.Application")
  If Err Then
    Err.Clear
    Set objExcel = CreateObject("Excel.Application")
  End If
  objExcel.FindFormat.Clear
 
  ' Main
  For Each objAtt In itm.Attachments
    j = 0
    sFileName = LCase(objAtt.Filename)
    i = InStrRev(sFileName, ".xls", Compare:=vbTextCompare)
    If i >= Len(sFileName) - 4 Then
      sExt = Mid(sFileName, i)
      sFileName = Left(sFileName, i - 1) & "(" & Format(Now, "yymmdd_hhmmss")
      sPathName = sFld & sFileName & ").*"
      While Dir(sPathName) <> ""
        j = j + 1
        sPathName = sFld & sFileName & "-" & j & ").*"
      Wend
      If j > 0 Then sFileName = sFileName & "-" & j
      sPathName = sFld & sFileName & ")" & sExt
      objAtt.SaveAsFile sPathName
      With objExcel.Workbooks.Open(sPathName, ReadOnly:=True)
        Set x = .Sheets(SHEET).UsedRange.Find(MASK, LookIn:=xlValues, LookAt:=xlPart)
        If x Is Nothing Then
          .Close False
        Else
          .SaveAs sFld & sFileName & ").csv", xlCSV
          .Close False
          Kill sPathName
          Set x = Nothing
        End If
      End With
    End If
  Next
 
End Sub
 
Sub Test()
  ' Open the mail item with xls attachment(s) and run this code. Press F8 for step by step debugging
  SaveAttachToDisk Application.ActiveInspector.CurrentItem
End Sub