Set Focus Back to Excel, Mac VBA 2016 - excel

Question

I am currently using the following VBA code in Excel for MAC 2016:
Sub MailWorkSheet()
Dim SourceWb As Workbook, DestWb As Workbook, sh As Worksheet
Dim strbody As String, TempFileName As String
If Val(Application.Version) < 15 Then Exit Sub
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'Check if the Script File is in the correct location
If CheckScript(ScriptFileName:="ExcelOutlook.scpt") = False Then
MsgBox "Sorry the ExcelOutlook.scpt file is not in the correct
location, " & _
"Email File Manually."
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Set reference to the source workbook
Set SourceWb = ActiveWorkbook
'Create the body text in the strbody string
strbody = "<FONT size=""3"" face=""Calibri"">"
strbody = strbody & "Hello:" & "<br>" & "<br>" & _
"XXXXXXX." & "<br>" & _
" " & "<br>" & _
"XXXXXXX." & "<br>" & _
" " & "<br>" & _
"XXXXXXX!!"
strbody = strbody & "</FONT>"
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set DestWb = ActiveWorkbook
'Delete the button on the one sheet workbook
On Error Resume Next
DestWb.Sheets(1).DrawingObjects.Visible = True
DestWb.Sheets(1).DrawingObjects.Delete
On Error GoTo 0
'Enter the name of the file just created
TempFileName = "Long Lane Merit Sheet" & " " _
& Range("A2") & " " & Format(Now, "mmm-dd-yy")
'Call the MailWithMac function to save the new file and create the
mail
MailWithMac _
subject:="XXXXXXX", _
mailbody:=strbody, _
toaddress:=Range("A3"), _
ccaddress:="", _
bccaddress:="", _
displaymail:=True, _
accounttype:="", _
accountname:="", _
attachment:=TempFileName, _
FileFormat:=SourceWb.FileFormat
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Turn on Automatic Calculation
Application.Calculation = xlCalculationAutomatic
'Turn Alert Messages On
Application.DisplayAlerts = True
End Sub
It works great to email the current sheet through Outlook.
The problem I am having is that I want the focus to return to the Excel sheet. What is happening now is that the Outlook screen along with a new email pops up. After hitting send, the new email screen goes away, but the main Outlook window remains.
How do I set focus back to Excel?

Answer 1

