Hello,
I have an old code snippet here and do not know, if it still works. Try
it and fit it to your requirements:
Option Explicit
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
Public Sub OpenHyperlink()
'=========================================================================================
' Searching for Links in new mails and open them
'=========================================================================================
' Show and activate the browser window
Const SW_SHOWNORMAL As Long = 1
' Senderaddress
Const SENDER As String = "(e-mail address removed)"
'-----------------------------------------------------------------------------------------
' Variables
'-----------------------------------------------------------------------------------------
Dim objInBox As Outlook.MAPIFolder ' Inbox
Dim objItems As Outlook.Items ' All mails
from senderaddress
Dim objItem As Object ' One single
mail
Dim strBody As String ' mail content
Dim strLink As String ' Hyperlink
Dim strFilter As String ' Filter
Dim lngReturn As Long ' Returnvalue
of "ShellExexute"
'-----------------------------------------------------------------------------------------
' Does not work on saturday (god`s sabbat)
'-----------------------------------------------------------------------------------------
If Format(Date, "DDDD") = "Saturday" Then Exit Sub
'-----------------------------------------------------------------------------------------
' Reference the inbox
'-----------------------------------------------------------------------------------------
Set objInBox = Nothing
Set objInBox = Outlook.session.GetDefaultFolder(olFolderInbox)
'-----------------------------------------------------------------------------------------
' Reference all mails from senderaddress
'-----------------------------------------------------------------------------------------
strFilter = "[SenderName] = """ & SENDER & """"
Set objItems = Nothing
Set objItems = objInBox.Items.Restrict(strFilter)
'-----------------------------------------------------------------------------------------
' No mails matching?
'-----------------------------------------------------------------------------------------
If objItems.Count = 0 Then Exit Sub
'-----------------------------------------------------------------------------------------
' Get the first item
'-----------------------------------------------------------------------------------------
Set objItem = Nothing
Set objItem = objItems.GetFirst
'-----------------------------------------------------------------------------------------
' Run all items
'-----------------------------------------------------------------------------------------
Do
'-------------------------------------------------------------------------------------
' Read the body
'-------------------------------------------------------------------------------------
strBody = objItem.Body
'-------------------------------------------------------------------------------------
' Get the hyperlink
'-------------------------------------------------------------------------------------
strLink = GetHyperlink(strBody)
'-------------------------------------------------------------------------------------
' Link found?
'-------------------------------------------------------------------------------------
If strLink <> "" Then
'---------------------------------------------------------------------------------
' Open link
'---------------------------------------------------------------------------------
lngReturn = ShellExecute(0, "open", strLink & vbNullChar,
vbNullString, _
vbNullString, SW_SHOWNORMAL)
'---------------------------------------------------------------------------------
' Delete the mail if open commando was successful
'---------------------------------------------------------------------------------
If lngReturn = 42 Then objItem.Delete
End If
'-------------------------------------------------------------------------------------
' Get the next item
'-------------------------------------------------------------------------------------
Set objItem = Nothing
Set objItem = GetNextItem(objItems)
Loop While Not objItem Is Nothing
End Sub
Private Function GetNextItem(objItems As Outlook.Items) As Object
'=========================================================================================
' Returns the next item (if exists)
'=========================================================================================
On Error Resume Next
Set GetNextItem = objItems.GetNext
End Function
Private Function GetHyperlink(ByVal strBody As String) As String
'=========================================================================================
' Returns the first hyperlink in a mail (the hyperling have to be
on the beginning of a line)
'=========================================================================================
Dim aryBody() As String
Dim intIndex As Integer
'-----------------------------------------------------------------------------------------
' Split body in rows
'-----------------------------------------------------------------------------------------
aryBody() = Split(strBody, vbCrLf)
'-----------------------------------------------------------------------------------------
' Does we have at least 1 row?
'-----------------------------------------------------------------------------------------
If UBound(aryBody()) > -1 Then
'-------------------------------------------------------------------------------------
' Search the 1. hyperlink
'-------------------------------------------------------------------------------------
For intIndex = 0 To UBound(aryBody())
'---------------------------------------------------------------------------------
' Hyperlink found?
'---------------------------------------------------------------------------------
If Left(Trim(aryBody(intIndex)), 7) = "http://" Then
'-----------------------------------------------------------------------------
' Return hyperlink and get out
'-----------------------------------------------------------------------------
GetHyperlink = aryBody(intIndex): Exit Function
End If
Next
End If
End Function
