'Save as ExportVisibleOutputToWordViaHTML.SBS 'Begin DESCRIPTION 'This script copies all visible items of the Designated Output to MS Word. This is done via HTML. ' The ** indicating significance in Correlations Tables "survive" the trip to Word 'REQUIREMENTS: ' Need an open Output window (Visible content will be sent to Word via Htlm) ' This was tested with English versions of SPSS 10.07 and MS Word 2000; ' It should also work with other languages of these versions ' Note that the temporary files holding the HTML files are created in "c:\\temp\\". 'End DESCRIPTION 'Author: rlevesque@videotron.ca 2001/07/14 'http://pages.infinit.net/rlevesqu/ Option Explicit Sub Main Dim intType As Integer Dim objOutputDoc As ISpssOutputDoc Dim objItems As ISpssItems Dim objItem As ISpssItem Dim strFile As String On Error GoTo ErrorHand Set objOutputDoc = objSpssApp.GetDesignatedOutputDoc ' This is the temporary file containing the HTML output strFile = "c:\\temp\\ExportToWord.htm" Kill strFile 'Kill file if it already exists objOutputDoc.Visible = True ' Export all visible objects to HTML documents objOutputDoc.ExportDocument (SpssVisible, strFile, SpssFormatHtml, True) ' Next Sub imports the HTML documents into Word Call ImportHTMLToWord (strFile) Kill strFile Exit Sub ErrorHand: Select Case Err Case 10101 'File could not be killed Resume Next Case Else Debug.Print Err & " " & Err.Description MsgBox "Sorry, an error occured! You will have to try to solve the problem." End Select End Sub '******************************** Sub ImportHTMLToWord (strFile As String) 'imports the HTML documents into Word Dim WordApp As Object On Error GoTo Oopps 'get access to Word application (if it does not exist, Oopps will create it) Set WordApp=GetObject(,"Word.Application") With WordApp If .Documents.Count = 0 Then ' we need to add a document .Documents.Add DocumentType:=0 'wdNewBlankDocument End If ' Import the HTML document into Word .Selection.InsertFile FileName:=strFile, Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False Call WordMacro(WordApp) End With Set WordApp = Nothing Exit Sub Oopps: Select Case Err Case 10096 'word is not running: use CreateObject Set WordApp = CreateObject("Word.Application") WordApp.Visible = True Debug.Print "error " & Err & ": " & Err.Description & "(Word was not already running)" Resume Next Case Else Debug.Print "error " & Err & ": " & Err.Description Set WordApp = Nothing Exit Sub End Select End Sub Sub WordMacro(WordApp As Object) ' To include the charts inside the Word document (instead of having ' a links to the charts) Const wdPasteMetafilePicture=3 Const wdFloatOverText=1 Dim idx As Integer On Error GoTo ErrorHand 'With WordApp For idx = WordApp.ActiveDocument.InlineShapes.Count -1 To 0 Step -1 WordApp.ActiveDocument.InlineShapes(idx).Select WordApp.Selection.Copy WordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _ Placement:=wdFloatOverText, DisplayAsIcon:=False Next idx 'End With ErrorHand: Debug.Print Err.Description Exit Sub End Sub