Outlook "Run Script" rule not triggering VBA script for incoming messages - vba

I am creating this new topic on the advice of another member. For additional history regarding how things arrived at this point see this question.
I have this VBA script, that I know works if it gets triggered. If I use the TestLaunch subroutine with a message already in my inbox that meets the rule criteria (but, of course, isn't being kicked off by the rule) it activates the link I want it to activate flawlessly. If, when I create the rule I say to apply it to all existing messages in my inbox, it works flawlessly. However, where it's needed, when new messages arrive it does not.
I know that the script is not being triggered because if I have a rule like this:
Outlook "New Message" rule that has "play sound" enabled
with "Play a sound" as part of it, the sound always plays when a message arrives from either of the two specified senders, so the rule is being triggered. I have removed the sound playing part from the rule, and integrated it into the VBA code for testing purposes instead:
Option Explicit
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
Private Declare Function sndPlaySound32 _
Lib "winmm.dll" _
Alias "sndPlaySoundA" ( _
ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
Sub PlayTheSound(ByVal WhatSound As String)
If Dir(WhatSound, vbNormal) = "" Then
' WhatSound is not a file. Get the file named by
' WhatSound from the Windows\Media directory.
WhatSound = Environ("SystemRoot") & "\Media\" & WhatSound
If InStr(1, WhatSound, ".") = 0 Then
' if WhatSound does not have a .wav extension,
' add one.
WhatSound = WhatSound & ".wav"
End If
If Dir(WhatSound, vbNormal) = vbNullString Then
Beep ' Can't find the file. Do a simple Beep.
Exit Sub
End If
Else
' WhatSound is a file. Use it.
End If
sndPlaySound32 WhatSound, 0& ' Finally, play the sound.
End Sub
Public Sub OpenLinksMessage(olMail As Outlook.MailItem)
Dim Reg1 As RegExp
Dim AllMatches As MatchCollection
Dim M As Match
Dim strURL As String
Dim RetCode As Long
Set Reg1 = New RegExp
With Reg1
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
.Global = True
.IgnoreCase = True
End With
PlayTheSound "chimes.wav"
' If the regular expression test for URLs in the message body finds one or more
If Reg1.test(olMail.Body) Then
' Use the RegEx to return all instances that match it to the AllMatches group
Set AllMatches = Reg1.Execute(olMail.Body)
For Each M In AllMatches
strURL = M.SubMatches(0)
' Don't activate any URLs that are for unsubscribing; skip them
If InStr(1, strURL, "unsubscribe") Then GoTo NextURL
' If the URL ends with a > from being enclosed in darts, strip that > off
If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
' The URL to activate to accept must contain both of the substrings in the IF statement
If InStr(1, strURL, ".com") Then
PlayTheSound "TrainWhistle.wav"
' Activate that link to accept the job
RetCode = ShellExecute(0, "Open", "http://nytimes.com")
Set Reg1 = Nothing
Exit Sub
End If
NextURL:
Next
End If
Set Reg1 = Nothing
End Sub
Private Sub TestLaunchURL()
Dim currItem As MailItem
Set currItem = ActiveExplorer.Selection(1)
OpenLinksMessage currItem
End Sub
which should play "chimes.wav" if the VBA script is triggered in all cases and play "TrainWhistle.wav" if my actual link activation processing occurs. When new messages arrive, neither happens, yet if there is a "Play sound" on the Outlook rule that should run this script that sound gets played.
At the moment I have the Trust Center settings for macros to allow all, as Outlook was being cranky about signing that used selfcert.exe earlier in the testing process. I would really like to be able to elevate the macro protections again rather than leave them at "run all" when this is all done.
But, first and foremost, I cannot for the life of me figure out why this script will run perfectly via the debugger or if applied to existing messages, but is not triggered by the very same Outlook rule applied to existing messages when an actual new message arrives. This is true under Outlook 2010, where I'm developing this script, and also under Outlook 2016, on a friend's machine where it's being deployed.
Any guidance on resolving this issue would be most appreciated.

Here is the code that finally works. It's clear that the .Body member of olMail is not available until some sort of behind the scenes processing has had time to occur and if you don't wait long enough it won't be there when you go to test using it. Focus on the Public Sub OpenLinksMessage
The major change that allowed that processing to take place, apparently, was the addition of the line of code: Set InspectMail = olMail.GetInspector.CurrentItem. The time it takes for this set statement to run allows the .Body to become available on the olMail parameter that's passed in by the Outlook rule. What's interesting is that if you immediately display InspectMail.Body after the set statement it shows as empty, just like olMail.Body used to.
Option Explicit
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
Public Sub OpenLinksMessage(olMail As Outlook.MailItem)
Dim InspectMail As Outlook.MailItem
Dim Reg1 As RegExp
Dim AllMatches As MatchCollection
Dim M As Match
Dim strURL As String
Dim SnaggedBody As String
Dim RetCode As Long
' The purpose of the following Set statement is strictly to "burn time" so that the .Body member of
' olMail is available by the time it is needed below. Without this statement the .Body is consistently
' showing up as empty. What's interesting is if you use MsgBox to display InspectMail.Body immediately after
' this Set statement it shows as empty.
Set InspectMail = olMail.GetInspector.CurrentItem
Set Reg1 = New RegExp
With Reg1
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
.Global = True
.IgnoreCase = True
End With
RetCode = Reg1.Test(olMail.Body)
' If the regular expression test for URLs in the message body finds one or more
If RetCode Then
' Use the RegEx to return all instances that match it to the AllMatches group
Set AllMatches = Reg1.Execute(olMail.Body)
For Each M In AllMatches
strURL = M.SubMatches(0)
' Don't activate any URLs that are for unsubscribing; skip them
If InStr(1, strURL, "unsubscribe") Then GoTo NextURL
' If the URL ends with a > from being enclosed in darts, strip that > off
If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
' The URL to activate to accept must contain both of the substrings in the IF statement
If InStr(1, strURL, ".com") Then
' Activate that link to accept the job
RetCode = ShellExecute(0, "Open", strURL)
Set InspectMail = Nothing
Set Reg1 = Nothing
Set AllMatches = Nothing
Set M = Nothing
Exit Sub
End If
NextURL:
Next
End If
Set InspectMail = Nothing
Set Reg1 = Nothing
Set AllMatches = Nothing
Set M = Nothing
End Sub
Special thanks to niton for his patience and assistance.

Related

Return focus to ThisWorkbook.Activesheet after XMLHTTP60 file download

Situation:
I am unable to return focus to the Excel application after initiating a file download.
My usual tricks of AppActivate and Application.hwnd , when working between applications, don't seem to be working this time. I haven't had a problem doing this before so don't know if I am being particularly dense today, or, it is because I am involving a browser for the first time. I suspect it is the former.
Questions:
1) Can any one see where I am going wrong (why focus does not shift back to Excel)?
2) More importantly: Is there a way to download files in the background, using the default browser, keeping the focus on ThisWorkbook and thereby avoiding the issue altogether?
I am using a workaround of SendKeys "%{F4}" immediately after the download, at present, to close the browser and so am defaulting back to Excel.
Note: The default browser in my case is Google Chrome but clearly could be any browser.
What I have tried:
1) From #user1452705; focus didn't shift:
Public Declare Function SetForegroundWindow _
Lib "user32" (ByVal hwnd As Long) As Long
Public Sub Bring_to_front()
Dim setFocus As Long
ThisWorkbook.Worksheets("Sheet1").Activate
setfocus = SetForegroundWindow(Application.hwnd)
End Sub
2) Then I tried:
ThisWorkbook.Activate 'No shift in focus
Windows(ThisWorkbook.Name).Activate 'Nothing happened
Application.Windows(ThisWorkbook.Name & " - Excel").Activate 'Subscript out of range
3) AppActivate using Title as actually displayed in Window:
AppActivate "AmbSYS_testingv14.xlsm" & " - Excel" 'Nothing happened
4) More desperate attempts:
AppActivate Application.Caption 'Nothing happened
AppActivate ThisWorkbook.Name & " - Excel" 'Nothing happened
AppActivate ThisWorkbook.Name 'Nothing happened
AppActivate "Microsoft Excel" 'Invalid proc call
4) Finally, the current version of my code is using #ChipPearson's sub ActivateExcel , which also has no effect:
Module 1:
Public Sub DownloadFiles()
'Tools > ref> MS XML and HTML Object lib
Dim http As XMLHTTP60
Dim html As HTMLDocument
Set http = New XMLHTTP60
Set html = New HTMLDocument
With http
.Open "GET", "https://www.england.nhs.uk/statistics/statistical-work-areas/ambulance-quality-indicators/ambulance-quality-indicators-data-2017-18/", False
.send
html.body.innerHTML = .responseText
End With
'Test Download code
html.getElementsByTagName("p")(4).getElementsByTagName("a")(0).Click
' Application.Wait Now + TimeSerial(0, 0, 3) 'pause for downloads to finish before files
'Other code
ActivateExcel
End Sub
Module 2:
Option Explicit
Option Compare Text
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modActivateExcel
' By Chip Pearson, www.cpearson.com, chip#cpearson.com
' http://www.cpearson.com/excel/ActivateExcelMain.aspx
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Window API Declarations
' These Declares MUST appear at the top of the
' code module, above and before any VBA procedures.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare PtrSafe Function BringWindowToTop Lib "user32" ( _
ByVal HWnd As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function SetFocus Lib "user32" ( _
ByVal HWnd As Long) As Long
Public Sub ActivateExcel()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ActivateExcel
' This procedure activates the main Excel application window,
' ("XLMAIN") moving it to the top of the Z-Order and sets keyboard
' focus to Excel.
'
' !!!!!!!!!!!!!!!!!!!!!!!!!
' NOTE: This will not work properly if a VBA Editor is open.
' If a VBA Editor window is open, the system will set focus
' to that window, rather than the XLMAIN window.
' !!!!!!!!!!!!!!!!!!!!!!!!!
'
' This code should be able to activate the main window of any
' application whose main window class name is known. Just change
' the value of C_MAIN_WINDOW_CLASS to the window class of the
' main application window (e.g., "OpusApp" for Word).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Res As Long ' General purpose Result variable
Dim XLHWnd As Long ' Window handle of Excel
Const C_MAIN_WINDOW_CLASS = "XLMAIN"
'''''''''''''''''''''''''''''''''''''''''''
' Get the window handle of the main
' Excel application window ("XLMAIN"). If
' more than one instance of Excel is running,
' you have no control over which
' instance's HWnd will be retrieved.
' Related Note: You MUST use vbNullString
' not an empty string "" in the call to
' FindWindow. When calling API functions
' there is a difference between vbNullString
' and an empty string "".
''''''''''''''''''''''''''''''''''''''''''
XLHWnd = FindWindow(lpClassName:=C_MAIN_WINDOW_CLASS, _
lpWindowName:=vbNullString)
If XLHWnd > 0 Then
'''''''''''''''''''''''''''''''''''''''''
' If HWnd is > 0, FindWindow successfully
' found the Excel main application window.
' Move XLMAIN to the top of the
' Z-Order.
'''''''''''''''''''''''''''''''''''''''''
Res = BringWindowToTop(HWnd:=XLHWnd)
If Res = 0 Then
Debug.Print "Error With BringWindowToTop: " & _
CStr(Err.LastDllError)
Else
'''''''''''''''''''''''''''''''''
' No error.
' Set keyboard input focus XLMAIN
'''''''''''''''''''''''''''''''''
SetFocus HWnd:=XLHWnd
End If
Else
'''''''''''''''''''''''''''''''''
' HWnd was 0. FindWindow couldn't
' find Excel.
'''''''''''''''''''''''''''''''''
Debug.Print "Can't find Excel"
End If
End Sub
Additional references:
1) Toggle between Excel and IE
2) VBA API declarations. Bring window to front , regardless of application ; link also in main body
3) Return focus to excel after finishing downloading file with Internet explorer
4) Set focus back to the application window after showing userform
5) Close the application with sendkeys like ALt F4
Thanks to #OmegaStripes and #FlorentB for their input.
Using #OmegaStripes suggested method I:
Use XMLHTTP to get binary response content
Convert to UTF-8
Parse to extract the required URL
Use a new XMLHTTP to download binary
Use ADODB.Stream to write out file
Works a treat and no problems with shift in focus.
Notes: For step 3, I used the approach by #KarstenW to write the string , the converted responseText string, out to a txt file for examination to determine how to access the URL of interest.
Option Explicit
Public Const adSaveCreateOverWrite As Byte = 2
Public Const url As String = "https://www.england.nhs.uk/statistics/statistical-work-areas/ambulance-quality-indicators/ambulance-quality-indicators-data-2017-18/"
Public Const adTypeBinary As Byte = 1
Public Const adTypeText As Byte = 2
Public Const adModeReadWrite As Byte = 3
Public Sub DownLoadFiles()
Dim downLoadURL As String
Dim aBody As String
' Download via XHR
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", url, False
.send
' Get binary response content
aBody = BytesToString(.responseBody, "UTF-8")
End With
Dim respTextArr() As String
respTextArr = Split(Split(aBody, "New AmbSYS Indicators")(0))
downLoadURL = Split(respTextArr(UBound(respTextArr)), Chr$(34))(1)
Dim urlArr() As String
Dim fileName As String
Dim bBody As Variant
Dim sPath As String
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", downLoadURL, False
.send
urlArr = Split(downLoadURL, "/")
fileName = urlArr(UBound(urlArr))
bBody = .responseBody
sPath = ThisWorkbook.Path & "\" & fileName
End With
' Save binary content to the xls file
With CreateObject("ADODB.Stream")
.Type = 1
.Open
.Write bBody
.SaveToFile sPath, adSaveCreateOverWrite
.Close
End With
' Open saved workbook
With Workbooks.Open(sPath, , False)
End With
End Sub
Public Function BytesToString(ByVal bytes As Variant, ByVal charset As String) As String
With CreateObject("ADODB.Stream")
.Mode = adModeReadWrite
.Type = adTypeBinary
.Open
.Write bytes
.Position = 0
.Type = adTypeText
.charset = charset
BytesToString = .ReadText
End With
End Function
For Excel 2013 please see here a solution that worked for me
In summary, change this:
AppActivate "Microsoft Excel"
to
AppActivate "Excel
Note: a pause before the command can help (at least in my case):
Application.Wait (Now + TimeValue("0:00:1"))

