I want to replace each instance of a given regex with some string in the currently active email draft.
I'm particularly stuck on the first line below.
PseudoCode:
myMessage = active message
someRegex = \d\d[:,]\d\d
someString = "(Time Entry)"
myMessage.HTMLBody = Replace(myMessage.HTMLBody, someRegex, someCharacter)
Something like this should work on the first items in Drafts.
Will add further error handling and testing later.
Dim objRegex As Object
Dim objNS As Outlook.NameSpace
Dim objItemj
Dim objFolder As Outlook.MAPIFolder
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderDrafts)
Set objItem = objFolder.Items(1)
Set objRegex = CreateObject("vbscript.regexp")
objRegex.Pattern = ":\d\d[:,]\d\d"
somestring = "(Time Entry)"
objItem.HTMLBody = objRegex.Replace(objItem.HTMLBody, somestring)
Related
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
I'm trying to filter items with an email body that contains a less than symbol <.
Here is a sample email body that contains less than symbol.
Our drive E: is now < 10%.
Sub CodeSubjectForward(Item As Outlook.MailItem)
Dim M1 As MatchCollection
Dim M As Match
Set Reg1 = New RegExp
With Reg1
.Pattern = "([<]\s*(\w*)\s*)"
.Global = True
End With
If Reg1.Test(Item.Body) Then
Set M1 = Reg1.Execute(Item.Body)
For Each M In M1
Next
End If
Item.Save
Set myForward = Item.Forward
myForward.Recipients.Add "alias#domain.com"
myForward.Send
End Sub
Should be something like this
Public Sub FWItem(Item As Outlook.mailitem)
Dim Email As Outlook.mailitem
Dim Matches As Variant
Dim RegExp As Object
Dim Pattern As String
Set RegExp = CreateObject("VbScript.RegExp")
If TypeOf Item Is Outlook.mailitem Then
Pattern = "(\s[<]\s)"
With RegExp
.Global = False
.Pattern = Pattern
.IgnoreCase = True
Set Matches = .Execute(Item.Body)
End With
If Matches.Count > 0 Then
Debug.Print Item.subject ' Print on Immediate Window
Set Email = Item.Forward
Email.subject = Item.subject
Email.Recipients.Add "0m3r#Email.com"
Email.Save
Email.Send
End If
End If
Set RegExp = Nothing
Set Matches = Nothing
Set Email = Nothing
Set Item = Nothing
End Sub
https://regex101.com/r/KOFM8E/1/
I have this VBS code:
Option Explicit
Dim reMethod, reInterface
Dim vaction
Dim fileService
Dim mService
Dim lineService
Dim objFSO
Const ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set fileService = objFSO.OpenTextFile("GIISAssuredController.java" , ForReading)
Set reMethod = new regexp
reMethod.Pattern = """\w+?""\.equals\(ACTION\)[\s\S]*?\{[\s\S]*?\.([^(]*)\("
reMethod.IgnoreCase = True
reMethod.Global = True
Do Until fileService.AtEndOfStream
lineService = fileService.ReadLine
For Each mService In reMethod.Execute(lineService)
vaction = mService.Submatches(0)
Set reInterface = new regexp
Wscript.Echo vaction
Next
Loop
And 'GIISAssuredController.java':
} else if ("hello".equals(ACTION)) {
Integer assuredNo = giisAssuredService.saveAssured(assured);
The regex pattern is not working.
I am expecting the output to be is:
saveAssured
But instead, it's not echoing anything. I tried the regex pattern here > https://regex101.com/r/kH3aZ4/1, and it's getting the 'saveAssured' string.
This question is related to: Multiline REGEX using VB Script
If the expression needs to match a text that spawns over multiple lines, but you read the file line by line and test line by line, there will never be a match.
Option Explicit
Const ForReading = 1
Dim code
code = CreateObject("Scripting.FileSystemObject" _
).OpenTextFile("GIISAssuredController.java" , ForReading _
).ReadAll()
Dim mService
With new RegExp
.Pattern = """\w+?""\.equals\(ACTION\)[\s\S]*?\{[\s\S]*?\.([^(]*)\("
.IgnoreCase = True
.Global = True
For Each mService in .Execute(code)
WScript.Echo mService.Submatches(0)
Next
End With
I'm struggling with validating a regex syntax that I'd like to use in Excel (VBA). The syntax runs good in every validator engine on the net but I can't get it to work in Excel.
Could anyone help me with this and I'd most grateful.
The expression:
^.+(?<!/)(?=/?[RP]\d)
Data to validate: ABC12345/67/R1A
Expected result: ABC12345/67
Please check this regex ^.+(?<!/)(?=/?[RP]\d) as its not giving the expected output.
It works with ^.+(?=/[RP]\d). Below is sample code.
Sub Main()
Dim stringToValidate As String
Dim stringResult As String
stringToValidate = "ABC12345/67/R1A"
stringResult = getData(stringToValidate)
End Sub
Function getData(ByVal str As String) As String
Dim objRegEx As Object
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.IgnoreCase = True
objRegEx.Global = True
objRegEx.Pattern = "^.+(?=/[RP]\d)"
Set allMatches = objRegEx.Execute(str)
For i = 0 To allMatches.Count - 1
result = result & allMatches.Item(i)
Next
getData = result
End Function
With the code below I am trying to pull each url I extract using the regular expression into an array that I can call later along with the count of urls. Not sure how to grab all of them.
Set objxmlHTTP = CreateObject("Microsoft.XMLHTTP")
Call objxmlHTTP.open("GET", "website", False)
objxmlHTTP.Send()
strHTML = objxmlHTTP.ResponseText
Dim objRegExp
Set objRegExp = New RegExp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<a\s+href=""(http://.*?)""[^>]+>(\s*\n|.+?\s*)</a>"
Dim objMatch
For Each objMatch in objRegExp.Execute(strHTML)
objMatch.SubMatches(0)
Next
Set objxmlHTTP = Nothing
I tested this with a fake string, your regexp results seemed a bit wonky so I changed it (grabbed from here). Results of the 1st match (you capture 2?) are placed in the matches array:
Dim objRegExp
Set objRegExp = New RegExp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = ""((https?:\/\/|www.)([-\w.]+)+(:\d+)?(\/([\w\/_.]*(\?\S+)?)?)?)""
dim matches()
dim i: i = 0
Dim objMatch
For Each objMatch in objRegExp.Execute(strHTML)
redim preserve matches(i)
matches(i) = objMatch.SubMatches(0)
i = (i + 1)
Next
Set objxmlHTTP = Nothing
'//read back
for i = 0 to ubound(matches)
wscript.echo matches(i)
next