Question

使用Outlook VBA - 我想在excel的特定实例中打开附件，然后将该附件中的工作表复制到打开的工作簿中。

我使用了来自（Saving Outlook attachment with date in the filename和Check to see if Excel is open (from another Office 2010 App)的几个代码段来保存电子邮件中的附件，然后找到我需要打开它的excel窗口 - 两者都在单独的outlook中工作测试宏。

麻烦的是，我似乎无法将这两个部分连接成工作代码，在我所有的部分结尾处：

Option Explicit
Private Declare Function newFindWindowEx Lib "user32" Alias "FindWindowExA" _
 (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
 ByVal lpsz2 As String) As Long

 Private Declare Function GetDesktopWindow Lib "user32" () As Long

 Private Declare Function AccessibleObjectFromWindow& Lib "oleacc" _
  (ByVal hwnd&, ByVal dwId&, riid As newGUID, xlWB As Object)

Private Const newOBJID_NATIVEOM = &HFFFFFFF0

Private Type newGUID
    lData1 As Long
    iData2 As Integer
    iData3 As Integer
    aBData4(0 To 7) As Byte
End Type


Sub AttachmentToExcel()

  Dim obj As Object
  Dim msg As Outlook.MailItem

  Dim objAtt As Object, iDispatch As newGUID
  Dim sPath As String, sFileName As String, sFile As String, filewithoutExt As String
  Dim attachFileName As String, DealID As String
  Dim srcWorkbook As Object

  sPath = "\\eu.insight.com\users\mklefass\Data\Desktop\"
  sFileName = "Test Workbook.xlsx": filewithoutExt = "Test Workbook.xlsx"
  sFile = sPath & sFileName


  Set obj = GetCurrentItem
  If TypeName(obj) = "MailItem" Then
      Set msg = obj
      DealID = FindDealID(msg.Subject)

      For Each objAtt In msg.Attachments
        If Right(objAtt.FileName, 4) = ".txt" Then
            attachFileName = "C:\Users\mklefass\Desktop\tmp\" & objAtt.FileName & ".tsv"
            objAtt.SaveAsFile attachFileName
            Set objAtt = Nothing
        End If
      Next

    ' Find window that has our main workbook open

      Dim dsktpHwnd As Long, hwnd As Long, mWnd As Long, cWnd As Long, wb As Object

      newSetIDispatch iDispatch

      dsktpHwnd = GetDesktopWindow

      hwnd = newFindWindowEx(dsktpHwnd, 0&, "XLMAIN", vbNullString)

      mWnd = newFindWindowEx(hwnd, 0&, "XLDESK", vbNullString)

      While mWnd <> 0 And cWnd = 0
        cWnd = newFindWindowEx(mWnd, 0&, "EXCEL7", filewithoutExt)
        hwnd = newFindWindowEx(dsktpHwnd, hwnd, "XLMAIN", vbNullString)
        mWnd = newFindWindowEx(hwnd, 0&, "XLDESK", vbNullString)
      Wend

    '~~> We got the handle of the Excel instance which has the file
      If cWnd > 0 Then
        '~~> Bind with the Instance
        Debug.Print AccessibleObjectFromWindow(cWnd, newOBJID_NATIVEOM, iDispatch, wb)
        '~~> Work with the file

        Set srcWorkbook = wb.accParent.Application.Workbooks.Open(attachFileName)
        'srcWorkbook.Worksheets(sheetNr).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

        srcWorkbook.Close
        Set srcWorkbook = Nothing
      End If
   End If

End Sub
Private Sub newSetIDispatch(ByRef ID As newGUID)
 With ID
    .lData1 = &H20400
    .iData2 = &H0
    .iData3 = &H0
    .aBData4(0) = &HC0
    .aBData4(1) = &H0
    .aBData4(2) = &H0
    .aBData4(3) = &H0
    .aBData4(4) = &H0
    .aBData4(5) = &H0
    .aBData4(6) = &H0
    .aBData4(7) = &H46
 End With
End Sub

SetIDispatch，Findwindowex，accessibleobjectfromwindow都在Check to see if Excel is open (from another Office 2010 App)中定义，并且在我的代码中是相同的。

最后一行失败，运行时错误438：对象不支持此属性或方法。这告诉我，我可能正在咆哮错误的树 - 我害怕，虽然我不知道要瞄准哪棵树！

提前致谢。

Answer 1

两个问题：AccessibleObjectFromWindow返回Window个对象，Open方法是Application.Workbooks的成员;并且窗口标题没有文件扩展名。

所以要解决第一个问题：

Set srcWorkbook = wb.Application.Open(attachFileName)

需要成为：

Set srcWorkbook = wb.Parent.Application.Workbooks.Open(attachFileName)

对于Excel的某些安装中的第二个：

cWnd = FindWindowEx(mWnd, 0&, "EXCEL7", "Test Workbook.xlsx")

可能需要成为：

cWnd = FindWindowEx(mWnd, 0&, "EXCEL7", "Test Workbook")

未来读者注意：这似乎取决于Windows和Excel版本，以及是否在Windows资源管理器选项中启用“隐藏已知文件扩展名”。

最后似乎窗口名称需要是指针（仅限64位Office）：

Dim dsktpHwnd As Long, hwnd As Long, mWnd As Long, cWnd As Long, wb As Object

需要成为：

Dim dsktpHwnd As LongPtr, hwnd As LongPtr, mWnd As LongPtr, cWnd As LongPtr, wb As Object

在Excel窗口中打开附件并复制到打开工作簿

1 个答案: