How to use regexp and arrays to match groups or sets of 3 individual patterns?

[jbaich]

Sorry if this get's duplicated, tried to post, but wasn't logged in and then auto redirect didn't go anywhere, so went back and trying again...

Hey all, I'm new to Reg exp and I'm going to try to use it in Outlook... I know this is an Excel forum, but there are so many super smart and helpful people here I figured it might be worth asking.

I'm trying to match patterns, which occur in sets of 3. I have posted this question on another forum as well, where i was originally introduced to the Reg Exp function https://forums.slipstick.com/threads/95172-is-this-possible-to-do-with-a-macro/#post-347604, but with the holiday season, i'm not sure if I should be expecting a response in the short term and the usefulness of this macro (if I can get it to work) is increasing exponentially by the day, so I'd really love to figure something out in a hurry

So what I'm thinking is as follows, please correct me if I'm wrong:

example:
Pattern 1 = date
Pattern 2 = time
pattern 3 = postal code

The 3 individual patterns are SubMatches and together they would be a MatchCollection... right? Except instead of finding all the pattern 1 collections, all the pattern 2 collections and all the pattern 3 collections, I need to find all the pattern (1,2,3) collections... and store them for use later so i also need to create variables for them as they are identified... ie: collection 1, collection 2, collection 3... etc.

So I'm trying to figure out how to loop through and find all of the MatchCollections (1,2,3,) in my document... not sure how many there may be. I was thinking I could run a count of all the pattern 1 matches, which should give me the number of collections I'll need and then do an if loop for i = 1 to count... but I'm not sure how to group them... I've tried working with Case statements, but can only get as far as;

1. Having to create duplicate statements for each estimated recurrence (for example 3 match collections would require case 1-9 statements)... is there a way to just have the 3 case statements and then repeat the loop?

2. If I set Global=True, I will get all of the matches, grouped together as (1,1,1),(2,2,2),(3,3,3), however what I need to get is (1,2,3),(1,2,3),(1,2,3)

I'm guessing i need to incorporate arrays here somehow, but I've never really used arrays in VBA before and so far haven't been able to figure out what I need to do. Something like

[LIST]
[*]<article>[INDENT]Dim arr
 arr = Array("Collection 1","Collection 2","Collection 3")

[/INDENT]
</article>
[/LIST]

My code at this point is simply a patchwork of random failed attempts and commented out bits and pieces that may or may not be on the right track. As I said, new to both Reg and Arrays in VBA, so i think posting it might be more confusing than helpful, but if you think that would help, let me know and I will.

Any help would be very much appreciated! Also, i don't know the etiquette for cross posting, I know it's not the best and should be avoided to prevent duplication of effort, is this what Trackback is for? I'm guessing yes, so I've put the URL of the site I mentioned above in the trackback field here and hopefully that helps... I will also let Diane know over on Slipstick that I've asked this question here as well.

Thanks,
Joe

 

[Domenic]

Ok, it almost all works except for now the sub Copy seems to be doing something weird...

Unfortunately, I'm not familiar with that part of the code. I suggest that you start a new thread and ask your question there. Otherwise, not many will see your question here.

 

[jbaich]

ok resolved the clipboard issue... found out how to reference my forms library and changed the Copy sub to

Public Sub Copy()    
    Dim clipboard As MSForms.DataObject


    Set clipboard = New MSForms.DataObject
    
    clipboard.SetText strInList
    clipboard.PutInClipboard
    msgbox ("The InList has been copied to your clipboard. Please paste into the propid field to generate RS")
    
End Sub

Everything seems to be working now only two small things left that I'd like to figure out...

1. If the user cancels the folder browser, how can I put some error handling or pass that response to the main sub so it doesn't try to continue with the next line (MkDir) of the savemessages sub? Should I use On Error resume next at this point and/or after the MkDir in the even a folder with that name already exists?

Public Sub SaveMessageAsMsg()  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim sName As String
  
    Pick
