VBA Regex Pattern: failing when underscore in my pattern - regex

Looking for some help with my macro that loops through subfolders and brings back data from the workbooks that match my filename pattern, because the name changes each month.
It works seamlessly if the pattern is "[0-9][0-9][0-9][0-9][0-9][0-9] Filename"
But fails if "[0-9][0-9][0-9][0-9]_[0-9][0-9] Filename"
Any ideas on how to handle the underscore please?
This fails "[0-9][0-9][0-9][0-9][_][0-9][0-9] Filename"
Thanks heaps
GWS
Option Explicit
Option Base 1
Private Const PORTFOLIO_CODE As String = "G030"
Private Sub ExtractData()
' get workbook list
Dim wbList As Collection
Set wbList = New Collection
Application.DisplayAlerts = False
RecursiveFileSearch _
"O:\Sales and Marketing\Monthly Reports\", _
"[0-9][0-9][0-9][0-9][_][0-9][0-9] Monthly Report.xlsm", _ 'fails to find any workbooks
'"[0-9][0-9][0-9][0-9][0-9][0-9] Monthly Report.xlsm", _ 'would work except my file names contain underscores
wbList
Dim resultOffset As Integer
wsResult.Name = result
resultOffset = 1
Dim wbName As Variant, wbOpen As Workbook, wsFund As Worksheet
For Each wbName In wbList
' loop through workbook list
' - open workbook, hidden
Application.ScreenUpdating = False
Set wbOpen = Workbooks.Open(Filename:=wbName, ReadOnly:=True)
wbOpen.Windows(1).Visible = False
' - get worksheet for fund
Set wsFund = wbOpen.Worksheets(PORTFOLIO_CODE)
Application.ScreenUpdating = True
' - find top of data
Dim valueDate As Date
valueDate = WorksheetFunction.EoMonth(DateSerial(2000 + CInt(Left(wbOpen.Name, 2)), CInt(Mid(wbOpen.Name, 3, 2)), 1), 0)
Debug.Print valueDate, wbOpen.Name
ThisWorkbook.Worksheets(PORTFOLIO_CODE).Activate
Dim baseData As Excel.Range
Set baseData = wsFund.Range("AQ:AQ").Find("Currency")
If Not baseData Is Nothing Then
' - loop through data
Dim rowOffset As Integer
rowOffset = 0
wsResult.Range("A1").Offset(resultOffset, 0).Value = valueDate ' baseData.Offset(rowOffset, 0).Value
wsResult.Range("A1").Offset(resultOffset, 1).Value = baseData.Offset(rowOffset, 0).Value
wsResult.Range("A1").Offset(resultOffset, 2).Value = baseData.Offset(rowOffset, 5).Value
resultOffset = resultOffset + 1
End If
' - close workbook
wbOpen.Close SaveChanges:=False
DoEvents
Next
Application.DisplayAlerts = True
End Sub
RecursiveFileSearch
Sub RecursiveFileSearch( _
ByVal targetFolder As String, _
ByRef filePattern As String, _
ByRef matchedFiles As Collection _
)
Dim oRegExp As New VBScript_RegExp_55.RegExp
oRegExp.Global = False
oRegExp.IgnoreCase = True
oRegExp.MultiLine = False
oRegExp.Pattern = filePattern
Dim oFSO As Scripting.FileSystemObject
Set oFSO = New Scripting.FileSystemObject
'Get the folder oect associated with the target directory
Dim oFolder As Variant
Set oFolder = oFSO.GetFolder(targetFolder)
'Loop through the files current folder
Dim oFile As Variant
For Each oFile In oFolder.Files
If oRegExp.test(oFile.Name) Then
matchedFiles.Add oFile
End If
Next
'Loop through the each of the sub folders recursively
Dim oSubFolders As Object
Set oSubFolders = oFolder.Subfolders
Dim oSubfolder As Variant
For Each oSubfolder In oSubFolders
RecursiveFileSearch oSubfolder, filePattern, matchedFiles
Next
'Garbage Collection
Set oFolder = Nothing
Set oFile = Nothing
Set oSubFolders = Nothing
Set oSubfolder = Nothing
Set oFSO = Nothing
Set oRegExp = Nothing
End Sub

Perhaps:
\d{4}_\d{2}.*Monthly Report\.xlsm

My code was escaping the () and . to override the defined regex behavior. Portland Runner suggestion solved the question. ^[0-9]{3,4}[_][0-9]{2} SAMPSON International Shares Passive (Hedged) Trust Mandate Monthly Report.xlsm

Related

Crawling web page links through Visaul Basic 2008

