将焦点设置回Excel，Mac VBA 2016
我目前在Excel 2016 for MAC 2016中使用以下VBA代码：
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 它很好地通过Outlook电子邮件当前工作表。
我遇到的问题是，我想焦点返回到Excel工作表。 现在发生的事情是Outlook屏幕和一个新的电子邮件popup。 点击发送后，新的电子邮件屏幕消失，但主Outlook窗口仍然存在。
如何将焦点设置回Excel？
我发现解决scheme是使用Applescript来达到预期的效果。 这是整个脚本：ption显式
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
结束小组
函数MailWithMac（主题为string，mailbody为string，_ toaddress为string，ccaddress为string，_ bccaddress为string，displaymail为布尔，_ accounttype为string，accountname为string，_ attachment为string，FileFormat为长）
'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
结束function
函数CheckScript（ScriptFileName As String）作为布尔值
'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
结束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
结束function
AppleScript的：
如果fieldValue7 =“pop”，则告诉应用程序“Microsoft Outlook”，然后将“AccountAutlook”设置为“MicrosoftAutlook”第一个名字是fieldValue8的pop账户将NewMail设置为（使用属性{subject：fieldValue1，content：fieldValue2，account：theAccount}创build新的外发消息）else if fieldValue7 =“imap”然后将账户设置为第一个名为否则将NewMail设置为（使用属性{subject：fieldValue1，content：fieldValue2}创build新的外发消息）end if tell NewMail在我的SplitString中重复使用toRecipient（fieldValue3，“，”）使用属性{email地址：{address：toRecipient的内容}}结尾处的收件人结束使用toRecipient 在我的SplitString（fieldValue4，“，”）中使用属性（电子邮件地址：{地址：toRecipient的内容}}结束cc收件人的新收件人重复与我的SplitString中的toRecipient重复（fieldValue5，“，”）make new到具有属性的密件抄送收件人末尾的收件人（电子邮件地址：{地址：toRecipient的内容}}结束重复使用属性{file：POSIX file fieldValue9作为别名}创build新的附件}
if fieldValue6 as boolean = true then open NewMail activate NewMail else send NewMail end if end tell end tell
结束CreateMailInOutlook
在SplitString（TheBigString，fieldSeparator）告诉AppleScript将oldTID设置为文本项目分隔符将文本项目分隔符设置为fieldSeparator将TheItems设置为TheBigString的文本项目将文本项目分隔符设置为oldTID结束tell tell返回theItems结束SplitString
在Mini（）告诉应用程序“Microsoft Outlook”告诉（窗口的ID不是（前窗口的ID）和可见是真的）设置小型化为真结束告诉结束告诉结束迷你