Windows锁定时Outlook宏如何直达Excel用户窗体或解决剪贴板故障

收到邮件触发的Outlook宏，功能是复制邮件列表、打开指定工作簿、调出用户窗体并粘贴数据后运行后续宏。该流程在电脑解锁状态正常，但锁定时因写入剪贴板失败报错。

原Outlook宏代码 #

Sub Q_copy(msg As Outlook.MailItem)
    Dim xExcelFile As String
    Dim xExcelApp As Excel.Application
    Dim wb As Excel.Workbook
    Dim bd As Variant
    
    'Debug.Print Trim(msg.HTMLBody)
    If Now() < msg.SentOn + TimeValue("00:01:00") Then ' make sure it doesn't trigger on yesterdays mail when I start the computer
 
        ' remove empty lines
        bd = Split(msg.Body, vbNewLine)
        j = 0
        For i = LBound(bd) To UBound(bd)
            If bd(i) <> "" And bd(i) <> " " Then
                bd(j) = bd(i)
                j = j + 1
            End If
        Next i
        ReDim Preserve bd(LBound(bd) To j - 1)
        ' empty lines removed

        bdtxt = Join(bd, vbNewLine)
        Dim MSForms_DataObject As Object
        Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        MSForms_DataObject.SetText Trim(bdtxt)
        MSForms_DataObject.PutInClipboard ' here the code fails if the computer is locked, if I pull back the code two lines up to "Set..." and run again then it works.
        Set MSForms_DataObject = Nothing
        
        On Error Resume Next
        Set xExcelApp = GetObject(, "Excel.Application")
        On Error GoTo 0
        
        If xExcelApp Is Nothing Then
            Set xExcelApp = CreateObject("Excel.Application")
        End If
        
        Set wb = xExcelApp.Workbooks.Open("\\FS06\Users6\a78208\Dokument\Filtrera Quinyx.xlsm")
        xExcelApp.Visible = True
        xExcelApp.Application.Run "Modul1.test" ' opens a userform
        xExcelApp.Application.Run "Modul1.paste" ' this pastes data from clipboard to userform textbox
        xExcelApp.Application.Run "Modul1.leta_namn" ' uses the data in above textform
        'AppActivate "Filtrera Quinyx - Excel"
    End If
End Sub

原Excel工作簿宏代码 #

Sub test()
    UserForm1.Show (0)
End Sub

Sub paste()
    Dim DataObj As MSForms.DataObject
    Set DataObj = New MSForms.DataObject
    DataObj.GetFromClipboard

    UserForm1.TextBox1.Text = DataObj.GetText(1)
    UserForm1.Palm.Value = True
End Sub

Sub leta_namn()
    UserForm1.CommandButton1_Click
End Sub

方案1：直接传递数据（推荐，彻底规避剪贴板问题） #

不需要通过剪贴板中转，直接将Outlook处理后的文本传递给Excel用户窗体，步骤如下：

修改Outlook宏代码 #

移除剪贴板相关代码，改为调用Excel宏时直接传递bdtxt参数：

Sub Q_copy(msg As Outlook.MailItem)
    Dim xExcelFile As String
    Dim xExcelApp As Excel.Application
    Dim wb As Excel.Workbook
    Dim bd As Variant
    Dim bdtxt As String
    
    If Now() < msg.SentOn + TimeValue("00:01:00") Then
        ' 移除空行逻辑保持不变
        bd = Split(msg.Body, vbNewLine)
        j = 0
        For i = LBound(bd) To UBound(bd)
            If bd(i) <> "" And bd(i) <> " " Then
                bd(j) = bd(i)
                j = j + 1
            End If
        Next i
        ReDim Preserve bd(LBound(bd) To j - 1)
        bdtxt = Trim(Join(bd, vbNewLine))
        
        ' 启动/获取Excel实例
        On Error Resume Next
        Set xExcelApp = GetObject(, "Excel.Application")
        On Error GoTo 0
        
        If xExcelApp Is Nothing Then
            Set xExcelApp = CreateObject("Excel.Application")
        End If
        
        Set wb = xExcelApp.Workbooks.Open("\\FS06\Users6\a78208\Dokument\Filtrera Quinyx.xlsm")
        xExcelApp.Visible = True
        
        ' 直接传递数据给Excel宏，跳过剪贴板
        xExcelApp.Application.Run "Modul1.LoadDataToForm", bdtxt
        xExcelApp.Application.Run "Modul1.leta_namn"
    End If
End Sub

修改Excel工作簿代码 #

新增一个接收参数的宏，替换原有的test和paste：

' 新增：接收Outlook传递的数据并加载到用户窗体
Sub LoadDataToForm(emailBodyText As String)
    UserForm1.Show (0)
    UserForm1.TextBox1.Text = emailBodyText
    UserForm1.Palm.Value = True
End Sub

Sub leta_namn()
    UserForm1.CommandButton1_Click
End Sub

此方案完全绕开剪贴板，无论电脑是否锁定都能稳定运行，是最可靠的解决方式。

方案2：等待电脑解锁（备选） #

如果必须保留剪贴板逻辑，可通过检测写入结果，循环重试最长30分钟：

修改Outlook宏中的剪贴板部分代码 #

替换原剪贴板相关代码为以下逻辑：

Dim MSForms_DataObject As Object
Dim startTime As Date
startTime = Now()

' 循环尝试写入剪贴板，最长等待30分钟
Do
    On Error Resume Next
    Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    MSForms_DataObject.SetText Trim(bdtxt)
    MSForms_DataObject.PutInClipboard
    On Error GoTo 0
    
    ' 如果成功写入，退出循环
    If Err.Number = 0 Then Exit Do
    
    ' 等待10秒后重试
    Application.Wait Now() + TimeValue("00:00:10")
    
    ' 超过30分钟则停止等待
Loop Until Now() > startTime + TimeValue("00:30:00")

Set MSForms_DataObject = Nothing

注意：此方案依赖系统状态，锁屏期间可能仍存在资源限制导致失败，因此优先推荐方案1。

内容的提问来源于stack exchange，提问作者Andreas