Outlook 365 Outlook/VBA

eflats

New Member
Outlook version
Outlook 2016 64 bit
Email Account
IMAP
Hi I am fairly new to VBA and using it in outlook. Found this tutorial but cant seem to isolate the link I want to click in the email. Please help
 

eflats

New Member
Outlook version
Outlook 2016 64 bit
Email Account
IMAP
get the message source, put it in a text file and post it in this thread - I'll take a look.
I basically am using code I found on here. I mean it works and ive added some ignore lines like I saw you post. But I feel like there has to be a way to isolate the link since every single email I get is the same with an accept button then it opens a page with further options I would love to have an automatic interaction take place once the new tab opens. Also is there a way to have this script scan all inboxes and play once email is received not opened?

Here is the link from the email less the unique identifiers....
choicehomewarranty.com/cads/accept.php?


Code:
Sub OpenLinksMessage()
 Dim olMail As Outlook.MailItem
 Dim Reg1 As RegExp
 Dim M1 As MatchCollection
 Dim M As Match
 Dim strURL As String
 Dim lSuccess As Long

Set olMail = Application.ActiveExplorer().Selection(1)
Set Reg1 = New RegExp

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

If Reg1.Test(olMail.Body) Then
Set M1 = Reg1.Execute(olMail.Body)
 For Each M In M1
   strURL = M.SubMatches(0)
    Debug.Print strURL
   If InStr(strURL, "unsubscribe") Then GoTo NextURL
   If InStr(strURL, "http://www.choicehomewarranty.com/cads/images/logo.png") Then GoTo NextURL
   If InStr(strURL, "http://www.choicehomewarranty.com/cads/images/wo.png") Then GoTo NextURL
   If InStr(strURL, "https://my.choicehomewarranty.com/images/spacer.png") Then GoTo NextURL
   If InStr(strURL, "http://www.choicehomewarranty.com/cads/images/checkmark2.jpg") Then GoTo NextURL
   If InStr(strURL, "http://www.choicehomewarranty.com/cads/images/xmark2.jpg") Then GoTo NextURL
   If InStr(strURL, "http://www.choicehomewarranty.com/cads/decline.php*") Then GoTo NextURL
If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
   lSuccess = ShellExecute(0, "Open", strURL)

  DoEvents
NextURL:
  Next
  End If
Set Reg1 = Nothing
 End Sub
 
Last edited by a moderator:

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
These lines
If InStr(strURL, "http://www.choicehomewarranty.com/cads/images/xmark2.jpg") Then GoTo NextURL

could be condensed to one line -
If InStr(strURL, "http://www.choicehomewarranty.com/cads/images/") Then GoTo NextURL

or even something like this:
If InStr(strURL, "cads/images/") Then GoTo NextURL


What does the debug.print strurl show for the urls? Show the immediate window to view - or after the If Right(strURL, 1) = line, add msgbox strurl to display it in a message box before opening it. That way you can see if it is properly formed.

another option is to use something like this instead of listing all the lines.
If InStr(strURL, "SWO Accept") Then
msgbox strurl ' during testing, to verify the link looks good
lSuccess = ShellExecute(0, "Open", strURL)
end If
 

eflats

New Member
Outlook version
Outlook 2016 64 bit
Email Account
IMAP
These lines
If InStr(strURL, "http://www.choicehomewarranty.com/cads/images/xmark2.jpg") Then GoTo NextURL

could be condensed to one line -
If InStr(strURL, "http://www.choicehomewarranty.com/cads/images/") Then GoTo NextURL

or even something like this:
If InStr(strURL, "cads/images/") Then GoTo NextURL


What does the debug.print strurl show for the urls? Show the immediate window to view - or after the If Right(strURL, 1) = line, add msgbox strurl to display it in a message box before opening it. That way you can see if it is properly formed.

another option is to use something like this instead of listing all the lines.
If InStr(strURL, "SWO Accept") Then
msgbox strurl ' during testing, to verify the link looks good
lSuccess = ShellExecute(0, "Open", strURL)
end If
Can you show me what you mean? I tried to enter that bit of code where I thought it belonged but it did nothing for me. Also maybe show where debug.print would go to verify the info you are looking for?
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
This should work - you only need one of the strURL blocks - should be able to test it with both blocks to verify each works as expected. If there is only one url to open, you can exit the sub when found