VBA - Unable to map drive to sharepoint on another computer

I'm mapping to the company's sharepoint drive using VBA. The intention is to save local file to sharepoint, and delete local file and unmapped the drive after success.
On my machine(Windows 10 64bits), the code works perfectly fine, successfully mapped the drive, created folder and file, successfully uploaded to sharepoint and unmap the drive.
However, when I run the same excel workbook that contains the same code on my colleague's computer(Window 7), it failed. There's no error being shown, except that it keeps on loading and loading until Excel Not Responsive. I tried manually mapping the drive, it success.
I tried to debug and found out that the code stops (keeps on loading) at MsgBox "Hello" but could not figure out what's missing.
Both are using Excel 2016
Any help and suggestions are appreciated. let me know if more info is needed. Thanks in advance.
This is my vba code
Sub imgClicked()
Dim fileName As String
Dim SharePointLib As String
Dim MyPath As String
Dim folderPath As String
Dim objNet As Object
Dim copyPath As String
Dim copyFilePath As String
folderPath = Application.ThisWorkbook.path
MyPath = Application.ThisWorkbook.FullName
Dim objFSO As Object
Dim strMappedDriveLetter As String
Dim strPath As String
Dim spPath As String
strPath = "https://company.com/sites/test/test 123/" 'example path
spPath = AvailableDriveLetter + ":\test.xlsm" 'example path
copyPath = folderPath + "\copyPath\"
'Add reference if missing
Call AddReference
Set objFSO = CreateObject("Scripting.FileSystemObject")
With objFSO
strMappedDriveLetter = IsAlreadyMapped(.GetParentFolderName(strPath))
If Not Len(strMappedDriveLetter) > 0 Then
strMappedDriveLetter = AvailableDriveLetter
If Not MapDrive(strMappedDriveLetter, .GetParentFolderName(strPath)) Then
MsgBox "Failed to map SharePoint directory", vbInformation, "Drive Mapping Failure"
Exit Sub
End If
End If
' Check file/folder path If statement here
End With
Set objFSO = Nothing
End Sub
Code for getting available drive
' Returns the available drive letter starting from Z
Public Function AvailableDriveLetter() As String
' Returns the last available (unmapped) drive letter, working backwards from Z:
Dim objFSO As Object
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = Asc("Z") To Asc("A") Step -1
Select Case objFSO.DriveExists(Chr(i))
Case True
Case False
Select Case Chr(i)
Case "C", "D" ' Not actually necessary - .DriveExists should return True anyway...
Case Else
AvailableDriveLetter = Chr(i)
Exit For
End Select
End Select
Next i
Set objFSO = Nothing
MsgBox "This is the next available drive: " + AvailableDriveLetter ' returns Z drive
MsgBox "Hello" ' After this msgBox, starts loading until Not Responsive
End Function
Function to Map drive
Public Function MapDrive(strDriveLetter As String, strDrivePath As String) As Boolean
Dim objNetwork As Object
If Len(IsAlreadyMapped(strDrivePath)) > 0 Then Exit Function
Set objNetwork = CreateObject("WScript.Network")
objNetwork.MapNetworkDrive strDriveLetter & ":", strDrivePath, False
MapDrive = True
MsgBox "Successfully Created the Drive!"
Set objNetwork = Nothing
End Function
Code for MappedDrive
Public Function GetMappedDrives() As Variant
' Returns a 2-D array of (1) drive letters and (2) network paths of all mapped drives on the users machine
Dim objFSO As Object
Dim objDrive As Object
Dim arrMappedDrives() As Variant
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim arrMappedDrives(1 To 2, 1 To 1)
For i = Asc("A") To Asc("Z")
If objFSO.DriveExists(Chr(i)) Then
Set objDrive = objFSO.GetDrive(Chr(i))
If Not IsEmpty(arrMappedDrives(1, UBound(arrMappedDrives, 2))) Then
ReDim Preserve arrMappedDrives(1 To 2, 1 To UBound(arrMappedDrives, 2) + 1)
End If
arrMappedDrives(1, UBound(arrMappedDrives, 2)) = Chr(i) ' Could also use objDrive.DriveLetter...
arrMappedDrives(2, UBound(arrMappedDrives, 2)) = objDrive.ShareName
End If
Next i
GetMappedDrives = arrMappedDrives
Set objDrive = Nothing
Set objFSO = Nothing
End Function
Public Function IsAlreadyMapped(strPath As String) As String
' Tests if a given network path is already mapped on the users machine
' (Returns corresponding drive letter or ZLS if not found)
Dim strMappedDrives() As Variant
Dim i As Long
strMappedDrives = GetMappedDrives
For i = LBound(strMappedDrives, 2) To UBound(strMappedDrives, 2)
If LCase(strMappedDrives(2, i)) Like LCase(strPath) Then
IsAlreadyMapped = strMappedDrives(1, i)
Exit For
End If
Next i
Set objNetwork = Nothing
End Function
Add Reference
Sub AddReference()
'Macro purpose: To add a reference to the project using the GUID for the
'reference library
Dim strGUID As String, theRef As Variant, i As Long
'Update the GUID you need below.
strGUID = "{420B2830-E718-11CF-893D-00A0C9054228}"
'Set to continue in case of error
On Error Resume Next
'Remove any missing references
For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set theRef = ThisWorkbook.VBProject.References.Item(i)
If theRef.isbroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If
Next i
'Clear any errors so that error trapping for GUID additions can be evaluated
Err.Clear
'Add the reference
ThisWorkbook.VBProject.References.AddFromGuid _
GUID:=strGUID, Major:=1, Minor:=0
'If an error was encountered, inform the user
Select Case Err.Number
Case Is = 32813
'Reference already in use. No action necessary
Case Is = vbNullString
'Reference added without issue
Case Else
'An unknown error was encountered, so alert the user
MsgBox "A problem was encountered trying to" & vbNewLine _
& "add or remove a reference in this file" & vbNewLine & "Please check the " _
& "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
End Select
On Error GoTo 0
End Sub
Procedure imgClicked is calling function AvailableDriveLetter multiple times. Remember that the function has to execute each time you refer to it.
I ran imgClicked (assuming that's the procedure you start with) and I was told, twice, "Next available letter = Z" and "Hello" and then it crashed Excel (perhaps getting stuck in a loop of creating FileSystem objects to look for an available drive letter?)
Try assigning AvailableDriveLetter to a variable (string) at the beginning of the procedure and referring to the variable each time you need the value, and see if you still have the issue.
(Remember to save before execution -- I get frustrated when troubleshooting "application hanging" issues because I keep forgetting to save my changes and then lose them on the crash!)
If this doesn't work, add a breakpoint (F9) on the End Function line after your "Hello" box and see if the code stops there. (I have trouble believing the MsgBox or End Function are the culprit.) If not, which procedure runs after that?
One more thing whether the issue is resolved or not:
Add Option Explicit at the very beginning of your module and then Compile the project and fix your missing variable declaration(s).
This is recommended whenever troubleshooting an issue as a means to eliminate variable declaration issues as a possible cause.

Activate specific URL contained in an email message - Take 2

First, thanks to all who have already assisted in the first iteration of this message. After looking around at other sites I found a better method for searching messages for URLs using regular expressions on this page, Open All Hyperlinks in an Outlook Email Message, on slipstick.com.
The my personal tweaking of the code is:
Option Explicit
Public Sub OpenLinksMessage()
Dim olMail As Outlook.MailItem
Dim Reg1 As RegExp
Dim AllMatches As MatchCollection
Dim M As Match
Dim strURL As String
Dim oApp As Object
Set oApp = CreateObject("InternetExplorer.Application")
Set olMail = ActiveExplorer.Selection(1)
Set Reg1 = New RegExp
'Set the Regular Expression to search for any http:// or https:// format URL
'The Global feature says to look through the entire message text being tested
With Reg1
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
.Global = True
.IgnoreCase = True
End With
' If the regular expression test for URLs comes back true
If Reg1.test(olMail.Body) Then
' Use the RegEx to return all instances that match it to the AllMatches group
Set AllMatches = Reg1.Execute(olMail.Body)
For Each M In AllMatches
strURL = M.SubMatches(0)
' Don't activate any URLs that are for unsubscribing; skip them
If InStr(strURL, "unsubscribe") Then GoTo NextURL
' If the URL ends with a > from being enclosed in darts, strip that > off
If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
' We now have a URL that we want to open in a new tab in IE
oApp.navigate strURL, CLng(2048)
oApp.Visible = True
' wait for page to load before passing the web URL
Do While oApp.Busy
DoEvents
Loop
NextURL:
Next
End If
Set Reg1 = Nothing
End Sub
Private Sub TestLaunchURL()
OpenLinksMessage
End Sub
This will be running under Windows 10, and I am wondering if there is some way to substitute the statement:
Set oApp = CreateObject("InternetExplorer.Application")
with its equivalent but snagging the application that the user has chosen as their default web browser? I'm also not certain of what, if any change, would be necessary to the Clng(2048) to communicate that I'd like the URL to be opened in a new tab of that browser rather than the one that currently has focus.
Would:
Set olMail = ActiveExplorer.Selection(1)
be the correct syntax for the "message I've just received" when this is being triggered by a rule for an incoming message? If not, what is?
Is that DO loop really necessary? I am trying to get a handle on what it does but really don't have it yet.
There should only be a single link in messages received from a specific e-mail address that should be parsed for the link and opened, but the test for that should be in the rule that invokes this subroutine rather than in the VBA code itself. I may have some additional filtering logic, but I think it will be a matter of adding an IF statement or two.
If anyone sees any glaring error in this adapted code please do let me know. It seems to be working on tests on individual messages, as IE opens and every link that's in the message is being opened in its own tab. I'd really like to make it open in the user's default web browser if at all possible.
Thanks in advance for your assistance. It has been invaluable already.
Phase 2: The script is thoroughly tested and works. It has been installed under Outlook 2016, we signed it with a certificate created with selfcert, the Trust Center Macro permissions are still at "Notifications for digitally signed macros, all other macros disabled."
When the the rule that invokes the script is run, and the script is triggered, the following error message box appears:
VBA error message box
Any theories on what went wrong and how to fix it? I have not yet created a second certificate with selfcert and signed this again because I wanted to know if this error message might pop up for other reasons, as sometimes happens.
Also, am I correct in believing that signed, user created macros will run, if signed, regardless of what the macro security is set to unless the setting is "all macros disabled"?
Phase 3.5 (sort of)
It appears the root of the problem is that the script itself is not being run at all when a new message arrives. I set up a testing rule that initially was to play a sound and invoke the script when a message arrives with either of two addresses in the sender's address. The sound would consistently play, but nothing else happened. So, I thought, let's take the sound playing out of the Outlook rule and put it in the script itself, with one sound playing unconditionally at the start of the script. Well, nada. Here is the latest code (some of which is taken directly from prior threads here on stackoverflow):
Option Explicit
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
Private Declare Function sndPlaySound32 _
Lib "winmm.dll" _
Alias "sndPlaySoundA" ( _
ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
Sub PlayTheSound(ByVal WhatSound As String)
If Dir(WhatSound, vbNormal) = "" Then
' WhatSound is not a file. Get the file named by
' WhatSound from the Windows\Media directory.
WhatSound = Environ("SystemRoot") & "\Media\" & WhatSound
If InStr(1, WhatSound, ".") = 0 Then
' if WhatSound does not have a .wav extension,
' add one.
WhatSound = WhatSound & ".wav"
End If
If Dir(WhatSound, vbNormal) = vbNullString Then
Beep ' Can't find the file. Do a simple Beep.
Exit Sub
End If
Else
' WhatSound is a file. Use it.
End If
sndPlaySound32 WhatSound, 0& ' Finally, play the sound.
End Sub
Public Sub OpenLinksMessage(olMail As Outlook.MailItem)
Dim Reg1 As RegExp
Dim AllMatches As MatchCollection
Dim M As Match
Dim strURL As String
Dim RetCode As Long
Set Reg1 = New RegExp
With Reg1
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
.Global = True
.IgnoreCase = True
End With
PlayTheSound "chimes.wav"
' If the regular expression test for URLs in the message body finds one or more
If Reg1.test(olMail.Body) Then
' Use the RegEx to return all instances that match it to the AllMatches group
Set AllMatches = Reg1.Execute(olMail.Body)
For Each M In AllMatches
strURL = M.SubMatches(0)
' Don't activate any URLs that are for unsubscribing; skip them
If InStr(1, strURL, "unsubscribe") Then GoTo NextURL
' If the URL ends with a > from being enclosed in darts, strip that > off
If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
' The URL to activate to accept must contain both of the substrings in the IF statement
If InStr(1, strURL, ".com") Then
PlayTheSound "TrainWhistle.wav"
' Activate that link to accept the job
RetCode = ShellExecute(0, "Open", "http://nytimes.com")
Set Reg1 = Nothing
Exit Sub
End If
NextURL:
Next
End If
Set Reg1 = Nothing
End Sub
Private Sub TestLaunchURL()
Dim currItem As MailItem
Set currItem = ActiveExplorer.Selection(1)
OpenLinksMessage currItem
End Sub
If I trigger the above code either by using the TestLaunch subroutine via the debugger, or create a rule and at the end say "Run on messages already in the inbox," it functions perfectly.
The only thing I can't do right now is get this to be triggered using the "run script" feature of an Outlook Rule when a new message arrives.
Any theories or assistance regarding how to get over this last hurdle would be very much appreciated.
This activates the specific URL. The part that plays the sound is not necessary.
Option Explicit
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
Private Declare Function sndPlaySound32 _
Lib "winmm.dll" _
Alias "sndPlaySoundA" ( _
ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
Sub PlayTheSound(ByVal WhatSound As String)
If Dir(WhatSound, vbNormal) = "" Then
' WhatSound is not a file. Get the file named by
' WhatSound from the Windows\Media directory.
WhatSound = Environ("SystemRoot") & "\Media\" & WhatSound
If InStr(1, WhatSound, ".") = 0 Then
' if WhatSound does not have a .wav extension,
' add one.
WhatSound = WhatSound & ".wav"
End If
If Dir(WhatSound, vbNormal) = vbNullString Then
Beep ' Can't find the file. Do a simple Beep.
Exit Sub
End If
Else
' WhatSound is a file. Use it.
End If
sndPlaySound32 WhatSound, 0& ' Finally, play the sound.
End Sub
Public Sub OpenLinksMessage(olMail As Outlook.MailItem)
Dim Reg1 As RegExp
Dim AllMatches As MatchCollection
Dim M As Match
Dim strURL As String
Dim RetCode As Long
Set Reg1 = New RegExp
With Reg1
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
.Global = True
.IgnoreCase = True
End With
PlayTheSound "chimes.wav"
' If the regular expression test for URLs in the message body finds one or more
If Reg1.test(olMail.Body) Then
' Use the RegEx to return all instances that match it to the AllMatches group
Set AllMatches = Reg1.Execute(olMail.Body)
For Each M In AllMatches
strURL = M.SubMatches(0)
' Don't activate any URLs that are for unsubscribing; skip them
If InStr(1, strURL, "unsubscribe") Then GoTo NextURL
' If the URL ends with a > from being enclosed in darts, strip that > off
If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
' The URL to activate to accept must contain both of the substrings in the IF statement
If InStr(1, strURL, ".com") Then
PlayTheSound "TrainWhistle.wav"
' Activate that link to accept the job
RetCode = ShellExecute(0, "Open", "http://nytimes.com")
Set Reg1 = Nothing
Exit Sub
End If
NextURL:
Next
End If
Set Reg1 = Nothing
End Sub
Private Sub TestLaunchURL()
Dim currItem As MailItem
Set currItem = ActiveExplorer.Selection(1)
OpenLinksMessage currItem
End Sub
"If I trigger the above code either by using the TestLaunch subroutine via the debugger, or create a rule and at the end say "Run on messages already in the inbox," it functions perfectly." britechguy
The answer to this question, including the code for same, has been answered by me on a follow up question I'd asked: Why does this regular expression test give different results for what should be the same body text?
Please refer to the answer on that thread for the solution.

Rename and save ActiveDocument with VBA

Is it possible to rename the activedocument (the word document that I'm running the macro from) with VBA?
Right now I'm saving my activedocument under a new name and then attempt to delete the original. The latter part won't go through, so the original never gets deleted.
Anyone know if this is even possible?
I spent a lot of time doing this recently, because I disliked having to delete previous files when I did "Save As" - I wanted a "Save as and delete old file" answer. My answer is copied from here.
I added it to the quicklaunch bar which works wonderfully.
Insert following code into normal.dotm template (found in C:\Documents and Settings\user name\Application Data\Microsoft\Templates for Windows 7 for Word)
Save normal.dotm
Add this to the quicklaunch toolbar in Word.
Optional - remap a keyboard shortcut to this
Optional - digitally sign your template (recommended)
Note this actually moves the old file to the Recycle Bin rather than trashing completely and also sets the new file name in a very convenient fashion.
Option Explicit
'To send a file to the recycle bin, we'll need to use the Win32 API
'We'll be using the SHFileOperation function which uses a 'struct'
'as an argument. That struct is defined here:
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As Long
End Type
' function declaration:
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
'there are some constants to declare too
Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_NOCONFIRMATION = &H10
Private Const FOF_SILENT = &H4
Function RecycleFile(FileName As String, Optional UserConfirm As Boolean = True, Optional HideErrors As Boolean = False) As Long
'This function takes one mandatory argument (the file to be recycled) and two
'optional arguments: UserConfirm is used to determine if the "Are you sure..." dialog
'should be displayed before deleting the file and HideErrors is used to determine
'if any errors should be shown to the user
Dim ptFileOp As SHFILEOPSTRUCT
'We have declared FileOp as a SHFILEOPSTRUCT above, now to fill it:
With ptFileOp
.wFunc = FO_DELETE
.pFrom = FileName
.fFlags = FOF_ALLOWUNDO
If Not UserConfirm Then .fFlags = .fFlags + FOF_NOCONFIRMATION
If HideErrors Then .fFlags = .fFlags + FOF_SILENT
End With
'Note that the entire struct wasn't populated, so it would be legitimate to change it's
'declaration above and remove the unused elements. The reason we don't do that is that the
'struct is used in many operations, some of which may utilise those elements
'Now invoke the function and return the long from the call as the result of this function
RecycleFile = SHFileOperation(ptFileOp)
End Function
Sub renameAndDelete()
' Store original name
Dim sOriginalName As String
sOriginalName = ActiveDocument.FullName
' Save As
Dim sFilename As String, fDialog As FileDialog, ret As Long
Set fDialog = Application.FileDialog(msoFileDialogSaveAs)
'set initial name so you don't have to navigate to
fDialog.InitialFileName = sOriginalName
ret = fDialog.Show
If ret <> 0 Then
sFilename = fDialog.SelectedItems(1)
Else
Exit Sub
End If
Set fDialog = Nothing
'only do this if the file names are different...
If (sFilename <> sOriginalName) Then
'I love vba's pretty code
ActiveDocument.SaveAs2 FileName:=sFilename, FileFormat:= _
wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False, CompatibilityMode:=14
' Delete original (don't care about errors, I guess)
Dim hatersGonnaHate As Integer
hatersGonnaHate = RecycleFile(sOriginalName, False, True)
End If
End Sub

Running 7Z in a dos command from VBA Excel causes warning alert

I am currently using the following code to run a dos command as follows from VBA.
Set objShell = CreateObject("WScript.Shell")
dos_command="\\\10.xx.xx.xx\test\7z.exe a -r " etc etc etc
result = objShell.Run(dos_command, 0, True)
Set objShell =nothing
All runs well, the only problem is that I get an annoying Warning Windows Box advising a program is trying to run in my computer, press OK or Cancel
I must use "objshell" because I need VBA to wait until DOS command is completed.
is there a way to avoid the warning box from coming up from within VBA or adding some additional parameters to the DOS command ?
The 7z.exe file is running in a server (not local PC) so I assume that's the problem.
I cannot use or install 7z.exe in each machine.
Here are three options, presented in order from quickest/dirtiest to most robust:
Create a text file as part of command line and wait for its existence: modify your command line to something like this and run it using Shell (not your objShell):
dos_command = "\\\10.xx.xx.xx\test\7z.exe a -r " etc etc etc
dos_command = dos_command & " && echo > " & TempFileName
This will create a text file named TempFileName after your 7-zip code completes. You just need to make sure TempFileName does not exist before you run your shell command, then run the command and wait for the TempFileName file to exist.
Use OpenProcess and GetExitCodeProcess APIs: launch your command line using the OpenProcess API call which provides access to your new process (note that the Shell function returns the ProcessID of the launched process). Then use the ProcessID to sit in a loop and poll the process via GetExitCodeProcess. Relevant declarations:
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
Private Const STILL_ACTIVE = &H103
Private Const PROCESS_QUERY_INFORMATION = &H400
'---------------------------------------------------------------------------------------vv
' Procedure : ShellWait
' DateTime : 2/15/2008 10:59
' Author : Mike
' Purpose : Executes a shell command and waits for it to complete.
' Notes : Runs the shell as a batch file, allowing the user to pass a string with
' line breaks to execute a multi-line command.
'
' : Provides two means to break out of the loop.
' 1) Provide a timeout in seconds.
' The code breaks out once it reaches the timeout.
' 2) Provide a flag to tell the procedure to stop running.
' To use this option, you would need to pass the procedure a global flag
' that the user has the ability to change through the interface.
' Update (5/23/2008):
' - Uses a progressive sleep timer to allow fast processes to run quickly
' and long processes to get increasing clock cycles to work with.
' - Changed default window mode to hidden.
'---------------------------------------------------------------------------------------
'^^
Public Function ShellWait(DosCmd As String, _
Optional StartIn As String = "WINDOWS TEMP FOLDER", _
Optional WindowStyle As VbAppWinStyle = vbHide, _
Optional TimeOutSeconds As Long = -1, _
Optional ByRef StopWaiting As Boolean = False) 'vv
On Error GoTo Err_ShellWait
Dim hProcess As Long, RetVal As Long, StartTime As Long
Dim BatName As String, FileNum As Integer, SleepTime As Long
StartTime = Timer
BatName = TempFileName(StartIn, "bat")
FileNum = FreeFile()
Open BatName For Output As #FileNum
ChDrive Left(BatName, 1)
ChDir Left(BatName, InStrRev(BatName, "\"))
Print #FileNum, DosCmd
Close #FileNum
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(BatName, WindowStyle))
SleepTime = 10
Do
'Get the status of the process
GetExitCodeProcess hProcess, RetVal
DoEvents: Sleep SleepTime
If TimeOutSeconds <> -1 Then
If Timer - StartTime > TimeOutSeconds Then Exit Do
End If
If StopWaiting Then Exit Do
'Progressively increase the SleepTime by 10%
' This allows a quick process to finish quickly, while providing
' a long process with increasingly greater clock cycles to work with
SleepTime = SleepTime * 1.1
Loop While RetVal = STILL_ACTIVE
Kill BatName
Exit_ShellWait:
Exit Function
Err_ShellWait:
MsgBox Err.Description
Resume Exit_ShellWait
End Function
'---------------------------------------------------------------------------------------vv
' Procedure : TempFileName
' DateTime : 12/9/08
' Author : Mike
' Purpose : Returns an unused file name but does not create the file. Path can be
' passed with or without the trailing '\'.
' Requires : TempPath() function
'---------------------------------------------------------------------------------------
'^^
Function TempFileName(Optional ByVal Path As String = "WINDOWS TEMP FOLDER", _
Optional Ext As String = "txt", _
Optional Prefix As String = "temp") As String 'vv
Dim TempFName As String, i As Integer
If Path = "WINDOWS TEMP FOLDER" Then Path = TempPath
If Right(Path, 1) <> "\" Then Path = Path & "\"
If Not (Path Like "?:\*" Or Path Like "\\*") Then
Err.Raise 52 '"Bad file name or number."
ElseIf Dir(Path, vbDirectory) = "" Then
Err.Raise 76 '"Path not found."
End If
TempFName = Path & Prefix & "." & Ext
For i = 1 To 500
If Dir(TempFName) = "" Then
TempFileName = TempFName
GoTo Exit_TempFileName
End If
TempFName = Path & Prefix & "_" & Format(i, "000") & "." & Ext
Next i
TempFileName = ""
End Function
'---------------------------------------------------------------------------------------
' Procedure : TempPath
' Author : Mike
' Date : 8/12/2008
' Purpose : Returns something like:
' C:\DOCUME~1\BGRAND~1\LOCALS~1\Temp\
'---------------------------------------------------------------------------------------
'^^
Function TempPath() As String 'vv
Const TemporaryFolder = 2
Static TempFolderPath As String
Dim fs As Object
If Len(TempFolderPath) = 0 Then
Set fs = CreateObject("Scripting.FileSystemObject")
TempFolderPath = fs.GetSpecialFolder(TemporaryFolder) & "\"
End If
TempPath = TempFolderPath
End Function
Use CreateProcess and WaitForSingleObject APIs: refer to the "Super Shell" example at this help page for CreateProcess
Calling Microsoft® Windows® Script Host causes windows to display the message. Instead try this
Public Sub test()
Dim dos_command$, lRet&
dos_command = """\\xxx.xxx.xxx.xxx\xxx\xxx\7z.exe"" a test.zip ""\\xxx.xxx.xxx.xxx\xxx\xxx\*.log"" -r"
lRet = Shell(dos_command, vbMaximizedFocus)
MsgBox lRet
End Sub
UPDATE
You may do the following and use your code:
Open Start | Run and type gpedit.msc. Click OK
User Configuration >> Administrative Templates >> Windows Components >> Attachment Manager
Add 7z.exe to the Inclusion list for moderate risk file types setting.
Hpe this helps