通过单击使用 myOlExp_SelectionChange 自动缩放电子邮件窗口

Question

我有自动缩放电子邮件窗口窗格的代码。直到几天前对 MS Outlook 进行了最新更新后，它才有效。

'Install redemption and add "Microsoft Word Object Library" reference and "Redemption Outlook library" reference.
Option Explicit
    Dim WithEvents objInspectors As Outlook.Inspectors
    Dim WithEvents objOpenInspector As Outlook.Inspector
    Dim WithEvents objMailItem As Outlook.MailItem
    Dim WithEvents myOlExp As Outlook.Explorer
    Dim sExplorer As Object
    Dim Document As Object
    Dim Msg
    
    Const MsgZoom = 150
    
Private Sub Application_Startup()
    Set objInspectors = Application.Inspectors
    Set myOlExp = Application.ActiveExplorer
    Set sExplorer = CreateObject("Redemption.SafeExplorer")
End Sub
    
Private Sub Application_Quit()
    Set objOpenInspector = Nothing
    Set objInspectors = Nothing
    Set objMailItem = Nothing
End Sub
    
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
    If Inspector.CurrentItem.Class = olMail Then
        Set objMailItem = Inspector.CurrentItem
        Set objOpenInspector = Inspector
    End If
End Sub

Private Sub objOpenInspector_Close()
    Set objMailItem = Nothing
End Sub
    
Private Sub objOpenInspector_Activate()
    Dim wdDoc As Word.Document
    Set wdDoc = objOpenInspector.WordEditor
    wdDoc.Windows(1).Panes(1).View.Zoom.Percentage = MsgZoom
End Sub
    
Private Sub myOlExp_SelectionChange()
    On Error GoTo ErrHandler:
    Set Msg = Application.ActiveExplorer.Selection(1)
    Application.ActiveExplorer.RemoveFromSelection (Msg)
    Application.ActiveExplorer.AddToSelection (Msg)
    sExplorer.Item = Application.ActiveExplorer
    Set Document = sExplorer.ReadingPane.WordEditor
    Document.Windows.Item(1).View.Zoom.Percentage = MsgZoom
    Exit Sub
    
ErrHandler:
    Exit Sub
    
End Sub

我必须单击电子邮件，然后再次单击它才能使自动缩放起作用。过去，我点击了一次电子邮件。

我使用的是 Microsoft Outlook 2016 版本 1805（内部版本 9330.2087）

导致问题的代码段在myOlExp_SelectionChange()。

当我在myOlExp_SelectionChange() 中添加断点并单步执行代码时，自动缩放在调试模式下工作。

Answer 1

尝试在更改Zoom 级别之前在事件处理程序中使用以下调用：

Application.DoEvents()

DoEvents 函数产生执行，以便操作系统可以处理其他事件。 DoEvents 将控制权交给操作系统。在操作系统完成处理其队列中的事件并且SendKeys 队列中的所有键都已发送后，控制权被返回。 DoEvents 对于简单的事情最有用，比如允许用户在进程启动后取消它，例如搜索文件。对于长时间运行的进程，通过使用计时器或将任务委托给 ActiveX EXE 组件来更好地完成让处理器。在后一种情况下，任务可以完全独立于您的应用程序继续进行，并且操作系统负责多任务处理和时间切片。每当您在事件过程中临时让出处理器时，请确保在第一次调用返回之前不会从代码的不同部分再次执行该过程；这可能会导致不可预知的结果。

Private Sub myOlExp_SelectionChange()
 DoEvents
 Set Msg = Application.ActiveExplorer.Selection(1)
 Application.ActiveExplorer.RemoveFromSelection (Msg)
 Application.ActiveExplorer.AddToSelection (Msg)
 sExplorer.Item = Application.ActiveExplorer

 Set Document = sExplorer.ReadingPane.WordEditor
 Document.Windows.Item(1).View.Zoom.Percentage = MsgZoom

End Sub

您也可以尝试在调整缩放级别之前使用计时器来引入延迟。您可以使用SetTimer 和KillTimer Windows API 函数。请参阅Outlook VBA - Run a code every half an hour 了解更多信息。

Answer 2

在outlook 2018以后，有一个保存缩放的选项（请在状态栏中右键单击缩放百分比）