VBA - Find string in email body or subject - vba

I am trying to create a simple macro, which reads the active email and checks whether or not a certain string is present. Now, the string can have two possible formats, and will only contains digits.
The two formats:
xxx-xxxxxxxx or xxxxxxxxxxx
(x will always be a digit)
I am unsure on how to do this. Below I have a macro, which reads the mail - but it can only find a specific string:
Sub AutomateReplyWithSearchString()
Dim myInspector As Outlook.Inspector
Dim myObject As Object
Dim myItem As Outlook.MailItem
Dim myDoc As Word.Document
Dim mySelection As Word.Selection
Dim strItem As String
Dim strGreeting As String
Set myInspector = Application.ActiveInspector
Set myObject = myInspector.CurrentItem
'The active inspector is displaying a mail item.
If myObject.MessageClass = "IPM.Note" And myInspector.IsWordMail = True Then
Set myItem = myInspector.CurrentItem
'Grab the body of the message using a Word Document object.
Set myDoc = myInspector.WordEditor
myDoc.Range.Find.ClearFormatting
Set mySelection = myDoc.Application.Selection
With mySelection.Find
.Text = "xxx-xxxxxxxx"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
If mySelection.Find.Execute = True Then
strItem = mySelection.Text
'Mail item is in compose mode in the inspector
If myItem.Sent = False Then
strGreeting = "With reference to " + strItem
myDoc.Range.InsertBefore (strGreeting)
End If
Else
MsgBox "There is no item number in this message."
End If
End If
End Sub

You can use regex pattern:
(\d{11}|\d{3}-\d{8})
Try it.
This example is copied from here. I have not tested it.
Option Explicit
Sub GetValueUsingRegEx()
' Set reference to VB Script library
' Microsoft VBScript Regular Expressions 5.5
Dim olMail As Outlook.MailItem
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Set olMail = Application.ActiveExplorer().Selection(1)
' Debug.Print olMail.Body
Set Reg1 = New RegExp
With Reg1
.Pattern = "(\d{11}|\d{3}-\d{8})"
.Global = True
End With
If Reg1.test(olMail.body) Then
Set M1 = Reg1.Execute(olMail.body)
For Each M In M1
Debug.Print M.SubMatches(1)
Next
End If
End Sub

Related

Find and delete all highlighted text in an email

I need to find and delete all highlighted text in an email body.
I tried to use WordEditor in Outlook VBA.
The following works in a Word document because I recorded the macro in Word:
.Find.ClearFormatting
.Find.Highlight = True
.Find.Replacement.ClearFormatting
With .Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
MsgBox "running macro"
End With
Selection.Find.Execute Replace:=wdReplaceAll
What are the necessary Outlook objects and code to include in the Outlook macro?
I know I need to dim ObjectInspector and a few other objects.
To deal with the Word editor in Outlook you need to use the Inspector.WordEditor property which returns the Microsoft Word Document Object Model of the message. You can use the following ways to get an instance of the Inspector class:
Use the ActiveInspector method to return the object representing the currently active inspector (if there is one).
Sub CloseItem()
Dim myinspector As Outlook.Inspector
Dim myItem As Outlook.MailItem
Set myinspector = Application.ActiveInspector
Set myItem = myinspector.CurrentItem
myItem.Close olSave
End Sub
Use the GetInspector property to return the Inspector object associated with an item.
Sub InsertBodyTextInWordEditor()
Dim myItem As Outlook.MailItem
Dim myInspector As Outlook.Inspector
'You must add a reference to the Microsoft Word Object Library
'before this sample will compile
Dim wdDoc As Word.Document
Dim wdRange As Word.Range
On Error Resume Next
Set myItem = Application.CreateItem(olMailItem)
myItem.Subject = "Testing..."
myItem.Display
'GetInspector property returns Inspector
Set myInspector = myItem.GetInspector
'Obtain the Word.Document for the Inspector
Set wdDoc = myInspector.WordEditor
If Not (wdDoc Is Nothing) Then
'Use the Range object to insert text
Set wdRange = wdDoc.Range(0, wdDoc.Characters.Count)
wdRange.InsertAfter ("Hello world!")
End If
End Sub

Infinite Loop in VBA WORD code due to Set statement