Code:
Sub OpenLinksMessage()
Dim olMail As Outlook.MailItem
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim strURL As String
Dim lSuccess As Long

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

Set Reg1 = New RegExp

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

If Reg1.Test(olMail.Body) Then

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

' Either this block
If InStr(strURL, "unsubscribe") Then GoTo NextURL
If InStr(strURL, "cads/images/") Then GoTo NextURL
If InStr(strURL, "http://www.choicehomewarranty.com/cads/decline.php*") Then GoTo NextURL
If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
msgbox strurl ' during testing, to verify the link looks good
Debug.Print strURL
lSuccess = ShellExecute(0, "Open", strURL)
'end block

' or this block should work
If InStr(strURL, "http://www.choicehomewarranty.com/cads/accept.php") Then
msgbox strurl ' during testing, to verify the link looks good
Debug.Print strURL
lSuccess = ShellExecute(0, "Open", strURL)
exit sub ' if there is only one link yo open, exit sub once its found
end If
' end block


DoEvents

NextURL:
Next
End If

Set Reg1 = Nothing
End Sub
 

eflats

New Member
Outlook version
Outlook 2016 64 bit
Email Account
IMAP
This should work - you only need one of the strURL blocks - should be able to test it with both blocks to verify each works as expected. If there is only one url to open, you can exit the sub when found

Code:
Sub OpenLinksMessage()
Dim olMail As Outlook.MailItem
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim strURL As String
Dim lSuccess As Long

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

Set Reg1 = New RegExp

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

If Reg1.Test(olMail.Body) Then

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

' Either this block
If InStr(strURL, "unsubscribe") Then GoTo NextURL
If InStr(strURL, "cads/images/") Then GoTo NextURL
If InStr(strURL, "http://www.choicehomewarranty.com/cads/decline.php*") Then GoTo NextURL
If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
msgbox strurl ' during testing, to verify the link looks good
Debug.Print strURL
lSuccess = ShellExecute(0, "Open", strURL)
'end block

' or this block should work
If InStr(strURL, "http://www.choicehomewarranty.com/cads/accept.php") Then
msgbox strurl ' during testing, to verify the link looks good
Debug.Print strURL
lSuccess = ShellExecute(0, "Open", strURL)
exit sub ' if there is only one link yo open, exit sub once its found
end If
' end block


DoEvents

NextURL:
Next
End If

Set Reg1 = Nothing
End Sub
Very cool so it makes me accept via a popup. Can be handy. My end goal is for this to run immediately once an email is received. Then further accept and schedule from a radio button selection in the new browser tab.

So with this code I get three popups all of which I have to ok before the tab opens first one is not relevant. Its https://my.choicehomewarranty.com/images/spacer.png then the second two are the outcome of clicking on accept and are identical.
 

eflats

New Member
Outlook version
Outlook 2016 64 bit
Email Account
IMAP
Very cool so it makes me accept via a popup. Can be handy. My end goal is for this to run immediately once an email is received. Then further accept and schedule from a radio button selection in the new browser tab.

So with this code I get three popups all of which I have to ok before the tab opens first one is not relevant. Its https://my.choicehomewarranty.com/images/spacer.png then the second two are the outcome of clicking on accept and are identical.
I was hoping all this would fully automate
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
o with this code I get three popups all of which I have to ok before the tab opens first one is not relevant. Its https://my.choicehomewarranty.com/images/spacer.png then the second two are the outcome of clicking on accept and are identical.
The msgbox are just for testing- comment out or remove those lines, like this:

' msgbox strurl ' during testing, to verify the link looks good
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
BTW - what are the 3? I only see 2 msgbox lines - both of which should have the url you want to open.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Is the url in twice?

it will ask twice in the either or blocks - but the second one exists when a match is found.
' Either this block
' or this block should work

try removing the first block and see if it only comes up once. If so, that is the one you want to use.
 
