Show Word doc in XL userform frame

[NdNoviceHlp]

My objective is to present a quick view of stored Word documents within an XL userform frame (a userfom listbox would contain the file names and a selection would display the doc within the userform frame). Not quite there yet. The following XL code copies the contents of the Word doc, pastes it to a chart, creates a jpeg file then loads the pic to the XL userform frame. To maintain the doc format it seems the chart has to be sized similar to the Word doc. Now for the issues, the document header/footer is not copied and only 1 doc page is copied. Not sure that these can be fixed and maybe really not important to the quick view objective. It all seems to work somewhat adequately with XL 2016 and Windows 10 however not so much in earlier office versions and/or earlier Windows os… the formatting deteriorates. Any ideas where to start looking... it seems like the document width/height is different? Also, an API solution seems like it should be possible. The only problem seems to be that the doc is copied as a jpeg not as a bmp file. Here is a link to a thread involving making pic files of XL ranges.
https://www.mrexcel.com/forum/excel...en-shot-given-range-every-worksheet-file.html
If someone could convert the API code to taking pic files of Word documents, it seems like that approach would be much better and may resolve my version issues. Anyways, thanks for any help. Dave
XL module code...

Public PFWdApp As Object
Public PagFlag As Boolean
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long

Public Sub NofileEr1()
'open Word application
On Error Resume Next
Set PFWdApp = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set PFWdApp = CreateObject("Word.Application")
'turn on pagination
End If
If PFWdApp.Options.Pagination = False Then
PFWdApp.Options.Pagination = True
PagFlag = True
End If
End Sub

A large XL userform with a document wide Frame code...

Option Explicit
Sub ShowDocFrame()
Dim Fname As String, ht As Double, wt As Integer, FS As Object
Dim Flag As Boolean, ObjPic As Object, TmpFl As String
'Excel Userform code. Word doc image to XL userform frame
'requires Userform1 with Frame1 and sheet1 and sheet2 in wb
'places document image to Frame1 in Userform1

'check for open Word
Call NofileEr1
'copy test doc contents
Fname = "C:\testfolder\test.doc"

Set FS = CreateObject("Scripting.FileSystemObject")
If FS.fileexists(Fname) Then
Flag = False
PFWdApp.Documents.Open Filename:=Fname, ReadOnly:=False
PFWdApp.activedocument.Windows(1).View.Type = 3 'wdPrintView
ht = 0
'get ht for chart from inlineshapes
For Each ObjPic In PFWdApp.activedocument.InlineShapes
ht = ht + ObjPic.Height
Flag = True
Next ObjPic
'get ht for chart from shapes
For Each ObjPic In PFWdApp.activedocument.Shapes
ht = ht + ObjPic.Height
Flag = True
Next ObjPic
'get ht for chart from text
If Not Flag Then
PFWdApp.activedocument.Characters.Last.Select
If PFWdApp.Selection.Information(3) < 2 Then 'page info
ht = PFWdApp.Selection.Information(6) 'wdVerticalPositionRelativeToPage
Else
ht = 792 ' 11 inches in points(72/in)
End If
End If
'copy content & close doc
PFWdApp.activedocument.Content.Copy
PFWdApp.activedocument.Close savechanges:=False

'paste to chart, make pic file, delete chart
Charts.Add.Location Where:=xlLocationAsObject, Name:="Sheet2"
TmpFl = ThisWorkbook.Path & "\" & "test.jpg"
With ActiveChart
.Parent.Width = UserForm1.Frame1.InsideWidth
.Parent.Height = ht
.Paste
.Export Filename:=TmpFl, Filtername:="jpg"
End With
wt = ActiveChart.ChartArea.Width
ht = ActiveChart.Parent.Height
ActiveChart.ChartArea.Select
ActiveWindow.Visible = False
ActiveChart.Parent.Delete
Sheets("Sheet1").Select
Sheets("Sheet1").Range("A1").Select

'load pic to userform frame
With UserForm1.Frame1
.ScrollBars = fmScrollBarsBoth
.KeepScrollBarsVisible = fmScrollBarsBoth
.ScrollWidth = wt
.ScrollHeight = ht
.Picture = LoadPicture(TmpFl)
.BorderStyle = fmBorderStyleNone
.Caption = vbNullString
End With

'clean up
Kill TmpFl
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
Else
MsgBox "NO file"
End If
Set FS = Nothing
If PagFlag Then
PFWdApp.Options.Pagination = False
End If
PFWdApp.Quit
Set PFWdApp = Nothing
Application.ScreenUpdating = True
Exit Sub

