warbe
01-08-2019, 08:38 AM
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
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