Similar threads
Thread starter Title Forum Replies Date
J VBA for outlook to compare and sync between calendar Outlook VBA and Custom Forms 1
E Outlook VBA change GetDefaultFolder dynamically Outlook VBA and Custom Forms 6
S vba outlook search string with special characters Outlook VBA and Custom Forms 1
U Outlook 2019 VBA run-time error 424 Outlook VBA and Custom Forms 2
G VBA to save selected Outlook msg with new name in selected network Windows folder Outlook VBA and Custom Forms 1
F Excel VBA to move mails for outlook 365 on secondary mail account Outlook VBA and Custom Forms 1
K Outlook Office 365 VBA download attachment Outlook VBA and Custom Forms 2
V vBA for searching a cell's contents in Outlook and retrieving the subject line Outlook VBA and Custom Forms 1
B vBA for exporting excel file from outlook 2016 Outlook VBA and Custom Forms 3
S Excel vba code to manage outlook web app Using Outlook 10
H Custom Outlook Contact Form VBA Outlook VBA and Custom Forms 1
S Problem Checking the available stores in my Inbox (Outlook VBA) Outlook VBA and Custom Forms 0
S Outlook VBA How to adapt this code for using in a different Mail Inbox Outlook VBA and Custom Forms 0
O VBA Outlook Message Attachment - Array Index Out of Bounds Outlook VBA and Custom Forms 0
J Want to learn VBA Macros for Outlook. What book can you recommend? Outlook VBA and Custom Forms 2
M Outlook 2013 reminder email by using Outlook vba Outlook VBA and Custom Forms 2
D Outlook VBA error extracting property data from GetRules collection Outlook VBA and Custom Forms 10
O Email not leaving Outbox when using Excel VBA to sync Outlook account Outlook VBA and Custom Forms 4
L Moving emails with similar subject and find the timings between the emails using outlook VBA macro Outlook VBA and Custom Forms 1
B Outlook Business Contact Manager with SQL to Excel, User Defined Fields in BCM don't sync in SQL. Can I use VBA code to copy 1 field to another? BCM (Business Contact Manager) 0
N How can I increase/faster outlook VBA Macro Speed ? Using Outlook 2
N Outlook Email Rule execution through shortcut keys (VBA codes) Using Outlook 1
A VBA Code in Outlook disappears after first use Outlook VBA and Custom Forms 1
dweller Outlook 2010 Rule Ignores VBA Script Outlook VBA and Custom Forms 2
G Outlook VBA and Google Calendar ("Events") Outlook VBA and Custom Forms 1
J VBA Outlook : Subject line : Cut and Paste name to heading , number to very end of the body of Email Outlook VBA and Custom Forms 1
B Advanced Search in MS Outlook by VBA and SQL Outlook VBA and Custom Forms 2
K Outlook Archive to PST Files by Date Range VBA Script? Outlook VBA and Custom Forms 1
J Help Please!!! Outlook 2016 - VBA Macro for replying with attachment in meeting invite Outlook VBA and Custom Forms 9
S Find a cell value in excel using outlook vba Using Outlook 1
J Execute Add-In Button from VBA Outlook 2016 Outlook VBA and Custom Forms 1
J Open an outlook email by Subject on MS Access linked table with VBA Outlook VBA and Custom Forms 10
D create an html table in outlook custom form 2010 using vba in MsAccess Outlook VBA and Custom Forms 7
M Slow VBA macro in Outlook Outlook VBA and Custom Forms 5
T Outlook AntiSpam with VBA Outlook VBA and Custom Forms 1
F "Move to" O365 feature to Outlook client via VBA Outlook VBA and Custom Forms 4
B query outlook using vba Outlook VBA and Custom Forms 13
J VBA to switch Outlook online/offline Outlook VBA and Custom Forms 4
M VBA to change flag status in outlook contact item Outlook VBA and Custom Forms 3
T VBA outlook, detect priority emails Outlook VBA and Custom Forms 5
C Need VBA code to automatically save message outside outlook and add date Outlook VBA and Custom Forms 1
stephen li VBA Outlook send mail automatically by specified outlook mail box Outlook VBA and Custom Forms 1
S Outlook VBA Contacts Notes Outlook VBA and Custom Forms 0
O VBA to Run Font Change on Outlook Startup Outlook VBA and Custom Forms 4
P Outlook 2007 Email Categorization using VBA Outlook VBA and Custom Forms 1
O VBA or other solution for Outlook tasks to OneNote Outlook VBA and Custom Forms 0
S Automatically selecting folders and deleting messages in Outlook VBA Outlook VBA and Custom Forms 7
D Creating an outlook session from Access vba but run silently. With A specific profile Outlook VBA and Custom Forms 1
Diane Poremsky Outlook VBA: Use a Text File to Populate a ListBox Using Outlook 0
C Saving Outlook attachments and links to attachments with VBA Outlook VBA and Custom Forms 2

Similar threads

Top