[U][B]'''need some error handling in here if the user cancels out of the file picker?

[/B][/U]
MkDir (strNewFolderPath & "\" & FileRef)
[U][B]
'''On error resume next?'''[/B][/U]

2. I've only ever really used macro's in Excel, but it seems to me the security with outlook is a bit different... any clue about the easiest way to share this with colleagues? I've done the self cert, but it says it will only apply on the machine that it was created so would everyone i share this with need to make their own self cert? I realize this is a rather outlook specific question, but I figured it might be worth a shot to ask

Thanks Joe

 

[jbaich]

sorry, didn't see your last reply before i hit post on my last post...

 

[Domenic]

If you're using your original BrowseForFolder function...

    If strFolderpath = False Then Exit Sub

If you're using the one I gave you, I've already provided you with an example that will test whether the user cancelled, made an invalid selection, or selected a valid folder.

 

[jbaich]

I am using a bit of a hybrid (str instead of var), but with the user input code you provided. I'm not sure if this is a good way to do it, but here's what I came up with that seems to work... please let me know if you see a flaw in this plan

If it's cancelled or invalid, I've set the strNewFolderPath variable to "Exit"... which is passed back to SaveMessageAs sub

Sub Pick()    Dim answer                      As Integer


strFolderPath = "C:\Users\joe\Pictures\"
BrowseForFolder (strFolderPath)


If Len(strNewFolderPath) = 0 Then
        msgbox "User cancelled...", vbInformation 'optional
[B]    strNewFolderPath = "Exit"[/B]
    
    ElseIf strNewFolderPath = "False" Then
        msgbox "Invalid selection...", vbInformation
[B]    strNewFolderPath = "Exit"[/B]
    
    Else
    answer = msgbox("A copy of this message will be saved in a new folder that will be created in: " & strNewFolderPath & "\", vbOKCancel)
[B]    If answer = vbCancel Then[/B]
[B]    strNewFolderPath = "Exit"[/B]
End If
    End If
End Sub

Then, when it starts back in the savemessageas sub, i added this bit....

    Pick
    
[B]If strNewFolderPath = "Exit" Then     ''' This is the next line after the Pick sub is done...[/B]
[B]Exit Sub[/B]
[B]End If[/B]