I wrote a simple code in VBA for MS WORD,
in which I want to add dot at the end of each paragraph that has no dot.
The code is as follows:
Function FindParagraph(ByVal doc As Document, ByVal Npara As String) As Paragraph
Dim para As Paragraph
For Each para In doc.Paragraphs
If para.Range.ListFormat.ListString = Npara Then
Set FindParagraph = para
End If
Next para
End Function
Sub End_para_with_dot()
Dim doc As Document
Dim tb As table
Dim prange As Range
Dim srange As Range
Dim para As Paragraph
Dim spara As Paragraph
Dim epara As Paragraph
Dim txt As String
Set doc = ActiveDocument
Set spara = FindParagraph(doc, "1")
Set epara = FindParagraph(doc, "2")
Set srange = doc.Range(spara.Range.Start, epara.Range.Start) 'sets a specific range of paragraphs in doc
For Each para In srange.Paragraphs
Set prange = para.Range
With prange
If .Style <> "Nagłówek 1" Then
Debug.Print .Text
txt = Trim(.Text)
n = Len(txt)
last_c = Mid(txt, n - 1, 1)
If last_c <> "." Then
txt = Left(txt, n - 1) & "." & Chr(13)
Debug.Print txt
End If
.Text = txt '!!!SUPPOSED REASON FOR ERROR!!!
End If
End With
Next para
End Sub
Unfortunately, after I run this code an infinite loop is produced with the first found paragraph being print all the time.
I suppose that it is due to .Text = txt line. Earlier I made a reference to the range object in this statement Set prange = para.Range. But I do not understand why when I want to reassign the .Text property of this object then the infinite loop is produced.
I would be grateful for any tip.
I'm assuming you don't want to add a . when the paragraph ends with any of !.,:;?
Try a wildcard Find/Replace, where:
Find = ([!\!.,:;\?])(^13)
Replace = \1.\2
Or, as a macro:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "([!\!.,:;\?])(^13)"
.Replacement.Text = "\1.\2"
.Format = False
.Forward = True
.Wrap = wdFindContinue
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub

Use VB within Excel to open up a Word Doc and search and replace a string which is in a text box within the word document

