将焦点重新设置为Excel，Mac VBA 2016

Question

我目前在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屏幕以及新的电子邮件。 点击发送后，新的电子邮件屏幕消失，但是Outlook主窗口仍然保留。

如何将焦点重新设置为Excel？

Answer 1

我发现解决方案是使用Applescript达到预期的效果。 这是整个脚本：ption显式

子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（主题为字符串，主体为字符串，_ toaddress为字符串，ccaddress为字符串，_ bccaddress为字符串，displaymail为布尔值，_ accounttype为字符串，accountname为String，_附件为String，FileFormat为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

结束功能

函数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

结束功能

函数KillFile（Filestr作为字符串）

'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

结束功能

Applescript：

在CreateMailInOutlook（paramString）上，将{fieldValue1，fieldValue2，fieldValue3，fieldValue4，fieldValue5，fieldValue6，fieldValue7，fieldValue8，fieldValue9}设置为SplitString（paramString，“;”）告诉应用程序“ Microsoft Outlook”，如果fieldValue7 =“ pop”，然后将Account设置为名称为fieldValue8的第一个弹出帐户将NewMail设置为（使用属性{subject：fieldValue1，content：fieldValue2，account：theAccount}创建新的传出消息），否则，如果fieldValue7 =“ imap”，则将该帐户设置为名称为第一个imap帐户fieldValue8将NewMail设置为（使用属性{subject：fieldValue1，content：fieldValue2，account：theAccount}创建新的传出消息），否则将NewMail设置为（使用属性{subject：fieldValue1，content：fieldValue2}创建新的传出消息）如果告诉NewMail结束在我的SplitString（fieldValue3，“，”）中与toRecipient重复，在属性为{电子邮件地址：{地址：toRecipient的内容}}的收件人的末尾，使收件人成为新收件人。 在我的SplitString（fieldValue4，“，”）中，在属性为{电子邮件地址：{地址：toRecipient的内容}}的抄送收件人的末尾，为收件人重新创建收件人，并在我的SplitString（fieldValue5，“，”）中的收件人重复重复在属性为{电子邮件地址：{地址：toRecipient的内容}}的密件抄送收件人的末尾，向收件人发送重复，并以属性{file：POSIX file fieldValue9作为别名}创建新附件

        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 end告诉返回return theItems end SplitString

在Mini（）上告诉应用程序“ Microsoft Outlook”，告诉（其ID不是（获取前窗口的ID）并且visible为true的窗口）将小型化设置为true end tell end tell end Mini