Erfix:
On Error GoTo 0
MsgBox "Error"
If PagFlag Then
PFWdApp.Options.Pagination = False
End If
Set FS = Nothing
PFWdApp.Quit
Set PFWdApp = Nothing
Application.ScreenUpdating = True
End Sub

The code requires the wb to have sheet2. The Word doc file name/location needs to be adjusted in this line...

Fname = "C:\testfolder\test.doc"

To operate...

Call ShowDocFrame

 

[NdNoviceHlp]

I gave up on using a chart for this. It just didn't seem to maintain format across versions/different pcs and I wasn't all that sure if the problem wasn't related to screen resolution and/or DPI settings across pcs. Anyways, I resolved this using the API approach posted at the above link. The resolution continues not to include header/footers but does provide for viewing of all the document pages. It seems to work across versions and on different pc's. To set up, add a userform (Userform1) to an empty wb. Place a large (document width size) frame on the userform. Set the background property of the frame to white. Add a listbox (Listbox1) to the userform. Add a spinbutton (spinbutton1) to the userform. Add a module to the wb and place this API code in it. Note that this API code is for 32 bit installations only and will crash if U have a 64 bit installation.
Module code...

 'Thanks to Stephan Bullen for most of this API code
'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

'Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type

'Does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the clipboard to read
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'Get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'Close the clipboard
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal N2 As Long, ByVal un2 As Long) As Long

'The API format types we're interested in
Public Const CF_BITMAP = 2
Private Const CF_PALETTE = 9
Public Const CF_ENHMETAFILE = 14
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4

'OLE Picture types
Private Const PICTYPE_BITMAP = 1
Private Const PICTYPE_ENHMETAFILE = 4
'======================================================================================================

Public Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture
Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long

'Convert the type of picture requested from the xl constant to the API constant
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
'Check if the clipboard contains the required format
hPicAvail = IsClipboardFormatAvailable(lPicType)

If hPicAvail <> 0 Then
h = OpenClipboard(0&)   'Get access to the clipboard
If h > 0 Then
hPtr = GetClipboardData(lPicType) 'Get a handle to the image data
'Create our own copy of the image on the clipboard, in the appropriate format.
If lPicType = CF_BITMAP Then
    hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
    hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If

'clear then close clipboard
EmptyClipboard

h = CloseClipboard  'Release the clipboard to other programs

'If we got a handle to the image, convert it into a Picture object and return it
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
End If
End If
End Function

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture

' Create the Interface GUID (for the IPicture interface)
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With

' Fill uPicInfo with necessary parts.
With uPicInfo
.Size = Len(uPicInfo) ' Length of structure.
.Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture
.hPic = hPic ' Handle to image.
.hPal = IIf(lPicType = CF_BITMAP, hPal, 0) ' Handle to palette (if bitmap).
End With

' Create the Picture object.
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
' If an error occured, show the description
If r <> 0 Then Debug.Print "Create Picture Error" ' & fnOLEError(r) 'Requires a reference to the "OLE Automation" type library

Set CreatePicture = IPic    ' Return the new Picture object.
End Function

Now add another module to your wb and place this code...

Option Explicit
Public PageCollect As Collection, HtArr() As Variant, SpinCnt As Integer, TempName As String
Public PFWdApp As Object, PagFlag As Boolean, FolderName As String, PageCnt As Integer

Public Sub CloseSummaryDoc()
'close active doc
Dim temp As Object
On Error Resume Next
Set temp = PFWdApp.ActiveDocument
If Err.Number <> 0 Then
On Error GoTo 0
Exit Sub
End If
PFWdApp.ActiveDocument.Close savechanges:=False
Set temp = Nothing
End Sub

Public Sub NofileEr1()
'open Word application
On Error Resume Next
Set PFWdApp = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set PFWdApp = CreateObject("Word.Application")
'turn on pagination
End If
If PFWdApp.Options.Pagination = False Then
PFWdApp.Options.Pagination = True
PagFlag = True
End If
End Sub

Public Sub NofileEr2()
'close Word application
On Error Resume Next
Set PFWdApp = GetObject(, "word.application")
If Err.Number = 0 Then
'reset pagination
If PagFlag Then
PFWdApp.Options.Pagination = False
End If
PFWdApp.Quit
End If
On Error GoTo 0
Set PFWdApp = Nothing
End Sub

Public Function GetPageSize(Fpath As String) As Double
Dim cnt As Integer
PFWdApp.Visible = False
PFWdApp.Documents.Open (Fpath)
With PFWdApp.ActiveDocument
.Range(0, .Characters.Count).Delete
.Content.InsertAfter Chr(13)
cnt = 1
Do Until .Paragraphs(cnt).Range.Information(3) <> _
.Paragraphs(cnt + 1).Range.Information(3)
.Content.InsertAfter Chr(13)
cnt = cnt + 1
Loop
GetPageSize = .Paragraphs(cnt).Range.Information(6)
.Close savechanges:=False
End With
End Function

Public Sub ShowDocFrame2(Fpath As String)
Dim FullPageFrame As Double, LastPara As Integer, Cnt2 As Integer, cnt As Integer, ObjPic As Object
Dim FrameHt As Double, ParaCnt As Integer, MyRange As Variant, PageStr As String

'close doc
Call CloseSummaryDoc
'check for open Word
Call NofileEr1

FullPageFrame = GetPageSize(Fpath)
PFWdApp.Visible = False
PFWdApp.Documents.Open (Fpath)
LastPara = PFWdApp.ActiveDocument.Content.Paragraphs.Count
'inline shapes (charts)
If PFWdApp.ActiveDocument.InlineShapes.Count <> 0 Then
    With PFWdApp.ActiveDocument
        .Content.InsertAfter Chr(13)
    LastPara = .Content.Paragraphs.Count
    End With
    'start of new page
    If PFWdApp.ActiveDocument.Paragraphs(LastPara - 1).Range.Information(3) <> _
    PFWdApp.ActiveDocument.Paragraphs(LastPara).Range.Information(3) Then
    LastPara = LastPara - 1
    End If
    'more than 1 page (LastPara page)
    If PFWdApp.ActiveDocument.Paragraphs(LastPara).Range.Information(3) > 1 Then
    ReDim Preserve HtArr(PFWdApp.ActiveDocument.Paragraphs(LastPara).Range.Information(3))
    For Cnt2 = 1 To PFWdApp.ActiveDocument.Paragraphs(LastPara).Range.Information(3) - 1
    HtArr(Cnt2 - 1) = FullPageFrame
    Next Cnt2
    FrameHt = PFWdApp.ActiveDocument.Paragraphs(LastPara).Range.Information(6)
    HtArr(Cnt2 - 1) = FrameHt
    Else
    ReDim HtArr(1)
    FrameHt = PFWdApp.ActiveDocument.Paragraphs(LastPara).Range.Information(6)
    HtArr(0) = FrameHt
    End If
End If

'get FrameHt for shapes (range pics)
If PFWdApp.ActiveDocument.Shapes.Count <> 0 Then
FrameHt = PFWdApp.ActiveDocument.Shapes(1).Height
'FrameHt = ObjPic.Height
ReDim HtArr(1)
HtArr(0) = FrameHt
End If

PageCnt = 1
ParaCnt = 1
Set PageCollect = New Collection
For cnt = 1 To LastPara 'LastPara paragraph(line#)
' 1 page only or LastPara page
If cnt = LastPara Then
    Set MyRange = PFWdApp.ActiveDocument.Paragraphs(ParaCnt).Range
    MyRange.SetRange Start:=MyRange.Start, _
        End:=PFWdApp.ActiveDocument.Paragraphs(LastPara).Range.End
    PageCollect.Add MyRange
    If FrameHt = 0 Then
    ReDim Preserve HtArr(PageCnt)
    HtArr(PageCnt - 1) = PFWdApp.ActiveDocument.Paragraphs(LastPara).Range.Information(6)
    End If
    GoTo below
End If

'loop pages
If PFWdApp.ActiveDocument.Paragraphs(cnt).Range.Information(3) > PageCnt Then
If FrameHt = 0 Then
ReDim Preserve HtArr(PFWdApp.ActiveDocument.Paragraphs(cnt).Range.Information(3))
HtArr(PageCnt - 1) = PFWdApp.ActiveDocument.Paragraphs(cnt - 1).Range.Information(6)
End If
Set MyRange = PFWdApp.ActiveDocument.Paragraphs(ParaCnt).Range
MyRange.SetRange Start:=MyRange.Start, _
        End:=PFWdApp.ActiveDocument.Paragraphs(cnt - 1).Range.End
PageCollect.Add MyRange
PageCnt = PFWdApp.ActiveDocument.Paragraphs(cnt).Range.Information(3)
ParaCnt = cnt
End If
Next cnt

below:
If PageCnt > 1 Then
PageStr = "                         Page ( " & SpinCnt & " of " & PageCnt & " )"
Else
PageStr = vbNullString
End If

UserForm1.Caption = UserForm1.ListBox1.Text & PageStr