When my code is executed from Excel, it will open up a Word document and can replace strings in the word doc with a given value taken from the Excel file, however it will not currently replace any text that is within a Text Box in the Word doc.
Here is my code (which I took from a previous post on here) -
For Each itm In arrNames
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "C:\Users\Test\Desktop\Test.docx"
With objWord
.Activate
With objWord.Selection.Find
.Text = "Sheep"
.Replacement.Text = itm
.Forward = True
.Wrap = 2
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute Replace:=2
End With
End With
objWord.Application.ActiveDocument.SaveAs ("C:\Users\Test\Desktop\ReportPage\" & itm & ".doc")
Next itm
Are there additional arguments I need to pass into the With statement in order for text in a Text Box to also be replaced?
I was able to find a solution.
Here is the code -
Dim objWord2 As Object
Set objWord2 = CreateObject("Word.Application")
objWord2.Visible = True
objWord2.Documents.Open "C:\Users\kmccorma\Desktop\FRONTCOVER.doc"
'Iterate round a list of names
For Each itm In arrNames
Dim rngStory As Word.Range
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
Dim strText As String
' Get the text from the current TextBox
strText = rngStory.Text
'Check if the current text box contains the string you are looking for
If InStr(1, strText, "SearchText") Then
'Overwrite the text in the TextBox
rngStory.Text = itm
End If
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
If itm & "X" <> "X" Then
ActiveDocument.SaveAs ("C:\Users\kmccorma\Desktop\FrontCover\" & itm & ".doc")
End If
Next itm

Retain formatting when copying from word to outlook

I have a code which replaces the text of certain format into a hyperlink. This code works during an incoming email.
Incoming email -> copy the email to word editor(formatting lost) -> make necessary changes -> copy from word editor to outlook mail item(again replaced hyperlinks gets lost in mail item)
My code is here for your refernce..
Sub IncomingHyperlink(MyMail As MailItem)
Dim strID As String
Dim Body As String
Dim objMail As Outlook.MailItem
Dim strtemp As String
Dim RegExpReplace As String
Dim RegX As Object
Dim myObject As Object
Dim myDoc As Word.Document
Dim mySelection As Word.Selection
strID = MyMail.EntryID
Set objMail = Application.Session.GetItemFromID(strID)
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
'Set myDoc = objWord.Documents.Open("filename")
'Set objDoc = objWord.Documents.Open("C:\test.doc")
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
objSelection.TypeText "GOOD" & objMail.HTMLBody
With objSelection.Find
.ClearFormatting
.Text = "ASA[0-9][0-9][0-9][0-9][a-z][a-z]"
.Forward = True
.Wrap = wdFindAsk
.MatchWildcards = True
End With
objSelection.Find.Execute
objSelection.Hyperlinks.Add Anchor:=objSelection.Range, _
Address:="http://www.code.com/" & objSelection.Text, _
TextToDisplay:=objSelection.Text
objMail.HTMLBody = objDoc.Range(0, objDoc.Range.End)
objMail.Save
Set objMail = Nothing
End Sub
Also, this code replaces only the first occurrence of the needed text and does not replace others.
Please help solve these problems. Thank you...
In order to replace every occurrences of the regex, you can loop over the results :
With objSelection.Find
.ClearFormatting
.Text = "ASA[0-9][0-9][0-9][0-9][a-z][a-z]"
.Forward = True
.Wrap = wdFindAsk
.MatchWildcards = True
While objSelection.Find.Execute
Hyperlinks.Add Anchor:= objSelection.Range, _
Address:="http://www.code.com/" & objSelection.Text, _
TextToDisplay:=objSelection.Text
objSelection.Collapse wdCollapseEnd
Wend
End With
In order to keep your formatting, did you try (if possible) to execute your vba only in Outlook ?
Regards,
Max

Replace specific ids in body with specific hyperlinks

After my thorough homework, I am posting this question. Please help me solve this..
I want to search for ASA1234yy in the body of a text and replace it with the embedded hyperlink [ASA1234yy][1]
There can be many ids of this type in the body and each of theri hyperlinks should be unique which follows a pattern
Code done so far
Sub ConvertToHyperlink(MyMail As MailItem)
Dim strID As String
Dim Body As String
Dim objMail As Outlook.MailItem
Dim temp As String
Dim RegExpReplace As String
Dim RegX As Object
strID = MyMail.EntryID
Set objMail = Application.Session.GetItemFromID(strID)
Body = objMail.Body
Body = Body + "Test"
objMail.Body = Body
Set RegX = CreateObject("VBScript.RegExp")
With RegX
.Pattern = "ASA[0-9][0-9][0-9][0-9][a-z][a-z]"
.Global = True
.IgnoreCase = Not MatchCase
End With
RegExpReplace = RegX.Replace(Body, "http://www.code.com/ABCD")
Set RegX = Nothing
objMail.Body = RegExpReplace
objMail.Save
Set objMail = Nothing
End Sub
This code replaces the entire id only. How do I add the id to the hyperlink.
and after adding it, I need a embedded hyperlink.
thanks
Ok my modified idea below...
Hi..
I am facing two problems in the process described below..
Convert specified text extracted from Outlook mailitem to hyperlinks in word document and save it in outlook mailitem.
i.e Incoming email -> Save it in a Word Document -> Change text to hyperlinks-> Save changed WORD document to Outlook mail item
My code finds only the first occuring text in the document , and replaces it with a hyperlink and leaves the other ocurrences
After making modifications in the word document, I want to copy the contents of the document to the outlook mailitem.
Formatting getting lost if email has tables and other stuff.
My code here for you...
Sub IncomingHyperlink(MyMail As MailItem)
Dim strID As String
Dim Body As String
Dim objMail As Outlook.MailItem
Dim temp As String
Dim RegExpReplace As String
Dim RegX As Object
Dim myObject As Object
Dim myDoc As Word.Document
Dim mySelection As Word.Selection
strID = MyMail.EntryID
Set objMail = Application.Session.GetItemFromID(strID)
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
objSelection.TypeText "GOOD" & objMail.Body
With objSelection.Find
.ClearFormatting
.Text = "ASA[a-z][a-z][0-9][0-9][0-9][0-9][0-9]"
.Forward = True
.Wrap = wdFindAsk
.MatchWildcards = True
End With
'Find next instance of Pattern "ASA[a-z][a-z][0-9][0-9][0-9][0-9]"
objSelection.Find.Execute
'Replace it with a hyperlink
objSelection.Hyperlinks.Add Anchor:=objSelection.Range, _
Address:="http://www.code.com/" & objSelection.Text, _
TextToDisplay:=objSelection.Text
objDoc.SaveAs ("C:\Desktop\testdoc.doc")
objWord.Quit
objMail.Body = objSelection.Paste
objMail.Save
Set objMail = Nothing
End Sub
Can you please help solve these two problems?
Ok, I think I understand you now. You want to use named groups.
Start with this regex pattern:
(?<key>ASA\d{3}[a-z]{2})
Then, use this for the replacement pattern:
<a href=http://code.com${key}/example>${key}</a>
--dave
Suggestion: just use Word's built-in Find method.
'Set up search
With Selection.Find
.ClearFormatting
.Text = "ASA[0-9][0-9][0-9][0-9][a-z][a-z]"
.Forward = True
.Wrap = wdFindAsk
.MatchWildcards = True
End With
' Find next instance of Pattern "ASA[0-9][0-9][0-9][0-9][a-z][a-z]"
Selection.Find.Execute
' Replace it with a hyperlink
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, _
Address:="http://www.code.com/" & Selection.Text, _
TextToDisplay:=Selection.Text
The above will keep the orinigal text e.g. "ASA5534yy" and insert the hyperlink http://www.code.com/ASA5534yy (adjust as you see fit).