Adjusting to work in VBA 64 bit

[jet8510]

Can some one help me having issues getting this to work since i upgraded to 64 bit

Option Explicit


Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Longptr, _
ByVal Operation As String, _
ByVal Filename As String, _
Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Longptr = vbMinimizedFocus _
) As Longptr






Sub Xmatterclick(MyMail As Outlook.MailItem)

Dim strID As String
Dim olMail As Outlook.MailItem
strID = MyMail.EntryID
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim strURL As String
Dim lSuccess As LongPtr


Set olMail = Application.Session.GetItemFromID(strID)
olMail.Save

Set Reg1 = New RegExp

With Reg1
.Pattern = "Accept <(.*)>"
.Global = False
.IgnoreCase = True
End With


If Reg1.test(olMail.Body) Then
Set M1 = Reg1.Execute(olMail.Body)
'Debug.Print "Hello"
For Each M In M1
strURL = M.SubMatches(0)
'Debug.Print strURL
If InStr(strURL, "unsubscribe") Then GoTo NextURL
If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)

lSuccess = ShellExecute(0, "Open", strURL)


Debug.Print strURL
Debug.Print DateTime.Now

NextURL:
Next
End If



Set Reg1 = Nothing

'Set lSuccess = Nothing




End Sub


Sub test()

End Sub

 

[CJ_London]

See similar threads at the bottom of this one - at least two that I can see

 

[Pat Hartman]

Welcome aboard. This is your very first post So I get to tell you about our search feature. To start with take a look at the similar threads below.

 

[jet8510]

I am not very good at coding and was hopening someone could take a look over my example above and help me fix it so that it would work on 64 bit system

 

[arnelgp]

maybe something like this:

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Longptr, _
ByVal Operation As String, _
ByVal Filename As String, _
Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long = vbMinimizedFocus _
) As LongPtr
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, _
ByVal Operation As String, _
ByVal Filename As String, _
Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long = vbMinimizedFocus _
) As Long
#End If

Sub Xmatterclick(MyMail As Outlook.MailItem)
Dim strID As String
Dim olMail As Outlook.MailItem
strID = MyMail.EntryID
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim strURL As String
#If VBA7 Then
    Dim lSuccess As LongPtr
#Else
    Dim lSuccess As Long
#End If

Set olMail = Application.Session.GetItemFromID(strID)
olMail.Save

Set Reg1 = New RegExp

With Reg1
    .Pattern = "Accept <(.*)>"
    .Global = False
    .IgnoreCase = True
End With


If Reg1.test(olMail.Body) Then
    Set M1 = Reg1.Execute(olMail.Body)
    'Debug.Print "Hello"
    For Each M In M1
        strURL = M.SubMatches(0)
        'Debug.Print strURL
        If InStr(strURL, "unsubscribe") Then GoTo NextURL
        If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)

        lSuccess = ShellExecute(0, "Open", strURL)


        Debug.Print strURL
        Debug.Print DateTime.Now

NextURL:
    Next
End If



Set Reg1 = Nothing

'Set lSuccess = Nothing




End Sub


Sub test()

End Sub

 

[jet8510]

maybe something like this:

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Longptr, _
ByVal Operation As String, _
ByVal Filename As String, _
Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long = vbMinimizedFocus _
) As LongPtr
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, _
ByVal Operation As String, _
ByVal Filename As String, _
Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long = vbMinimizedFocus _
) As Long
#End If

Sub Xmatterclick(MyMail As Outlook.MailItem)
Dim strID As String
Dim olMail As Outlook.MailItem
strID = MyMail.EntryID
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim strURL As String
#If VBA7 Then
    Dim lSuccess As LongPtr
#Else
    Dim lSuccess As Long
#End If

Set olMail = Application.Session.GetItemFromID(strID)
olMail.Save

Set Reg1 = New RegExp

With Reg1
    .Pattern = "Accept <(.*)>"
    .Global = False
    .IgnoreCase = True
End With


If Reg1.test(olMail.Body) Then
    Set M1 = Reg1.Execute(olMail.Body)
    'Debug.Print "Hello"
    For Each M In M1
        strURL = M.SubMatches(0)
        'Debug.Print strURL
        If InStr(strURL, "unsubscribe") Then GoTo NextURL
        If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)

        lSuccess = ShellExecute(0, "Open", strURL)


        Debug.Print strURL
        Debug.Print DateTime.Now

NextURL:
    Next
End If



Set Reg1 = Nothing

'Set lSuccess = Nothing




End Sub


Sub test()

End Sub

That works thank you so much