OLEObjects.Add Results In Multiple Instances of Excel

[B99]

I posted this on another forum but haven't gotten any results so I'm hoping I'll have better luck here. I have an Access DB that exports data to Excel, including images and documents that I insert using OLEObjects.Add. This is my first time using this function and it has been a learning process but after countless iterations, I have it 'mostly' working. The end result spreadsheet is what I want, however when there is an Excel spreadsheet that is being inserted into the target spreadsheet, the process creates (and leaves open) multiple instances of Excel - two additional instances for each inserted Excel sheet. The additional instances do not have any worksheets open but they are active, meaning I can navigate menus, etc. This does not happen for other Office documents or PDFs, only Excel files. And what's even more strange is that I am unable to close several of the instances after the process completes.

Here is the code I'm using to insert the files:

  Dim xlApp As Excel.Application    'Open the Excel application
  Dim xlBook As Excel.Workbook      'Create a new Excel workbook
  Dim xlImg As Excel.Worksheet      'Create a tab with Attachment details

  Set xlApp = Excel.Application
  Set xlBook = xlApp.Workbooks.Add

'First I add a 'data only' worksheet and do some processing on it, then add a new sheet below for the attachments

  xlBook.Worksheets.Add
  Set xlImg = xlBook.Worksheets(1)

'I get the filename from a recordset
'strIcon is the default executable for the file type
'strAtchName is the file name without the path

xlBook.ActiveSheet.OLEObjects.Add(FileName:=<recordset filename>, _
          Link:=False, DisplayAsIcon:=True, IconFileName:=strIcon, _
          Left:=ActiveSheet.Range("D" & x).Left, Width:=13, _
          Top:=ActiveSheet.Range("D" & x).Top, Height:=56, _
          iconlabel:=strAtchName).Select

'More formatting, then cleanup

Here is a screenshot where there were 6 files that were inserted into the export spreadsheet; 3 Excel files, one Word doc, one PDF and one PPT. Excel was closed before the export, and the screenshot shows 7 instances were running after the process completed.

If I try to close any of the 7, it asks me if I want to save the changes to the export spreadsheet (Book5 in this case). After saving (or discarding), 4 of the instances close and I am left with "ExcelTest2.xlsx", "Excel" and "Book1.xlsx" in this example. I am unable to close any of those without forcing it in Task Manager. However, if I open a new (unrelated) Excel file and close it, two of the instances disappear and if I repeat that process, the third one disappears.

Any ideas on what I can do to either prevent the extra instances from opening or somehow close them? I want to leave the main spreadsheet open so that the user can review it. Thanks in advance for any help!

 

[B99]

Apologies again for the delay...I am sufficiently sunburned and back at work now. First, thank you both for the time spent trying to help me out. It is very much appreciated! Unfortunately the changes to the code didn't help...maybe. As for the processes, here is what I have after running the code and starting out with Excel closed: They all stay open, at least for several minutes that I've been waiting.

When I made the latest code changes, Access thought "Dictionary" was a user defined type. I've never used it before but read the MS documentation and made a few changes until it compiled and ran without errors. This is a little above my head so I may have broken it but here's the code I have now. The changes are marked with "XXX 9/25"

Option Compare Database
Option Explicit
'XXX 9/25
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long