'show first page
SpinCnt = 1
PageCollect(1).Copy
With UserForm1.Frame1
.ScrollBars = fmScrollBarsBoth
.KeepScrollBarsVisible = fmScrollBarsBoth
.BorderStyle = fmBorderStyleNone
.Caption = vbNullString
.ScrollWidth = UserForm1.Frame1.InsideWidth
.ScrollHeight = HtArr(0)
.Picture = PastePicture(CF_ENHMETAFILE)
End With
End Sub

Public Sub LoadUserForm1()
Dim FS As Object, CountFiles As Integer, ObjFiles As Object, Fl As Object
'**** adjust FolderName to suit****
FolderName = "C:\TestFolder"
Set FS = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set ObjFiles = FS.GetFolder(FolderName).Files
If Err.Number <> 0 Then
CountFiles = 0
Else
CountFiles = ObjFiles.Count
End If
On Error GoTo 0
If CountFiles = 0 Then
MsgBox "No REPORT(S) available."
Set FS = Nothing
Exit Sub
End If
For Each Fl In ObjFiles
UserForm1.ListBox1.AddItem Fl.Name
Next Fl
UserForm1.Show
End Sub

Place this in userform code...

Option Explicit
Private Sub ListBox1_Click()
Dim FS As Object, TempName As String
TempName = "C:\TestFolder" & "\" & UserForm1.ListBox1.Text
Set FS = CreateObject("Scripting.FileSystemObject")
On Error GoTo erfix
    If FS.fileexists(TempName) Then
    Application.Cursor = xlWait
    Call ShowDocFrame2(TempName)
    Application.Cursor = xlDefault
    Else
    MsgBox "No file"
    End If
erfix:
Set FS = Nothing
Application.Cursor = xlDefault
End Sub

Private Sub SpinButton1_Spinup()
Dim PageStr As String
SpinCnt = SpinCnt + 1
If SpinCnt > PageCollect.Count Then
SpinCnt = PageCollect.Count
Exit Sub
End If
If PageCnt > 1 Then
PageStr = "                         Page ( " & SpinCnt & " of " & PageCnt & " )"
Else
PageStr = vbNullString
End If
UserForm1.Caption = UserForm1.ListBox1.Text & PageStr
PageCollect(SpinCnt).Copy
With UserForm1.Frame1
.ScrollWidth = UserForm1.Frame1.InsideWidth
.ScrollHeight = HtArr(SpinCnt - 1)
.Picture = PastePicture(CF_ENHMETAFILE)
End With
End Sub

Private Sub SpinButton1_Spindown()
Dim PageStr As String
SpinCnt = SpinCnt - 1
If SpinCnt < 1 Then
SpinCnt = 1
Exit Sub
End If
If PageCnt > 1 Then
PageStr = "                         Page ( " & SpinCnt & " of " & PageCnt & " )"
Else
PageStr = vbNullString
End If
UserForm1.Caption = UserForm1.ListBox1.Text & PageStr
PageCollect(SpinCnt).Copy
With UserForm1.Frame1
.ScrollWidth = UserForm1.Frame1.InsideWidth
.ScrollHeight = HtArr(SpinCnt - 1)
.Picture = PastePicture(CF_ENHMETAFILE)
End With
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'close summary doc
Call CloseSummaryDoc
'close word
Call NofileEr2
End Sub

To operate, place Word doc files in some folder (TestFolder on the "C" drive in this example). Change the folder path as needed in the "LoadUserForm1" sub. Please note that the code does not include any check for appropriate file type ie. make sure only Word docs are in the folder.
Then...

Call LoadUserForm1

I would be interested in any comments, any suggestions for code improvements or any errors that occur. Dave

 

[NdNoviceHlp]

The module code of the Showdoc2 sub has a correction in the following section. Dave

' 1 page only or LastPara page
If cnt = LastPara Then
    Set MyRange = PFWdApp.ActiveDocument.Paragraphs(ParaCnt).Range
    MyRange.SetRange Start:=MyRange.Start, _
        End:=PFWdApp.ActiveDocument.Paragraphs(LastPara).Range.End
    PageCollect.Add MyRange
    If FrameHt = 0 Then
    ReDim Preserve HtArr(PageCnt)
    'HtArr(PageCnt - 1) = PFWdApp.ActiveDocument.Paragraphs(LastPara).Range.Information(6)
    HtArr(PageCnt - 1) = PFWdApp.ActiveDocument.Paragraphs(cnt - 1).Range.Information(6)
    End If
    GoTo Below
End If