I have found that the solution is to use Applescript to achieve the desired effect. Here is the whole script:
ption Explicit
Sub MailWorkSheet()
'Only working in Excel 2016 for the Mac with Outlook 2016
Dim SourceWb As Workbook, DestWb As Workbook, sh As Worksheet
Dim strbody As String, TempFileName As String
Dim RunMyScript As String
'Exit the sub if it is Mac Excel 2011 or lower
If Val(Application.Version) < 15 Then Exit Sub
'Turn off Automatic Calculation
Application.Calculation = xlCalculationManual
'Turn off Alerts
Application.DisplayAlerts = False
'Check if the Script File is in the correct location
If CheckScript(ScriptFileName:="ExcelOutlook.scpt") = False Then
MsgBox "Sorry the ExcelOutlook.scpt file is not in the correct location, " & _
"Email File Manually."
Exit Sub
End If
With Application
'.ScreenUpdating = False
.EnableEvents = False
End With
'Set reference to the source workbook
Set SourceWb = ActiveWorkbook
'Create the body text in the strbody string
strbody = "<FONT size=""3"" face=""Calibri"">"
strbody = strbody & "Hello:" & "<br>" & "<br>" & _
"XXXXXXX" & "<br>" & _
" " & "<br>" & _
"XXXXXXX" & "<br>" & _
" " & "<br>" & _
"XXXXXXX"
strbody = strbody & "</FONT>"
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set DestWb = ActiveWorkbook
'Delete the button on the one sheet workbook
On Error Resume Next
DestWb.Sheets(1).DrawingObjects.Visible = True
DestWb.Sheets(1).DrawingObjects.Delete
On Error GoTo 0
'Enter the name of the file just created
TempFileName = "XXXXXXX" & " " _
& Range("A2") & " " & Format(Now, "mmm-dd-yy")
'Call the MailWithMac function to save the new file and create the mail
MailWithMac _
subject:="XXXXXXX", _
mailbody:=strbody, _
toaddress:=Range("A3"), _
ccaddress:="", _
bccaddress:="", _
displaymail:=True, _
accounttype:="", _
accountname:="", _
attachment:=TempFileName, _
FileFormat:=SourceWb.FileFormat
With Application
'.ScreenUpdating = True
.EnableEvents = True
End With
'Minimize Outlook
RunMyScript = AppleScriptTask("ExcelOutlook.scpt", "Mini", _
"/Library/Application Scripts/com.microsoft.Excel/ExcelOutlook.scpt")
'Turn on Automatic Calculation
Application.Calculation = xlCalculationAutomatic
'Turn Alert Messages On
Application.DisplayAlerts = True
End Sub
Function MailWithMac(subject As String, mailbody As String, _
toaddress As String, ccaddress As String, _
bccaddress As String, displaymail As Boolean, _
accounttype As String, accountname As String, _
attachment As String, FileFormat As Long)
'Function to create a mail with the activesheet
Dim FileExtStr As String, FileFormatNum As Long
Dim TempFilePath As String, fileattachment As String
Dim ScriptStr As String, RunMyScript As String
Select Case FileFormat
Case 52: FileExtStr = ".xlsx": FileFormatNum = 52
Case 53:
If ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 53
Else
FileExtStr = ".xlsx": FileFormatNum = 52
End If
Case 57: FileExtStr = ".xls": FileFormatNum = 57
Case Else: FileExtStr = ".xlsb": FileFormatNum = 51
End Select
'Save the new temporary workbook and close it
TempFilePath = _
MacScript("return POSIX path of (path to home folder) as string")
With ActiveWorkbook
.SaveAs TempFilePath & attachment & FileExtStr, FileFormat:=FileFormatNum
.Close SaveChanges:=False
End With
'Build the AppleScriptTask parameter string
fileattachment = TempFilePath & attachment & FileExtStr
ScriptStr = subject & ";" & mailbody & ";" & toaddress & ";" & ccaddress & ";" & _
bccaddress & ";" & displaymail & ";" & accounttype & ";" & _
accountname & ";" & fileattachment
'Call the ExcelOutlook Script with the AppleScriptTask Function
RunMyScript = AppleScriptTask("ExcelOutlook.scpt", "CreateMailinOutlook", CStr(ScriptStr))
'Delete the file we just mailed
KillFile fileattachment
End Function
Function CheckScript(ScriptFileName As String) As Boolean
'Function to Check if the AppleScriptTask script file exists
Dim AppleScriptTaskFolder As String
Dim TestStr As String
AppleScriptTaskFolder = MacScript("return POSIX path of (path to desktop folder) as string")
AppleScriptTaskFolder = Replace(AppleScriptTaskFolder, "/Desktop", "") & _
"Library/Application Scripts/com.microsoft.Excel/"
On Error Resume Next
TestStr = Dir(AppleScriptTaskFolder & ScriptFileName, vbDirectory)
On Error GoTo 0
If TestStr = vbNullString Then
CheckScript = False
Else
CheckScript = True
End If
End Function
Function KillFile(Filestr As String)
'Function to Kill File
Dim ScriptToKillFile As String
Dim Fstr As String
'Delete files from a Mac using Applescript to avoid probelsm with long file names
If Val(Application.Version) < 15 Then
ScriptToKillFile = "tell applicatoin " & Chr(34) & _
"Finder" & Chr(34) & Chr(13)
ScriptToKillFile = ScriptToKillFile & _
"do shell script ""rm"" & quoted form of posix path of " & _
Chr(34) & Filestr & Chr(34) & Chr(13)
ScriptToKillFile = ScriptToKillFile & "end tell"
On Error Resume Next
MacScript (ScriptToKillFile)
On Error GoTo 0
Else
Fstr = MacScript("return POSIX path of (" & _
Chr(34) & Filestr & Chr(34) & ")")
On Error Resume Next
Kill Fstr
End If
End Function
Applescript:
on CreateMailInOutlook(paramString)
set {fieldValue1, fieldValue2, fieldValue3, fieldValue4, fieldValue5, fieldValue6, fieldValue7, fieldValue8, fieldValue9} to SplitString(paramString, ";")
tell application "Microsoft Outlook"
if fieldValue7 = "pop" then
set theAccount to the first pop account whose name is fieldValue8
set NewMail to (make new outgoing message with properties {subject:fieldValue1, content:fieldValue2, account:theAccount})
else if fieldValue7 = "imap" then
set theAccount to the first imap account whose name is fieldValue8
set NewMail to (make new outgoing message with properties {subject:fieldValue1, content:fieldValue2, account:theAccount})
else
set NewMail to (make new outgoing message with properties {subject:fieldValue1, content:fieldValue2})
end if
tell NewMail
repeat with toRecipient in my SplitString(fieldValue3, ",")
make new to recipient at end of to recipients with properties {email address:{address:contents of toRecipient}}
end repeat
repeat with toRecipient in my SplitString(fieldValue4, ",")
make new to recipient at end of cc recipients with properties {email address:{address:contents of toRecipient}}
end repeat
repeat with toRecipient in my SplitString(fieldValue5, ",")
make new to recipient at end of bcc recipients with properties {email address:{address:contents of toRecipient}}
end repeat
make new attachment with properties {file:POSIX file fieldValue9 as alias}
if fieldValue6 as boolean = true then
open NewMail
activate NewMail
else
send NewMail
end if
end tell
end tell
end CreateMailInOutlook
on SplitString(TheBigString, fieldSeparator)
tell AppleScript
set oldTID to text item delimiters
set text item delimiters to fieldSeparator
set theItems to text items of TheBigString
set text item delimiters to oldTID
end tell
return theItems
end SplitString
on Mini()
tell application "Microsoft Outlook"
tell (windows whose id is not (get id of front window) and visible is true)
set miniaturized to true
end tell
end tell
end Mini