I've successfully managed to display a two-dimensional array filled with data in word in an excel workbook and like to share this here. In order the code compiles the following references are used: Visual Basic For Applications, Microsoft Word 14.0 Object Library, OLE Automation, Microsoft Office 14.0 Object Library, Microsoft Excel 14.0 Object Library. The solution tries to use an existing Excel application instance and provides a proper clean-up once the opened Workbook is closed, i.e. after 'WaitForClose' has finished.
Option Explicit '~~ Declaration for the 'WaitForClose' code -------------------------------------------------------------- #If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems #Else Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems #End If '~~ ------------------------------------------------------------------------------------------------------ Public Sub DsplyInExcel(ByVal a As Variant, _ Optional ByVal sTitle As String = vbNullString) ' ------------------------------------------------------------ ' Displays the array a in an existing or new temporary ' Workbook, waits until it is closed and quits the Excel ' instance when there are no more Workbooks in it. ' ------------------------------------------------------------ Dim sWbkFullName As String Dim rng As Excel.Range Dim lRows As Long Dim lCols As Long Dim xlApp As Excel.Application Dim xlWbk As Excel.Workbook Dim xlWsh As Excel.Worksheet '~~ Compile a temorary workbook file name sWbkFullName = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & "temp.xls" Set xlApp = App(sWbkFullName) ' existing/new application instance Set xlWbk = Wbk(xlApp, sWbkFullName) ' existing/new Workbook Set xlWsh = Wsh(xlWbk) ' the first sheet in xlWbk With xlWsh .UsedRange.Clear '~~ Display array a ----------------------- lRows = UBound(a, 1) - LBound(a, 1) + 1 lCols = UBound(a, 2) - LBound(a, 2) + 1 Set rng = .Cells(1, 1).Resize(lRows, lCols) rng.Value = a End With xlApp.Visible = True AppActivate ("Microsoft Excel") WaitForClose sWbkFullName, xlApp If xlApp.Workbooks.Count = 0 Then xlApp.Quit ' Quit instance only when empty Set xlWbk = Nothing Set xlApp = Nothing End Sub Private Function App(ByVal sWbk As String) As Excel.Application ' --------------------------------------------------------------- ' Provides an Excel instance, either an existing or a new one ' preferrably the one in which the Workbook sWbk is already open. ' --------------------------------------------------------------- Dim xlApp As Excel.Application '~~ 1. Preference: An instance in which the Workbook sWbk is already open On Error Resume Next Set xlApp = GetObject(sWbk).Application On Error GoTo -1 If xlApp Is Nothing Then '~~ 2. Preference: An already existing Excel instance Set xlApp = GetObject(, "Excel.Application") On Error GoTo -1 If xlApp Is Nothing Then '~~ 3. A new Excel instance Set xlApp = New Excel.Application End If End If If Not xlApp Is Nothing Then Set App = xlApp Else MsgBox "Providing an Excel application instance failed", vbCritical, "Error" End If End Function Private Function Wbk(ByVal xlApp As Excel.Application, _ ByVal sWbkFullName As String) ' --------------------------------------------------- ' Returns an existing or a new Excel Workbook. ' Precondition: xlApp is an existing Excel instance ' and, if existing, the one with the Workbook named ' sWbkFullName open. ' --------------------------------------------------- Dim xlWbk As Excel.Workbook If CreateObject("Scripting.FileSystemObject").FileExists(sWbkFullName) Then If FileInUse(sWbkFullName) Then ' ~~ Make use of the already open Workbook For Each xlWbk In xlApp.Workbooks If xlWbk.FullName = sWbkFullName Then Exit For End If Next xlWbk Else ' Open the yet not in use but already existing Workbook Set xlWbk = xlApp.Workbooks.Open(sWbkFullName) End If Else '~~ Create a new Workbook Set xlWbk = xlApp.Workbooks.Add xlWbk.SaveAs sWbkFullName, FileFormat:=-4143 End If If Not xlWbk Is Nothing Then Set Wbk = xlWbk Else MsgBox "Providing a temp Workbook in xlWbk failed", vbCritical, "Error" End If End Function Private Function Wsh(ByVal xlWbk As Excel.Workbook) As Excel.Worksheet ' -------------------------------------------------------------------- ' Sets xlWsh to a Worksheet in the temporary Workbook xlWbk ' Precondition: xlWbk is a Workbook object ' -------------------------------------------------------------------- Dim xlWsh As Excel.Worksheet On Error GoTo error If xlWbk.Worksheets.Count > 0 _ Then Set xlWsh = xlWbk.Worksheets(1) _ Else Set xlWsh = xlWbk.Worksheets.Add error: On Error GoTo -1 If Not xlWsh Is Nothing Then Set wsh = xlWsh Else MsgBox "Providing an xlWbk-Worksheet failed", vbCritical, "Error" End If End Function Private Sub WaitForClose(ByVal sWbk As String, _ Optional ByVal oApp As Excel.Application = Nothing) ' ----------------------------------------------------------------- ' Precondition: oApp when provided the (or there is an) Excel ' instance with the Workbook sWbk open. ' ----------------------------------------------------------------- Dim bOpen As Boolean Dim xlWbk As Excel.Workbook If oApp Is Nothing Then Set oApp = GetObject(sWbk).Application Do If oApp.Workbooks.Count = 0 Then Exit Sub bOpen = False For Each xlWbk In oApp.Workbooks If xlWbk.FullName = sWbk Then bOpen = True Next If bOpen Then Sleep 1000 Loop While bOpen End Sub Private Function FileInUse(ByVal sFileName As String) As Boolean On Error Resume Next Open sFileName For Binary Access Read Lock Read As #1 Close #1 FileInUse = IIf(Err.Number > 0, True, False) On Error GoTo -1 End Function
Reply With Quote
Originally Posted by Dave