MkDir (strNewFolderPath & "\" & FileRef)
On Error Resume Next

I think it will work

Thanks so much for all your help!

 

[Domenic]

I think it would help if you posted the complete code...

 

[jbaich]

ok, here's the whole thing...

Public strSubject As String, strFolderPath As String, strNewFolderPath As String, FileRef As String, strInList As StringPublic olMail As Object
Option Explicit
'For this Macro you will need to turn on the Microsoft Forms 2.0 Object Library as well as the Microsoft VBScript Regular Expressions 5.5 library


Sub MsgChecker()


    'Outlook variables
    Dim olApp                       As Object
    'Dim olMail                      As Object


    'VBScript variables
    Dim oRegExp                     As Object
    Dim oMatchCollection            As Object
    Dim oSubMatches                 As Object
    Dim oMatch                      As Object
        
    'Excel variables
    Dim oCol                        As New Collection
    Dim sPattern                    As String
    Dim testSubject                 As String
    Dim answer                      As Integer


    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.ActiveExplorer.Selection.Item(1)
    
    sPattern = "Area[:]\s*\r\n(\d*)\s*\r\nJurisdiction[:]\s*\r\n(\d*)\s*\r\nRoll Number[:]\s*\r\n(\w*)"


    Set oRegExp = CreateObject("VBScript.RegExp")
    
    With oRegExp
        .Global = True
        .IgnoreCase = True
        .Pattern = sPattern
        Set oMatchCollection = .Execute(olMail.Body)
    End With
    
    For Each oMatch In oMatchCollection
        oCol.Add oMatch, oMatch.SubMatches(2)
    Next oMatch
    Debug.Print oMatchCollection.Count
    For Each oMatch In oCol
        Debug.Print oMatch.SubMatches(0) & oMatch.SubMatches(1) & oMatch.SubMatches(2)
        strSubject = oMatch.SubMatches(0) & oMatch.SubMatches(1) & oMatch.SubMatches(2)
        strSubject = Replace(strSubject, Chr(13), "") & ","
        testSubject = testSubject & Trim(strSubject)
        Debug.Print testSubject
        strInList = "IN " & testSubject
    Next oMatch
        Debug.Print strInList
        
        If strInList = "" Then
        msgbox ("No references found, please ensure you have selected the correct message from your inbox")
        Exit Sub
        End If


answer = msgbox("I have found the following " & oMatchCollection.Count & " references in this email: " & _
strInList & vbNewLine & "Select Ok to copy In List to clipboard and continue" & _
vbNewLine & "Select Cancel if these results are incorrect", vbOKCancel)
    
    If answer = vbOK Then
    Copy
        
    Else
    Exit Sub


End If
msgbox ("To create folders for these files, you will need to know the primary actual use (ie: Res, Farm, ICI, Strata) for each. Click Ok when you have determined the correct uses to continue.")


    For Each oMatch In oMatchCollection
    FileRef = oMatch.SubMatches(1) & " - " & oMatch.SubMatches(2)
        SaveMessageAsMsg
    Next


msgbox ("Finished!")




Set oRegExp = Nothing


End Sub


Public Sub Copy()
    
    Dim clipboard As MSForms.DataObject


    Set clipboard = New MSForms.DataObject
    
    clipboard.SetText strInList
    clipboard.PutInClipboard
    msgbox ("The InList has been copied to your clipboard. Please paste into the propid field to generate RS")
    
End Sub


Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim sName As String
  
    Pick
    
If strNewFolderPath = "Exit" Then
Exit Sub
End If


MkDir (strNewFolderPath & "\" & FileRef)
On Error Resume Next


   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem
    
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"
  
  sPath = strNewFolderPath & "\" & FileRef & "\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName & ".msg", olMSG
   
  End If
  Next
   
End Sub


Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
 Dim ShellApp As Object
 Set ShellApp = CreateObject("Shell.Application"). _
 BrowseForFolder(0, "Please choose a folder for " & FileRef, 0, OpenAt)
 Debug.Print OpenAt
 On Error Resume Next
    BrowseForFolder = ShellApp.Self.Path
 Debug.Print BrowseForFolder
 strNewFolderPath = BrowseForFolder
 On Error GoTo 0


 Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
 Exit Function


Invalid:
 BrowseForFolder = False
End Function


Sub Pick()
    Dim answer                      As Integer
strFolderPath = "C:\Users\joe\Pictures\"
BrowseForFolder (strFolderPath)


If Len(strNewFolderPath) = 0 Then
        msgbox FileRef & " will be skipped", vbInformation 'optional
    strNewFolderPath = "Exit"
    
    ElseIf strNewFolderPath = "False" Then
        msgbox "Invalid selection...", vbInformation
    strNewFolderPath = "Exit"
    
    Else
    answer = msgbox("A copy of this message will be saved in a new folder named " & FileRef & " that will be created in: " & strNewFolderPath & "\", vbOKCancel)
    If answer = vbCancel Then
    strNewFolderPath = "Exit"
End If
    End If
End Sub

Thanks,
Joe

 

[Domenic]

You haven't change the Pick procedure and the SaveMessageAsMsg procedure as I've indicated in Post #35

And so as it stands, you won't be able to test strNewFolderPath in SaveMessageAsMsg.

And since you're using your original BrowseForFolder fucntion, you won't be able to do testing as you have there in Pick.

And, so I really don't know what to say at this point.

For now, I'm logging off.

 

[jbaich]

Hey Domenic, sorry about the confusion there... I had been trying to implement your advice from post 35, but hadn't been able to get the folder picker opening up at the right spot... I knew that it had sort of worked at some point in my past trials, so I just decided to try starting over and reworking things from my original start point to see if I could figure it out... I still don't know why the folder picker works this way and not the other way... to my (very limited) eye it looks like it should work the same either way. So I started from the beginning and when it worked this way (for whatever reason), I kinda just went with it...

I've been messing around with it some more this morning trying to see if I can figure out what wasn't working yesterday, and the only thing I can see that's really different is; in the working (original) format, the Browse function is called without a preceding variable, ie:

[COLOR=#333333]BrowseForFolder (strFolderPath)[/COLOR]

vs

varNewFolderPath = BrowseForFolder(sInitialPath)

So I just tried another configuration and it seems to have made a difference... by removing the "varNewFolderPath =" segment, the browse function opens at the right folder location... see below

Sub Pick(ByVal sInitialPath As String, ByRef varNewFolderPath As Variant)BrowseForFolder (sInitialPath)
End Sub

then in the function if I put varNewFolderPath = BrowseForFolder (see below)

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
 Dim ShellApp As Object
 Set ShellApp = CreateObject("Shell.Application"). _
 BrowseForFolder(0, "Please choose a folder for " & FileRef, 0, OpenAt)
 Debug.Print OpenAt
 On Error Resume Next
    BrowseForFolder = ShellApp.Self.Path
 Debug.Print BrowseForFolder
[U][B]varNewFolderPath = BrowseForFolder[/B][/U]
 On Error GoTo 0


 Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
 Exit Function


Invalid:
 BrowseForFolder = False
End Function

The varNewFolderPath value is returned to the SaveMessagesAs sub...
So then i would just need an if statement in the savemessagesas sub like..

If varNewFolderPath = Empty? False? Null? Invalid? 0? ""? Then
Exit Sub

Can you please advise on what the best way to structure the if statement above would be?
Also, if you can shed any light on why removing the "varNewFolderPath =" made a difference, I'd love to know

Thanks,
Joe

 

[Domenic]

[Note: I haven't had a chance to look at your last post. I start working on the following response earlier and only now have I had a chance to finish it. Hopefully it does what you want.]

First, here are a couple of things that I think needs to be addressed...

1) You'll need to add a comma in the following line where indicated in red, otherwise you'll get a compile error...

Public strSubject As String, strFolderPath As String, strNewFolderPath As String, FileRef As String, strInList As StringPublic[B][COLOR=#ff0000],[/COLOR][/B] olMail As Object

2) If you're running this code within Outlook, there's no need to set a reference to the Outlook library object and no need to create an instance of Outlook. So MsgChecker should be...

Sub MsgChecker()

    'Outlook variables
    Dim olMail                      As MailItem
    Dim sPattern                    As String
    Dim testSubject                 As String
    Dim answer                      As Integer
    
    'VBScript variables
    Dim oRegExp                     As Object
    Dim oMatchCollection            As Object
    Dim oSubMatches                 As Object
    Dim oMatch                      As Object
        
    Dim oCol                        As New Collection

    Set olMail = Application.ActiveExplorer.Selection.Item(1)

    'etc
    '
    '
    '

Then, for SaveMessageAsMsg...

Public Sub SaveMessageAsMsg()

    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sPath As String
    Dim sName As String
    Dim varFolderPath As Variant
    Dim strNewFolderPath As Variant
  
    varFolderPath = "C:\Users\joe\Pictures\"

    strNewFolderPath = Pick(varFolderPath)
    
    If strNewFolderPath = "Exit" Then Exit Sub
    
    MkDir (strNewFolderPath & "\" & FileRef)
    On Error Resume Next


    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem
            
            sName = oMail.Subject
            ReplaceCharsForFileName sName, "-"
            
            sPath = strNewFolderPath & "\" & FileRef & "\"
            Debug.Print sPath & sName
            oMail.SaveAs sPath & sName & ".msg", olMSG
        End If
    Next
   
End Sub

And, lastly, for Pick (notice that I turned it into a function so that it can return a value to your main sub)...

Function Pick(ByVal varFolderPath As Variant) As String

    Dim answer                      As Integer
    Dim varNewFolderPath            As Variant
    
    varNewFolderPath = BrowseForFolder(varFolderPath)
    
    If varNewFolderPath = False Then
        Pick = "Exit"
        Exit Function
    End If
    
    answer = MsgBox("A copy of this message will be saved in a new folder named " & FileRef & " that will be created in: " & varNewFolderPath & "\", vbOKCancel)
    If answer = vbCancel Then
        Pick = "Exit"
        Exit Function
    End If
    
    Pick = varNewFolderPath
    
End Function