VBA - 将电子邮件对象（OLEFormat）从剪贴板保存到文件

Question

我正在尝试使用拖放功能将电子邮件从 Outlook 拖到 Excel 中并保存到文件夹中。这是一个更大的宏的一部分，该宏记录信息并将其上传到服务器。没有简单的方法可以做到这一点，但我想我已经几乎破解了它。我正处于可以获得一些有用的东西的阶段 - 但需要太长时间并且很容易被用户打断。

我的 Excel VBA 代码执行以下步骤：

• 打开一个新的Word实例并创建一个新文档
• 监视文档的

  WordApp_WindowSelectionChange

  事件，该事件在将电子邮件拖放到文档上时触发。
• 检查

  WordApp_WindowSelectionChange

  事件是否因嵌入电子邮件而触发。
• 如果是电子邮件，则将嵌入的电子邮件（位于

  OLEFormat

  中）复制到剪贴板。如果这不是电子邮件，则不执行任何操作。
• 将电子邮件复制到剪贴板后，关闭 Word 文档和应用程序。'
• 使用

  Shell

  打开资源管理器窗口，然后暂停以允许窗口打开。
• 使用发送键将电子邮件粘贴到资源管理器窗口：

  Applicaiton.sendkeys "^v"

  。

这段代码确实有效！但它的速度很慢，因为必须打开资源管理器窗口，更糟糕的是，如果用户在 Excel 等待资源管理器窗口打开时单击并将焦点窗口设置在其他位置，则 Application.Sendkeys 消息会发送到其他位置，整个过程就会失败。

我想做的就是直接从剪贴板获取 OLEFormat 电子邮件并使用 VBA 保存它。我找到了许多针对图像或其他文件类型执行此操作的解决方案，但找不到适用于电子邮件的解决方案。有人可以帮忙吗？

仅供参考，我之前曾尝试使用 Excel 直接使用 Outlook 保存 OLEFormat 电子邮件，但我的安全设置不允许这样做。如果有人有一种无需使用剪贴板即可工作的替代方法，我很乐意考虑。我的主要限制是它必须可以使用 VBA 从 Excel 完成。

Answer 1

SetForegroundWindow

函数应该可以解决用户更改焦点窗口的问题。 还可以使用 WinAPI 预先打开资源管理器窗口并隐藏/显示它。

#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
#End If

Sub SetForegroundWindowByTitle(windowTitle As String)
    Dim hWnd As LongPtr
    ' Find the window handle based on the window title
    hWnd = FindWindow(vbNullString, windowTitle)
    
    If hWnd <> 0 Then
        ' Set the found window as the foreground window
        SetForegroundWindow hWnd
    Else
        Debug.Print "Window not found: " & windowTitle
    End If
End Sub

WebBrowser1 作为文件资源管理器 (FileView)

我不清楚为什么使用 MS Word（大概是为了捕获拖放事件），或者为什么用户不简单地将文件拖到文件资源管理器中。 另一种选择是在用户窗体上使用 WebBrower 控件作为文件资源管理器 (FileView)。

通过这个简单的设置，我们可以获得被放入网络浏览器中的电子邮件列表。

Option Explicit
Private WithEvents FolderView As Shell32.ShellFolderView

Private Sub FolderView_SelectionChanged()
    ListBox1.Clear
    Dim Item As FolderItem2
    
    For Each Item In FolderView.SelectedItems
        If Item.Type = "Outlook Item" Then
            If Item.ExtendedProperty("System.DateCreated") > Now - TimeValue("00:00:01") / 4 Then
                ListBox1.AddItem Item.Name
            End If
        End If
    Next
End Sub

Private Sub UserForm_Initialize()
    Dim Document
    
    WebBrowser1.Navigate "file:///D:/vba/test_WebBrowser"
    While WebBrowser1.Busy
        DoEvents
    Wend
    Set FolderView = WebBrowser1.Document
    
End Sub

注意：可以将 WebBrowser 控件嵌入到工作表中，但我们需要修改注册表才能做到这一点。