I have tried to convert one of my Visual Basic 6 programs to Visual Basic.NET. This program basically crawls email and mobile number data from a web page link. This program works great in Visual Basic 6 but after converting to Visual Basic.NET is not providing any function or result in .NET.
Imports VBScript_RegExp_55
Imports System.Collections.Specialized
Imports System.Diagnostics
Public Class autoextratorform
Dim emailsearch As New ListViewItem()
Dim numbersearch As New ListViewItem
Private Declare Function SendMessageByString _
Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As String) _
As Long
Private Const LB_SELECTSTRING = &H18C
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private WithEvents cIE As InternetHtml
Private WithEvents cExtLinks As cExtractLinks
Private cGSearch As cGoogleSearch
Dim Excel As Object
Dim Excelsheet As Object
Dim a() As String
Dim b() As String
Dim c() As String
Dim i As Integer
' Needs reference to Microsoft VBscript Regular Expressions I recomend ver 5.5.
'
Dim baseurl As String ' var to store base url so we can build the full path
Dim dVisited ' Dictionary to hold visited urls = I think Missing here
Dim dEmail ' dictionary to hold emails = I think Missing here
Dim dnumber ' = I think Missing here
Dim dweb '= I think Missing here
' We are putting the emails in a list also, for user feed back
'It would be less momery intensive and faster to just keep these in the dictionry object
'which allows to easily tell if the email already exist
Dim regxPage ' var to hold regular expression to extract urls
Dim regxEmail ' var to hold regular expression to extract emails
Dim regnumber
Dim regweb
Dim Match, Matches As String ' we use these to store are regx matches
Dim Match1, Matches1 As String
Dim Match2, Matches2 As String
' Regular expressions are super powerfull and have been a part of unix for a long time
' goto the form load event to see the regex initialization
' to learn more about regular expressions and to download the latest scripting runtime see
' http://msdn.microsoft.com/scripting/default.htm?/scripting/vbscript/techinfo/vbsdocs.htm
Dim email, pageurl, mnumber, sweb As String
' The above is only because dictionary.exist does not work directly on Match var
Dim stopcrawl As Integer ' Used to exit crawl loop
Private Sub ComboBox1_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ComboBox1.SelectedIndexChanged
Select Case ComboBox1.SelectedIndex
Case 0
ListBox2.Items.Clear()
ListBox2.Items.Add("http://classads.jang.com.pk/default.asp?cityid=1")
ListBox2.Items.Add("http://www.merapakistan.com/classifieds/")
ListBox2.Items.Add("http://olx.com.pk/")
ListBox2.SelectedIndex = 0
txtStartUrl.Text = ListBox2.Text
Case 1
ListBox2.Items.Clear()
ListBox2.Items.Add("http://www.locanto.com.pk/")
ListBox2.Items.Add("http://pakistanclassifiedads.com/")
ListBox2.Items.Add("http://pkr.com.pk/")
txtStartUrl.Text = ListBox2.Text
Case 2
ListBox2.Items.Clear()
ListBox2.Items.Add("http://adpost.pk/")
ListBox2.Items.Add("http://page.com.pk/")
ListBox2.Items.Add("http://www.clasf.pk/")
ListBox2.SelectedIndex = 0
txtStartUrl.Text = ListBox2.Text
Case 3
ListBox2.Items.Clear()
ListBox2.Items.Add("http://www.nelaam.com/")
ListBox2.Items.Add("http://www.asani.com.pk/")
ListBox2.Items.Add("http://freepost.com.pk/")
ListBox2.SelectedIndex = 0
txtStartUrl.Text = ListBox2.Text
End Select
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Command1.Click
stopcrawl = 0 ' set stop crawl so we do not exit loop
If txtStartUrl.Text & "" = "" Then
lblresult.Text = ("Please Load your Desired Site List !")
Exit Sub
ElseIf txtStartUrl.Text & "" = "http://" Then
lblresult.Text = ("Please Load your Desired Site List !")
Exit Sub
ElseIf txtStartUrl.Text = "" Then
lblresult.Text = ("Please Load your Desired Site List !")
Exit Sub
End If
' the above should really check for a valid url, but I am a lazy PERL programmer
ListBox1.Items.Add(txtStartUrl.Text) 'add item to list
Label16.Text = (ListBox2.Items.Count - 1)
Label8.Text = (ListBox2.Items.Count)
lblresult.Text = " Start service for searching Email address and Mobile Numbers"
Command1.Enabled = False
ComboBox1.Enabled = False
LaVolpeButton4.Enabled = True
'UPGRADE_ISSUE: (2064) ComboBox property Combo1.Locked was not upgraded. More Information: https://docs.mobilize.net/vbuc/ewis#2064
LaVolpeButton8.Enabled = False
LaVolpeButton9.Enabled = False
txtStartUrl.ReadOnly = True
crawl() ' and were off
End Sub
Private Sub autoextrator_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
With listnumber
.Columns.Clear()
.Columns.Add("Count!", CInt(Width * 0.1))
.Columns.Add("Mobile Number!", CInt(Width * 0.2))
.Columns.Add("Web URL!", CInt(Width * 0.68))
End With
With listemail
.Columns.Clear()
.Columns.Add("Count!", CInt(Width * 0.1))
.Columns.Add("Email Address!", CInt(Width * 0.2))
.Columns.Add("Web URL!", CInt(Width * 0.68))
End With
'initialize dictionary and regx objects
dVisited = CreateObject("Scripting.Dictionary")
dVisited.CompareMode = CompareMethod.Binary
dEmail = CreateObject("Scripting.Dictionary")
dEmail.CompareMode = CompareMethod.Binary
dnumber = CreateObject("Scripting.Dictionary")
dnumber.CompareMode = CompareMethod.Binary
dweb = CreateObject("Scripting.Dictionary")
dweb.CompareMode = CompareMethod.Binary
Dim counting1 As String
Dim counting2 As String
regxPage = New VBScript_RegExp_55.RegExp() ' Create a regular expression.
regxPage.Pattern = "HREF=""[^""#]+[.][^""#]+" ' Set pattern."
regxPage.IgnoreCase = True ' Set case insensitivity.
regxPage.Global = True ' Set global applicability.
regxEmail = New VBScript_RegExp_55.RegExp() ' Create a regular expression.
regxEmail.Pattern = "\b[a-z0-9._%+-]+#[a-z0-9.-]+\.[a-z]{2,4}\b" ' Set pattern."
regxEmail.IgnoreCase = True ' Set case insensitivity.
regxEmail.Global = True ' Set global applicability.
regnumber = New VBScript_RegExp_55.RegExp()
counting1 = "(\+92)-?\d{3}-?\d{7}"
counting2 = "(?:0092|0|\+92)-?\d{3}-?\d{7}"
regnumber.Pattern = counting1
regnumber.Pattern = counting2
regnumber.IgnoreCase = True
regnumber.Global = True
cIE = New InternetHtml()
cGSearch = New cGoogleSearch()
cExtLinks = New cExtractLinks()
End Sub
Sub crawl()
While ListBox1.Items.Count > 0 ' loop while list has data
If stopcrawl = 1 Then GoTo exitcrawl
getpage(ListBox1.Items(0)) ' This is the heart of the prog, except for the regx = I think Missing here
' stuff in the form load event
ListBox1.Items.Remove(0) ' remove item from list
End While
ListBox2.Items.Remove(ListBox2.SelectedIndex)
If ListBox2.SelectedIndex < ListBox2.Items.Count - 1 Then
ListBox2.SelectedIndex += 1
txtStartUrl.Text = ListBox2.Items.ToString
exitcrawl:
If ListBox2.Items.Count = 0 Then
MessageBox.Show("Searching has completed !", "Done ! searching", MessageBoxButtons.OK, MessageBoxIcon.Information)
txtStartUrl.ReadOnly = False
txtStartUrl.Text = ""
Label3.Text = "-----------------------------------------------------------"
LaVolpeButton4.Enabled = False
Command1.Enabled = True
LaVolpeButton8.Enabled = True
LaVolpeButton9.Enabled = True
End If
End If
End Sub
Sub getpage(ByVal page As String)
On Error Resume Next
If dVisited.Contains(page) Then
Exit Sub
Else
dVisited.Add(page, 1) ' add page to dVisited dictionary
Label6.Text = CStr(ListBox1.Items.Count)
Label14.Text = CStr(dVisited.Count)
Label3.Text = page
End If
baseurl = getpath(page) ' build full url - see getpath
TextBox1.Text = ""
If ListBox1.Items.Count > 5000 Then Exit Sub ' sets the maximum cache (so we don't run out of mem)
Using wc As New System.Net.WebClient
TextBox1.Text = wc.DownloadString(page)
End Using
Matches = regxPage.Execute(TextBox1.Text) ' Execute search.
For Each Me.Match In Matches
pageurl = Match
If InStr(1, pageurl, "http://", vbTextCompare) Then
If dVisited.Exists(pageurl) = False Then ListBox1.Items.Add(Mid(pageurl, 7))
Else
If dVisited.Exists(baseurl & Mid(pageurl, 7)) = False Then ListBox1.Items.Add(baseurl & Mid(pageurl, 7))
End If
Next
' search for email
Matches = regxEmail.Execute(TextBox1.Text) ' Execute search.
For Each Me.Match In Matches ' Iterate Matches collection.
' check if email exist
email = Match
Debug.Print(email & dEmail.Exists(email))
If dEmail.Exists(email) = False Then
dEmail.Add((email), 1)
Dim d As Integer
d = listemail.Items.Count
d = d + 1
emailsearch = listemail.Items.Add(d)
emailsearch.SubItems.Add(email.ToString)
emailsearch.SubItems.Add(pageurl.ToString)
ListBox3.Items.Add(email)
Label10.Text = listemail.Items.Count
End If
Next
Matches1 = regnumber.Execute(TextBox1.Text)
For Each Me.Match1 In Matches1
mnumber = Match1
Debug.Print(mnumber & dnumber.Exists(mnumber))
If dnumber.Exists(mnumber) = False Then
dnumber.Add((mnumber), 1)
Dim c As Integer
c = listnumber.Items.Count
c = c + 1
numbersearch = listnumber.Items.Add(c)
numbersearch.SubItems.Add(mnumber.ToString)
numbersearch.SubItems.Add(pageurl.ToString)
Label12.Text = listnumber.Items.Count
End If
Next
End Sub
Function getpath(ByVal URL As String) As String
' look for the last / and get a string up to that location
Dim lastbar As Integer = URL.LastIndexOf("/") + 1
Dim tmppath As String = URL.Substring(0, Math.Min(lastbar, URL.Length))
If tmppath = "http://" Then tmppath = URL ' full path already so return url
Return tmppath
End Function
Public Function StripOut(ByVal From As String, ByVal What As String) As String
Dim result As String = ""
result = From
For i As Integer = 1 To Strings.Len(What)
result = result.Replace(What.Substring(i - 1, Math.Min(1, What.Length - (i - 1))), "")
Next i
Return result
End Function
Private Sub LaVolpeButton4_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles LaVolpeButton4.Click
stopcrawl = 1
MsgBox(" Service has Stoped by USER !")
LaVolpeButton4.Enabled = False
Command1.Enabled = True
End Sub
Private Sub LaVolpeButton8_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles LaVolpeButton8.Click
Dim strData As String = ""
Dim strQ() As String
Dim intFile As Integer
' Set up the Common Dialog initial Directory
' to the application path. Filter for Text and All files
' Prompt the user to select a file
'
cmd.InitialDirectory = My.Application.Info.DirectoryPath
cmd.Filter = "Text Files(*.txt)|*.txt|All Files(*.*)|*.*"
cmd.Title = "Select Email Addresses File"
cmd.ShowDialog()
If cmd.FileName <> "" Then
'
' If the user selected a file
' open and read the entire contents
' then split it into records
'
intFile = FileSystem.FreeFile()
FileSystem.FileOpen(intFile, cmd.FileName, OpenMode.Input)
strData = FileSystem.InputString(intFile, FileSystem.LOF(intFile))
FileSystem.FileClose(intFile)
strQ = strData.Split(CChar(Environment.NewLine))
'
' Populate the texbox array with the questions
' (either the number of textboxes in the control array or
' number of questions, which ever is the smaller)
For Each strQ_item As String In strQ
ListBox2.Items.Add(strQ_item)
Next strQ_item
txtStartUrl.Text = ListBox2.Text
End If
End Sub
End Class
2- This is Visual basic 6 Code that works perfect.
Dim baseurl As String ' var to store base url so we can build the full path
Dim dVisited As Dictionary ' Dictionary to hold visited urls
Dim dEmail As Dictionary ' dictionary to hold emails
Dim dnumber As Dictionary
Dim dweb As Dictionary
Sub crawl()
While List1.ListCount > 0 ' loop while list has data
If stopcrawl = 1 Then GoTo exitcrawl
getpage List1.List(0) ' This is the heart of the prog, except for the regx
' stuff in the form load event
List1.RemoveItem (0) ' remove item from list
Wend
List2.RemoveItem (List2.ListIndex)
If List2.ListIndex < List2.ListCount - 1 Then
List2.ListIndex = List2.ListIndex + 1
txtStartUrl = List2.Text
Command1_Click
Else
exitcrawl:
If List2.ListCount = 0 Then
MsgBox "Searching has completed !", vbInformation, "Done ! searching"
WebBrowser1.Stop
txtStartUrl.Locked = False
txtStartUrl.Text = ""
Label3.Caption = "-----------------------------------------------------------"
LaVolpeButton4.Enabled = False
Command1.Enabled = True
LaVolpeButton8.Enabled = True
LaVolpeButton9.Enabled = True
End If
End If
End Sub

regEx positive lookbehind in VBA language [duplicate]

This is not code I wrote completely, some I have pieced together from one or two sites and some is what I have set. What I'm trying to do is use a regex function defined in regex.Pattern to look at message subject and extract a value. This is what I'm going to see in the email subject:
New Linux Server: prod-servername-a001
So far I can get the full message subject into the Excel file, but when I have tried to implement the regex portion, I get an error code 5017 (error in expression from what I can find) and the regex is not "working". My expectation is the script will pull the message subject, use the regex to extract the value and place it in the cell. I'm using RegEx Builder (regex testing program) to test the expression and it works there, but not here. I am very new to VB, so I don't know if the issue is that VB can't use this expression or if the script is failing somewhere else and the error is something residual from another problem. Or is there a better way to write this?
Sub ExportToExcel()
On Error GoTo ErrHandler
'Declarations
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim filePath As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
'RegEx Declarations
Dim result As String
Dim allMatches As Object
Dim regex As Object
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "(?<=Server: ).*"
regex.Global = True
regex.IgnoreCase = True
' Set the filename and path for output, requires creating the path to work
strSheet = "outlook.xlsx"
strPath = "D:\temp\"
filePath = strPath & strSheet
'Debug
Debug.Print filePath
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (filePath)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
If itm.UnRead = True Then
intRowCounter = intRowCounter + 1
wks.Cells(1, 1).value = "Subject" 'Row 1 Column 1 (A)
wks.Cells(1, 2).value = "Unread" 'Row 1 Column 2 (B)
wks.Cells(1, 3).value = "Server" 'Row 1 Column 3 (C)
Set rng = wks.Cells(intRowCounter + 1, intColumnCounter)
If InStr(msg.Subject, "Server:") Then
Set allMatches = regex.Execute(msg.Subject)
rng.value = allMatches
intColumnCounter = intColumnCounter + 1
msg.UnRead = False
Else
rng.value = msg.Subject
intColumnCounter = intColumnCounter + 1
msg.UnRead = False
End If
Set rng = wks.Cells(intRowCounter + 1, intColumnCounter)
rng.value = msg.UnRead
intColumnCounter = intColumnCounter + 1
End If
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler:
If Err.Number = 1004 Then
MsgBox filePath & " doesn't exist", vbOKOnly, "Error"
ElseIf Err.Number = 13 Then
MsgBox Err.Number & ": Type Mismatch", vbOKOnly, "Error"
ElseIf Err.Number = 438 Then
MsgBox Err.Number & ": Object doesn't support this property or method", vbOKOnly, "Error"
ElseIf Err.Number = 5017 Then
MsgBox Err.Number & ": Error in expression", vbOKOnly, "Error"
Else
MsgBox Err.Number & ": Description: ", vbOKOnly, "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
VBA regex does not support lookbehinds, but in this case, you do not need a positive lookbehind, you just can use a capturing group - "Server: (.*)"` - and then access Group 1 value:
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "Server: (.*)"
regex.IgnoreCase = True
Set allMatches = regex.Execute("New Linux Server: prod-servername-a001")
If allMatches.Count <> 0 Then
rng.Value = allMatches(0).Submatches(0)
End If
Here,
Server: - matches a string Server: + space
(.*) - matches and captures into Group 1 zero or more characters other than a newline up to the end of line.
See more about capturing groups.

How do I filter for a specific word (map) then capture the next text up until the next space?

I am trying to get the text right after - Map in this case example it is "AVE_NMHG_I_214_4010_XML_SAT" and input that into each Map Name row within the column up until the next space character found in could end up being "AVE_I_214_4010" as another example.
this is where I'm trying to make this fit.
Dim tmp As String
Dim RegX2 As Object, Mats1 As Object
tmp = strColS
Set RegX2 = CreateObject("VBScript.RegExp")
With RegX2
.Global = True
.Pattern = "Map\d{7}"
Set Mats1 = .Execute(tmp)
End With
If (RegX2.Test(tmp)) Then
Set Mats1 = RegX2.Execute(tmp)
tmp = Mats1(0)
Else
With RegX2
.Pattern = "MAP\d{9}"
Set Mats1 = .Execute(tmp)
End With
If (RegX.Test(tmp)) Then
tmp = Mats1(0)
End If
End If
Set Mats1 = Nothing
Set RegX2 = Nothing
Note: there isn't always a Map specified and sometimes it is defined as MAP or map.
This code works by selecting the emails in outlook and then running the macro for only that selected emails.
This is an example of a subject that has the
Example Subject
RE: TS001889493 - Translation failure - Inbound - ( VEXP/ HONCE/ Document Type 214 - Map AVE_NMHG_I_214_4010_XML_SAT - Error Conditional Relationship Error in N103 (0066) [ ref:_00D50c9MW._5000z1J3cG8:ref ]
Example of body
Dear Valued Trading Partner,
We received the attached 214 transactions from Sender ID: VEXP/ Receiver ID: HONCE that failed due to Conditional Relationship Error in the N1_03 (0066).
As per the map logic, If either N103 or N104 is present, then the other is required as they are in conditional relationship with each other. But in the input file received, N104 value is missing hence the error.
Transaction Details: #4# Attached
Please correct and resend the data.
Thank you, Simon Huggs | Sass support - Basic
What happens in the #num# is that it gets the sum of all these after making a match of the "TS" ticket ID.
This is the code I have up until now
Option Explicit
Sub WritingTicketNumberAndfailuresnew()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount, STicket, SticketNumber As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath, SSubject As String
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColS, strColB, sassupport, sMailDateReceived, SFrom As String
Dim Actions1, Actions2, Actions3, Actions4 As Boolean
Dim I, cnt, email_needed As Integer
' Get Excel set up
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open a specific workbook to input the data the path of the workbook under the windows user account
enviro = CStr(Environ("USERPROFILE"))
strPath = enviro & "\Documents\topthreeticket.xlsx"
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
' Add column names
xlSheet.Range("A1") = "Email Subject"
xlSheet.Range("B1") = "Map Name"
xlSheet.Range("C1") = "Case Number"
xlSheet.Range("D1") = "No. Of Failures"
xlSheet.Range("E1") = "Date"
xlSheet.Range("F1") = "Week Number"
sassupport = "sassuport#sass.com"
On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
'collect the fields for ticket number and failure count
strColS = olItem.Subject
strColB = olItem.Body
SFrom = olItem.SenderEmailAddress
sMailDateReceived = olItem.ReceivedTime
Dim sFailures, stmp1, stmp2, stmp3 As String
Dim RegX As Object, Mats As Object
Dim Found As Boolean
' Check the number of failures from body
sFailures = "0"
stmp1 = strColB
Set RegX = CreateObject("VBScript.RegExp")
With RegX
.Global = True
.Pattern = "#\d+#"
Set Mats = .Execute(stmp1)
End With
If (RegX.Test(stmp1)) Then
stmp2 = Mats(0)
Found = True
stmp3 = Mid(stmp2, 2, Len(stmp2) - 2)
sFailures = stmp3
Else
With RegX
.Pattern = "#d\d+"
Set Mats = .Execute(stmp1)
End With
If (RegX.Test(stmp1)) Then
stmp2 = Mats(0)
Found = True
stmp3 = Mid(stmp2, 2, Len(stmp2) - 1)
sFailures = stmp3
End If
End If
Set Mats = Nothing
Set RegX = Nothing
Dim tmp As String
Dim RegX2 As Object, Mats1 As Object
tmp = strColS
Set RegX2 = CreateObject("VBScript.RegExp")
With RegX2
.Global = True
.Pattern = "Map\d{7}"
Set Mats1 = .Execute(tmp)
End With
If (RegX2.Test(tmp)) Then
Set Mats1 = RegX2.Execute(tmp)
tmp = Mats1(0)
Else
With RegX2
.Pattern = "MAP\d{9}"
Set Mats1 = .Execute(tmp)
End With
If (RegX.Test(tmp)) Then
tmp = Mats1(0)
End If
End If
Set Mats1 = Nothing
Set RegX2 = Nothing
Dim tempticketnum, tmpdate As String
Dim ticketnumposition As Integer
'write them in the excel sheet
If SFrom = sassupport Then
xlSheet.Range("A" & rCount) = strColS
xlSheet.Range("B" & rCount) = tmp2
xlSheet.Range("C" & rCount) = tmp
xlSheet.Range("D" & rCount) = sFailures ' number of failures
xlSheet.Range("E" & rCount) = sMailDateReceived
rCount = rCount + 1
End If
Next
Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlSheet = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
End Sub
To extract the substring as you specify:
.ignorecase = True
.pattern = "map\s*(\S+)"
or
.pattern = "\bmap\s*(\S+)"
The substring will be in capturing group 1
If there is no map then the .test(..) line will return False
Regex Explained
\bmap\s*(\S+)
Options: Case insensitive; ^$ don’t match at line breaks
Assert position at a word boundary \b
Match the character string “map” literally map
Match a single character that is a “whitespace character” \s*
Between zero and unlimited times, as many times as possible, giving back as needed (greedy) *
Match the regex below and capture its match into backreference number 1 (\S+)
Match a single character that is NOT a “whitespace character” \S+
Between one and unlimited times, as many times as possible, giving back as needed (greedy) +
Created with RegexBuddy

Using regex with positive lookbehind in VBA

This is not code I wrote completely, some I have pieced together from one or two sites and some is what I have set. What I'm trying to do is use a regex function defined in regex.Pattern to look at message subject and extract a value. This is what I'm going to see in the email subject:
New Linux Server: prod-servername-a001
So far I can get the full message subject into the Excel file, but when I have tried to implement the regex portion, I get an error code 5017 (error in expression from what I can find) and the regex is not "working". My expectation is the script will pull the message subject, use the regex to extract the value and place it in the cell. I'm using RegEx Builder (regex testing program) to test the expression and it works there, but not here. I am very new to VB, so I don't know if the issue is that VB can't use this expression or if the script is failing somewhere else and the error is something residual from another problem. Or is there a better way to write this?
Sub ExportToExcel()
On Error GoTo ErrHandler
'Declarations
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim filePath As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
'RegEx Declarations
Dim result As String
Dim allMatches As Object
Dim regex As Object
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "(?<=Server: ).*"
regex.Global = True
regex.IgnoreCase = True
' Set the filename and path for output, requires creating the path to work
strSheet = "outlook.xlsx"
strPath = "D:\temp\"
filePath = strPath & strSheet
'Debug
Debug.Print filePath
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (filePath)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
If itm.UnRead = True Then
intRowCounter = intRowCounter + 1
wks.Cells(1, 1).value = "Subject" 'Row 1 Column 1 (A)
wks.Cells(1, 2).value = "Unread" 'Row 1 Column 2 (B)
wks.Cells(1, 3).value = "Server" 'Row 1 Column 3 (C)
Set rng = wks.Cells(intRowCounter + 1, intColumnCounter)
If InStr(msg.Subject, "Server:") Then
Set allMatches = regex.Execute(msg.Subject)
rng.value = allMatches
intColumnCounter = intColumnCounter + 1
msg.UnRead = False
Else
rng.value = msg.Subject
intColumnCounter = intColumnCounter + 1
msg.UnRead = False
End If
Set rng = wks.Cells(intRowCounter + 1, intColumnCounter)
rng.value = msg.UnRead
intColumnCounter = intColumnCounter + 1
End If
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler:
If Err.Number = 1004 Then
MsgBox filePath & " doesn't exist", vbOKOnly, "Error"
ElseIf Err.Number = 13 Then
MsgBox Err.Number & ": Type Mismatch", vbOKOnly, "Error"
ElseIf Err.Number = 438 Then
MsgBox Err.Number & ": Object doesn't support this property or method", vbOKOnly, "Error"
ElseIf Err.Number = 5017 Then
MsgBox Err.Number & ": Error in expression", vbOKOnly, "Error"
Else
MsgBox Err.Number & ": Description: ", vbOKOnly, "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
VBA regex does not support lookbehinds, but in this case, you do not need a positive lookbehind, you just can use a capturing group - "Server: (.*)"` - and then access Group 1 value:
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "Server: (.*)"
regex.IgnoreCase = True
Set allMatches = regex.Execute("New Linux Server: prod-servername-a001")
If allMatches.Count <> 0 Then
rng.Value = allMatches(0).Submatches(0)
End If
Here,
Server: - matches a string Server: + space
(.*) - matches and captures into Group 1 zero or more characters other than a newline up to the end of line.
See more about capturing groups.

