在excel窗口中打开附件并复制以打开工作簿

Question

Using outlook VBA - I would like to open an attachment in a particular instance of excel, and then copy the sheets from that attachment into an open workbook.

I've used a couple of code snippets from ( Saving Outlook attachment with date in the filename and Check to see if Excel is open (from another Office 2010 App) to save an attachment from an email and then find the excel window I need to open it in - both work in isolated outlook test macros.

Trouble is, I can't seem to link the two parts together into working code, at the end of all of it I have:

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 are all defined in Check to see if Excel is open (from another Office 2010 App) and are the same in my code.

The last line fails, with runtime error 438: Object doesn't support this property or method. This suggests to me that I'm probably barking up the wrong tree - I'm afraid though that I've no idea which tree to aim for!

Thanks in advance.

Answer 1

Two problems: AccessibleObjectFromWindow returns a Window object and the Open method is a member of Application.Workbooks ; and the window title doesn't have the file extension.

So to solve the first issue:

Set srcWorkbook = wb.Application.Open(attachFileName)

needs to become:

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

And for the second in some installations of Excel:

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

may need to become:

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

Note for future readers: This appears to depend on Windows and Excel versions, and whether or not you enable the "Hide known file extensions" in the windows explorer options.

Finally it seems that the window names need to be pointers (in 64-bit Office only):

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

needs to become:

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