VBA Rule for removing all body but hyperlink then forwarding

[Majunga]

I want to create an Outlook rule using a script that will forward an e-mail to my cell phone, keeping the same subject, and removing the majority of the body of the e-mail. The only part of the body I'd like to keep is a hyperlink, and the hyperlink can be listed in two ways: 1) a standard hyperlink (i.e. https://www.google.com) and 2) a hyperlink embedded in text (i.e. Google).

I'm currently using a script that does half of this. It forwards the e-mail but removes the body. It may be easiest just to modify my existing script. Here's the code:

Public Sub SMS(msg As MailItem)

  Dim olMailFwd As MailItem

  Set olMailFwd = msg.Forward

  With olMailFwd
      .HTMLBody = ""
      .Subject = msg.Subject
      .To = "5551234567@carrier.com" 'enter phone number e-mail address here
  End With

  olMailFwd.Send

  Set olMailFwd = Nothing

End Sub

I tried adapting the code found here under the "Find a code in the message body, then forward" section: Run a Script Rule: Change Subject then Forward Message, but even when I try to use this code unmodified, I get an error saying " Run-time error '5': Invalid procedure call or argument. When I debug, it highlights this line of code:

Item.Subject = M.SubMatches(1) & "; " & Item.Subject

 

[Majunga]

Sorry about the code tags. Whenever I tried to add them, I received an error.

 

[Diane Poremsky]

there is a bug in a recent forum update - inserting urls only works if http:// is removed - I wasn't aware code tags also failed.

This shows how to find links and assign the link to a variable, which you can then insert into the body using .body = strurl.
Open All Hyperlinks in an Outlook Email Message

the macro at Run a Script Rule: Change Subject then Forward Message is similar - you just need the correct pattern and put it in the body, not subject.

I'll have to see if we can pick up hyperlinks using word vba - if so, it would be embedded just as it appears in the email.

 

[Diane Poremsky]

I get an error saying " Run-time error '5': Invalid procedure call or argument. When I debug, it highlights this line of code:

Item.Subject = M.SubMatches(1) & "; " & Item.Subject

it's likely because there is no pattern match. oh, or its because you didn't set a reference to the regex object library.: Microsoft VBScript Regular Expressions 5.5

 

[Majunga]

there is a bug in a recent forum update - inserting urls only works if http:// is removed - I wasn't aware code tags also failed.

This shows how to find links and assign the link to a variable, which you can then insert into the body using .body = strurl.
Open All Hyperlinks in an Outlook Email Message

the macro at Run a Script Rule: Change Subject then Forward Message is similar - you just need the correct pattern and put it in the body, not subject.

I'll have to see if we can pick up hyperlinks using word vba - if so, it would be embedded just as it appears in the email.

I must have done something wrong. While I'm not getting any errors and the message is forwarding, it is forwarding with a blank body. Here's the code:

Public Sub SMStest(msg As MailItem)

    Dim olMailFwd As MailItem
    Dim Reg1 As RegExp
    Dim M1 As MatchCollection
    Dim M As Match
    Dim strURL As String
 
Set Reg1 = New RegExp

With Reg1
    .Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)>"
    .Global = True
    .IgnoreCase = True
End With

If Reg1.Test(msg.Body) Then

Set M1 = Reg1.Execute(msg.Body)
    For Each M In M1
        strURL = M.SubMatches(0)
        Debug.Print strURL

Next
End If

Set olMailFwd = msg.Forward

   With olMailFwd
       .HTMLBody = stURL
       .Subject = msg.Subject
       .To = "5551234567@carrier.com" 'enter phone number e-mail address here
   End With

olMailFwd.Send

Set olMailFwd = Nothing
Set Reg1 = Nothing


End Sub

 

[Diane Poremsky]

I'm not going to comment on how long it took me to see the problem... but
.HTMLBody = stURL is spelled wrong, it should be strURL.

you might need to use .Body = strURL if its not clickable.

The code gets the last url - to get the first, use
.Global = False

 

[Majunga]

Yup, I ended up writing the script over again and realized that was the problem after I mistakenly typed it wrong a second time.

So, it's working now that I've made that correction. How difficult do you think it would be to modify it further so that it can pull multiple hyperlinks from the e-mail instead of just one, and send those hyperlinks in one single forward?

 

[Diane Poremsky]

This variation gets the last link and pastes it as formatted text (embedded link)

Dim olMailFwd As MailItem
Dim objInsp As Outlook.Inspector
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim objSel As Word.Selection
On Error Resume Next

Set olMailFwd = msg.Forward

With olMailFwd
.Subject = msg.Subject
.To = "5551234567@carrier.com" 'enter phone number e-mail address here
End With
Set objInsp = olMailFwd.GetInspector
If objInsp.EditorType = olEditorWord Then
Set objDoc = objInsp.WordEditor
Set objWord = objDoc.Application
Set objSel = objWord.Selection
With objSel
.WholeStory

Dim H As Word.Hyperlink
For Each H In objDoc.Hyperlinks
H.Range.Select
.Copy
Next H
End With
End If
olMailFwd.Body = ""

objSel.PasteAndFormat (wdFormatOriginalFormatting)

olMailFwd.Display

Set olMailFwd = Nothing

End Sub

 

[Diane Poremsky]

BTW, to test the code (or any run a script code) without sending messages, you can use this stub - select a message then run this code to call the macro.

Sub RunScript()
Dim objApp As Outlook.Application
Dim objItem As MailItem
Set objApp = Application
Set objItem = objApp.ActiveExplorer.Selection.Item(1)

'macro name you want to run goes here
SMStest objItem

End Sub

Also, because the macro in the message above doesn't check for http, it gets the last link, which could be a mailto.

You can use something like this to filter for a word in the address -
If InStr(lcase(H.Address), "word") <> 0 Then
.copy
end if

 

[Diane Poremsky]

How difficult do you think it would be to modify it further so that it can pull multiple hyperlinks from the e-mail instead of just one, and send those hyperlinks in one single forward?

Not hard - you just need to tweak it - with the strURL code, do something like
strURL = strURL & vbcrlf & M.SubMatches(0)

The word code sample is a little more difficult - you need to scan the original message and write he links as you go.