Private Sub cmdExport_Click()
'******************************************************************************
' Export data into an Excel spreadsheet.  The code is based on:
'http://accessjitsu.com/2015/09/13/code-listing-exporting-data-from-access-to-excel-part-4-formatting/
'******************************************************************************
On Error GoTo ErrProc
  
  Dim xlApp As Excel.Application    'Create an instance of Excel application
  Dim xlBook As Excel.Workbook      'Create a new Excel workbook
  Dim xlAtch As Excel.Worksheet      'Create a tab with Attachment details
  Dim strSQL As String              'SQL for the Attachment recordset
  Dim rsAtch As DAO.Recordset        'Attachment recordset
  Dim x As Integer                  'Counter for Attachment line numbers
  Dim Img As Excel.Shape            'Process the Image Attachments
  Dim Atch As OLEObject             'Process the non-Image Attachments
  'XXX 9/25
  'Dim KeepTheseProcessesOpen As New Dictionary
  Dim KeepTheseProcessesOpen
  Set KeepTheseProcessesOpen = CreateObject("Scripting.Dictionary")
  Dim PID As Long
  
  'Turn on the hourglass; the export takes a few seconds
  DoCmd.Hourglass (True)
  
  'Create an instance of Excel.  Keep it hidden until it is finished
  Set xlApp = New Excel.Application
  xlApp.Visible = False
  Set xlBook = xlApp.Workbooks.Add
  xlBook.Worksheets.Add
  
  'Build the Image Reference SQL
  strSQL = "SELECT * FROM tblAttachments"

  'Open the recordset
  Set rsAtch = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
  
  'Add a new worksheet
  Set xlAtch = xlBook.Worksheets(1)
  
  With xlAtch
    .Name = "Attachments"
    .Cells.Font.Name = "Calibri"
    .Cells.Font.Size = 11
        
    'Build Column Headings
    .Range("A1").Value = "Name"
    .Range("B1").Value = "Attachment"
    .Range("C1").Value = "Attachment Path"
      
    .Range("A2:A5").RowHeight = 65
    .Columns("B").ColumnWidth = 17
    
    'Populate the detail data
    x = 2   'Set initial row counter
    Do While Not rsAtch.EOF
      .Range("A" & x).Value = Nz(rsAtch!AttachmentName, "")
      .Range("C" & x).Value = Nz(rsAtch!attachmentpath, "")

      If rsAtch!AttachmentType = "Image" Then
                  
        'Add the image; the initial size is set at 2000 and then resized below.
        'Otherwise, the image is blurry when expanded by the user
        Set Img = .Shapes.AddPicture(FileName:=rsAtch!attachmentpath, _
                  linktofile:=msoFalse, savewithdocument:=msoCTrue, _
                  Left:=.Range("B" & x).Left, Width:=2000, _
                  Top:=.Range("B" & x).Top, Height:=2000)
        
        'Resize the image
        Img.Width = .Range("B" & x).Width           'Width = cell width
        Img.Height = .Range("B" & x).Height         'Height = cell height
        Img.Placement = 1                           'Move and size with the cell
    
      Else 'non-image attachment
        
        Set Atch = .OLEObjects.Add(FileName:=rsAtch!attachmentpath, _
          iconindex:=0, _
          Link:=False, DisplayAsIcon:=True, IconFileName:=rsAtch!iconpath, _
          Left:=.Range("B" & x).Left, Width:=.Range("B" & x).Width, _
          Top:=.Range("B" & x).Top, Height:=.Range("B" & x).Height)
          
        Atch.Placement = 1                           'Move and size with the cell
      
      End If
      
      x = x + 1
      rsAtch.MoveNext
    
    Loop
    
    'Format the detail section as an Excel table
    .ListObjects.Add(xlSrcRange, .Range("$A$1:$C$" & x - 1), , xlYes).Name = "Attachments"
    .Range("Attachments[#All]").Select
    .ListObjects("Attachments").TableStyle = "TableStyleLight8"
    
    .Range("A2").Select     'Put the focus on the first data cell
    .Columns("A:C").AutoFit 'Autofit the column widths
    
  End With

ExitProc:
  
  On Error Resume Next
  DoCmd.Hourglass False   'Turn off the hourglass
  xlApp.Visible = True    'Set Excel to visible
  'Cleanup
  rsAtch.Close
  Set rsAtch = Nothing
  Set Img = Nothing
  Set Atch = Nothing
  
   'kill all Excel processes not in our list XXX 9/25
  KillExcelProcesses KeepTheseProcessesOpen
  
  Exit Sub
  
ErrProc:
  MsgBox Err.Number & "; " & Err.Description, vbOKOnly, "Error"
  Resume ExitProc

End Sub

Private Function ExcelProcesses() As Object
    Dim WMI
    Set WMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
      Environ("COMPUTERNAME") & "\root\cimv2")
    
    Set ExcelProcesses = WMI.ExecQuery("select * from win32_process where Name = ""EXCEL.EXE""")
End Function

'Private Function GetExcelProcesses() As Dictionary
Private Function GetExcelProcesses() As Variant

    'Dim ret As New Dictionary, Process As Object XXX 9/25
    Dim ret
    Dim Process As Object
    
    Set ret = CreateObject("Scripting.Dictionary")
  
    For Each Process In ExcelProcesses()
        ret.Add Process.ProcessId, Null
    Next
    Set GetExcelProcesses = ret
End Function

'Private Sub KillExcelProcesses(ExceptForThese As Dictionary) XXX 9/25
Private Sub KillExcelProcesses(ExceptForThese As Variant)
    'Dim ret As New Dictionary, Process As Object  XXX 9/25
    Dim ret
    Dim Process As Object
    
    Set ret = CreateObject("Scripting.Dictionary")
  
    For Each Process In GetExcelProcesses()
        If Not ExceptForThese.Exists(Process.ProcessId) Then Process.Terminate
    Next
End Sub

It also makes me slightly nervious that Micron has a different experience. This will be distributed and I need it to be consistent. Worst case, maybe I can save the file to a directory, close and then reopen it. If I don't make it visible, it doesn't create extra instances (that I can detect) so maybe it will close cleanly after saving...

 

[B99]

I think I found a workable solution. I hit several hurdles trying to save the file but ran across another option. I don't mind if Excel is visible during the export, I just didn't want the user to see everything flying around. It turns out if I leave it visible and set .ScreenUpdating = False at the start, then set it to True at the end, it behaves exactly as it should. I actually set it to False after adding the title to the worksheet so the user isn't just staring at a blank sheet.

I also noticed that I had inconsistent results with this initially. Sometimes it would show the sheet with the title, sometimes it would just show the blank sheet. I added a wait function starting with 0.1 seconds and ended up with a full second before it reliably showed the title before stopping the screen update.

It's not my first choice, and it really bothers me that I can't find a solution to the other approach, but it does seem to work.

Thanks again for your help! ?
-Brian