How to replace 'at' with #

I have about 17k emails containing orders, news, contacts etc. going back 11 years.
Users' email addresses have been shoddily encrypted to stop crawlers and spam by changing the # to either *#* or 'at'.
I am trying to create a comma separated list to build a database of our users.
The code works with writing the file and looping the folders because if I write the senders email address to the file where I am currently using the body of the email then it prints fine.
The problem is, the Replaces aren't changing *at* etc to #.
First of all, why not?
Is there a better way for me to be doing this as a whole?
Private Sub Form_Load()
Dim objOutlook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objInbox As MAPIFolder
Dim objFolder As MAPIFolder
Dim fldName As String
fldName = "TEST"
' Get the MAPI reference
Set objNameSpace = objOutlook.GetNamespace("MAPI")
' Pick up the Inbox
Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)
'Loop through the folders under the Inbox
For Each objFolder In objInbox.Folders
RecurseFolders fldName, objFolder
Next objFolder
End Sub
Public Sub RecurseFolders(targetFolder As String, currentFolder As MAPIFolder)
If currentFolder.Name = targetFolder Then
GetEmails currentFolder
Else
Dim objFolder As MAPIFolder
If currentFolder.Folders.Count > 0 Then
For Each objFolder In currentFolder.Folders
RecurseFolders targetFolder, objFolder
Next
End If
End If
End Sub
Sub WriteToATextFile(e As String)
MyFile = "c:\" & "emailist.txt"
'set and open file for output
fnum = FreeFile()
Open MyFile For Append As fnum
Print #fnum, e; ","
Close #fnum
End Sub
Sub GetEmails(folder As MAPIFolder)
Dim objMail As MailItem
' Read through all the items
For i = 1 To folder.Items.Count
Set objMail = folder.Items(i)
GetEmail objMail.Body
Next i
End Sub
Sub GetEmail(s As String)
Dim txt = s
Do Until InStr(txt, "#") <= 0
Dim tleft As Integer
Dim tright As Integer
Dim start As Integer
Dim text As String
Dim email As String
text = Replace(text, " at ", "#", VbCompareMethod.vbTextCompare)
text = Replace(text, "'at'", "#", VbCompareMethod.vbTextCompare)
text = Replace(text, "*at*", "#", VbCompareMethod.vbTextCompare)
text = Replace(text, "*at*", "#", VbCompareMethod.vbTextCompare)
text = Replace(text, "<", " ", VbCompareMethod.vbTextCompare)
text = Replace(text, ">", " ", VbCompareMethod.vbTextCompare)
text = Replace(text, ":", " ", VbCompareMethod.vbTextCompare)
'one two ab#bd.com one two
tleft = InStr(text, "#") '11
WriteToATextFile Str(tleft)
WriteToATextFile Str(Len(text))
start = InStrRev(text, " ", Len(text) - tleft)
'WriteToATextFile Str(start)
'WriteToATextFile Str(Len(text))
'start = Len(text) - tleft
text = left(text, start)
'ab#bd.com one two
tright = InStr(text, " ") '9
email = left(text, tright)
WriteToATextFile email
text = right(text, Len(text) - Len(email))
GetEmail txt
Loop
End Sub
What about using a regex (Regular Expression)?
Something like:
Public Function ReplaceAT(ByVal sInput as String)
Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")
With RegEx
.Global = True
.IgnoreCase = True
.MultiLine = True
.Pattern = "( at |'at'|<at>)"
End With
ReplaceAT = RegEx.Replace(sInput, "#")
Set RegEx = Nothing
End Function
Just replace the regexp with every cases you might get.
See http://www.regular-expressions.info/ for more tips and infos.
I've taken a crack at this to extract emails such as this sample below which will take out the three email addresses in yellow in the sample message below to a csv file
Any valids emails are written to a csv file Set objTF = objFSO.createtextfile("c:\myemail.csv")
This code scans all emails in a folder called temp under Inbox I cut out your recursive portion of testing and simplicity
There are four string manipulations
This line converts any non printing blank spaces to normal spaces strMsgBody = Replace(strMsgBody, Chr(160), Chr(32) (unlikely but it happened in my testing)
Regex1 converts any " at " or "at" etc into "#" "(\s+at\s+|'at'|<at>|\*at\*|at)"
Regex2 converts any " dot " or "dot" etc into "." "(\s+dot\s+|'dot'|<dot>|\*dot\*|dot)"
Regex3 converts any of "<" ">" or ":" into "" .Pattern = "[<:>]"
Regex4 extracts any valid email from the emailbody
Any valid emails are written to the csv file using objTF.writeline objRegM
Code below
Public Test()
Dim objOutlook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objFolder As MAPIFolder
Dim strfld As String
Dim objRegex As Object
Dim objRegMC As Object
Dim objRegM As Object
Dim objFSO As Object
Dim oMailItem As MailItem
Dim objTF As Object
Dim strMsgBody As String
Set objRegex = CreateObject("vbscript.regexp")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile("c:\myemail.csv")
With objRegex
.Global = True
.MultiLine = True
.ignorecase = True
strfld = "temp"
'Get the MAPI reference
Set objNameSpace = objOutlook.GetNamespace("MAPI")
'Pick up the Inbox
Set objFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
Set objFolder = objFolder.Folders(strfld)
For Each oMailItem In objFolder.Items
strMsgBody = oMailItem.Body
strMsgBody = Replace(strMsgBody, Chr(160), Chr(32))
.Pattern = "(\s+at\s+|'at'|<at>|\*at\*|at)"
strMsgBody = .Replace(strMsgBody, "#")
.Pattern = "(\s+dot\s+|'dot'|<dot>|\*dot\*|dot)"
strMsgBody = .Replace(strMsgBody, ".")
.Pattern = "[<:>]"
strMsgBody = .Replace(strMsgBody, vbNullString)
.Pattern = "[\w-\.]{1,}\#([\da-zA-Z-]{1,}\.){1,}[\da-zA-Z-]{2,3}"
If .Test(strMsgBody) Then
Set objRegMC = .Execute(strMsgBody)
For Each objRegM In objRegMC
objTF.writeline objRegM
Next
End If
Next
End With
objTF.Close
End Sub