Question

我目前在Excel 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明确

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

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

结束功能

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

结束功能

AppleScript的：

在CreateMailInOutlook（paramString）上将{fieldValue1，fieldValue2，fieldValue3，fieldValue4，fieldValue5，fieldValue6，fieldValue7，fieldValue8，fieldValue9}设置为SplitString（paramString，＆＃34;;＆＃34;）告诉应用程序＆＃34; Microsoft Outlook＆＃34; if fieldValue7 =＆＃34; pop＆＃34;然后将theAccount设置为名称为fieldValue8的第一个pop帐户将NewMail设置为（使用属性{subject：fieldValue1，content：fieldValue2，account：theAccount}制作新的外发邮件）否则，如果fieldValue7 =＆＃34; imap＆＃34;然后将theAccount设置为名为fieldValue8的第一个imap帐户将NewMail设置为（使用属性{subject：fieldValue1，content：fieldValue2，account：theAccount}制作新的外发邮件）其他将NewMail设置为（使用属性{subject：fieldValue1，content：fieldValue2}制作新的外发邮件）万一告诉NewMail 在我的SplitString中重复使用toRecipient（fieldValue3，＆＃34;，＆＃34;）在收件人末尾向收件人添加新邮件，其中包含属性{电子邮件地址：{地址：内容为toRecipient}} 结束重复在我的SplitString中重复使用toRecipient（fieldValue4，＆＃34;，＆＃34;）在具有属性{电子邮件地址：{地址：toRecipient}的内容}的cc收件人结尾处为收件人设置新内容结束重复在我的SplitString中重复使用toRecipient（fieldValue5，＆＃34;，＆＃34;）使用属性{电子邮件地址：{地址：toRecipient}的内容}在密送收件人结尾处为收件人设置新内容结束重复使用属性{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

结束CreateMailInOutlook

on SplitString（TheBigString，fieldSeparator）告诉AppleScript 将oldTID设置为文本项分隔符将文本项分隔符设置为fieldSeparator 将theItems设置为TheBigString的文本项将文本项分隔符设置为oldTID 结束告诉返回项目结束SplitString

on Mini（）告诉应用程序＆＃34; Microsoft Outlook＆＃34; 告诉（其id不是的窗口（获取前窗的id）并且可见是真的）设置小型化为真结束告诉结束告诉结束迷你

将焦点设置回Excel，Mac VBA 2016

1 个答案: