'Begin Description 'This script will export SPSS 8.0 PivotTables into Word as RTF-formatted tables. ' 'Some editing will make it easier to use with Word 95 (i.e. Word 6 or 7). 'Prior to Word 97, Word will disappear when the script ends. 'Comments in the script describe the changes needed to prevent this. 'End Description 'modifications by John Hendrickx, March 1 2001 'pivot tables are formatted with keep together, keep next 'to prevent page breaks within the table and with a 10 point font 'see ConvertToTextAndBackAgain for modifications 'John Hendrickx, Nijmegen Business School, University of Nijmegen, Netherlands 'J.Hendrickx@bw.kun.nl '****************************************************** 'TO PREVENT WORD 95 FROM CLOSING WHEN THE SCRIPT ENDS: 'see comments between rows of asterisks '****************************************************** ' 'You may need to: '---Edit the value of WORD_VERSION 'if Word is not installed in the default location '---Edit the path to Word ' '****************************************************** 'one or the other of the next two lines should be commented out Const WORD_VERSION As Integer = 97 'Const WORD_VERSION As Integer = 95 'or 6, or 7 '****************************************************** 'edit this constant to select a different table format Const WORD_TABLE_FORMAT = 0 '****************************************************** ' 'irrelevant if WORD_VERSION = 97 '****************************************************** 'if Word is installed in a different directory, 'and WORD_VERSION < 97, edit the following line Const WORD_PATH As String = "C:\\MSOFFICE\\WINWORD\\WINWORD.EXE" '****************************************************** ' '****************************************************** 'NO FURTHER CHANGES SHOULD BE NEEDED FOR WORD 95 '****************************************************** ' ' '****************************************************** 'You may wish to edit the Word Macro (below), which 're-formats the table after it is pasted into Word '****************************************************** Sub WordMacro(intFootnotes As Integer) On Error Resume Next If WORD_VERSION < 97 Then FindWordTable95 intFootnotes Else 'If WORD_VERSION = 97 Then FindWordTable97 intFootnotes 'This only works in, and is only needed for, Word 97 ConvertToTextAndBackAgain End If With objWordApp 'restore the cursor by seeking the end of the document. '.LineDown 2 + intFootnotes .EndOfDocument End With Debug.Print Err; Err.Description Err.Clear '+++ End Sub Sub FindWordTable95(intFootnotes As Integer) On Error Resume Next Dim i As Integer With objWordApp .LineUp intFootnotes For i = 0 To intFootnotes + 4 'assumes the caption takes up at most 4 lines .LineUp 'Count:=1 .TableAutoFormat Format:=WORD_TABLE_FORMAT, Autofit:=True Debug.Print Err; Err.Description If Err = 0 Then 'Found a table! Exit For Else Err.Clear End If Next End With End Sub Sub FindWordTable97(intFootnotes As Integer) On Error Resume Next Dim i As Integer With objWord.Selection .MoveUp Count:=intFootnotes For i = 0 To intFootnotes + 4 'assumes the caption takes up at most 4 lines .MoveUp 'Count:=1 .Tables(1).Select Debug.Print Err; Err.Description If Err = 0 Then 'Found a table! Exit For Else Err.Clear End If Next End With End Sub Sub ConvertToTextAndBackAgain() On Error Resume Next Dim lngNumRows As Long Dim lngNumColumns As Long With objWord.Selection.Tables(1) .Select lngNumRows = .Rows.Count lngNumColumns = .Columns.Count End With With objWord.Selection .Rows.ConvertToText Separator:=1 ':=wdSeparateByTabs .ConvertToTable Separator:=1, NumColumns:=lngNumColumns, _ NumRows:=lngNumRows, Format:=WORD_TABLE_FORMAT, ApplyBorders:=True, _ ApplyShading:=True, ApplyFont:=False, ApplyColor:=True, _ ApplyHeadingRows:=True, ApplyLastRow:=False, ApplyFirstColumn:=True, _ ApplyLastColumn:=False, AutoFit:=True .Tables(1).AutoFormat Format:=1, AutoFit:=True 'modifications John Hendrickx .ParagraphFormat.KeepWithNext = True .ParagraphFormat.KeepTogether = True .Font.size = 10 .ParagraphFormat.Alignment = 2 'wdAlignParagraphRight End With 'left align the first column (should be esthetically pleasing most of the time) objWord.Selection.Columns(1).Select objWord.Selection.ParagraphFormat.Alignment = 0 'wdAlignParagraphLeft 'select the paragraph directly above the table containing the caption 'apply keep together, keep next, size 10 to it as well 'Unit:=5 -> wdLine objWord.Selection.MoveUp Unit:=5, Count:=1 objWord.Selection.Paragraphs(1).Range.Select With objWord.Selection .ParagraphFormat.KeepWithNext = True .ParagraphFormat.KeepTogether = True .Font.size = 10 End With 'end of modifications John Hendrickx If Err Then Debug.Print "ConvertToTextAndBackAgain: Error " & Err Debug.Print Err.Description End If End Sub ' ' '****************************************************** 'See marked comments below to paste tables as Pictures '(e.g. for SPSS 7.5) or to paste only selected items '****************************************************** 'used for dialog titles Const SCRIPT_NAME As String = "Export to Word Document" 'used for preserving and restoring Alerts, to prevent unwanted dialog boxes Const ALERTS_PRESERVE As Boolean = False Const ALERTS_RESTORE As Boolean = True Option Explicit Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'global variables, used by most subroutines Dim objWordApp As Object Dim objOutput As ISpssOutputDoc '+++ Added to work around Word97 print problem +++ Dim objWord As Object '+++ 'to notify user that items could not be pasted... Dim s_intErrorCount As Integer Sub Main Dim strFileName As String On Error Resume Next 'In SPSS 8.0 and above, we can invoke this script from a syntax file. 'In that case, we want to prevent alerts which would halt execution. 'But in SPSS 7.5, this would cause an error. Therefore, all handling 'of Alerts is encapsulated in the Alerts function. We call it here 'only to initialize settings. It must be called again to restore 'settings before the script ends. Alerts(ALERTS_PRESERVE) 'Cancel the export if there is no output. If objSpssApp.Documents.OutputDocCount > 0 Then Set objOutput = objSpssApp.GetDesignatedOutputDoc Else 'MessageBox passes its arguments to MsgBox, but checks Alerts first. MessageBox( "There is no SPSS output to export. " & vbCrLf & _ "Please run an analysis and try again.", vbExclamation, SCRIPT_NAME) 'Always restore settings before quitting! Alerts(ALERTS_RESTORE) End End If 'Get the file name where output will be saved. 'In SPSS 8, the script can be invoked from a syntax file, and the name of the 'file passed in as the script parameter. 'Otherwise, the file name is requested from the user. strFileName = GetFileName() 'The following condition could be omitted, 'in which case the file would be exported but not saved. If strFileName = "" Then 'User cancelled, OR invoked from syntax and target file could not be killed. 'Always restore settings before quitting! Alerts(ALERTS_RESTORE) End End If 'Start Word and save a reference in the global variable objWordApp. CreateWord 'Here is where we actually do something! ExportItems 'Save the file. This would be a subroutine, if it weren't one line. objWordApp.FileSaveAs Name:=strFileName 'Tell the user if there were objects which could not be copied... If s_intErrorCount > 0 Then '... but only if the Alerts are on. MessageBox( "Some items may not have been successfully copied and/or pasted into Excel." & vbCrLf & _ "Please review your SPSS output and Excel document.", vbExclamation, SCRIPT_NAME) End If 'For the last time: 'Always restore settings before quitting! Alerts(ALERTS_RESTORE) End Sub Sub ExportItems Dim objItems As ISpssItems Dim objItem As ISpssItem Dim i As Long Dim intFootnotes As Integer On Error Resume Next objWordApp.FileNewDefault Set objItems = objOutput.Items For i = 0 To objItems.Count - 1 Set objItem = objItems.GetItem(i) Debug.Print "Item " & i & " Type " & objItem.SPSSType & _ " Visible " & objItem.Visible '****************************************************** 'one or the other of the next two lines should be commented out 'If objItem.Visible And objItem.Selected Then 'copy selection only If objItem.Visible Then 'copy all visible output '****************************************************** Select Case objItem.SPSSType Case SPSSPivot, SPSSWarning, SPSSNote 'we'll need to know the mumber of footnotes for the Word Macro intFootnotes = objItem.ActivateTable.FootnotesArray.Count 'copy won't work if item is activated! objItem.Deactivate '****************************************************** 'uncomment the following line if pasting as a picture 'PasteIntoWord objItem, "Pict" '****************************************************** 'comment out the remainder of this case if pasting as picture PasteIntoWord objItem, "RTF" 'apply a Word Macro to format the table WordMacro intFootnotes '****************************************************** Case SPSSLog, SPSSText, SPSSTitle PasteIntoWord objItem, "RTF" Case SPSSChart, SPSSIGraph PasteIntoWord objItem, "Pict" Case Else 'do nothing End Select End If Next End Sub Sub PasteIntoWord (objItem As ISpssItem, strDataType As String) On Error Resume Next Dim lngSleep As Long lngSleep = 100 '1/10th of a second Clipboard "" '.Clear objOutput.ClearSelection objItem.Selected = True 'Copy the item. Loop is only in case of problems. Do objWordApp.EndOfDocument Sleep lngSleep objOutput.Copy If Err Then 'clipboard may not be available immediately after copy returns 'try to deal with any errors by waiting longer before trying again lngSleep = 2 * lngSleep End If Loop Until (Err = 0) Or (lngSleep > 2000) If Err Then 'something went wrong with the copy, try to inform the user Clipboard ">>> Item could not be copied: Error # " & Err & vbCrLf & Err.Description s_intErrorCount = s_intErrorCount + 1 Err.Clear End If lngSleep = 100 Do Sleep lngSleep objWordApp.EditPasteSpecial DataType:=strDataType If Err Then 'clipboard may not be available immediately after copy returns 'try to deal with any errors by waiting longer before trying again lngSleep = 2 * lngSleep End If Loop Until (Err=0) Or (lngSleep > 2000) If Err Then s_intErrorCount = s_intErrorCount + 1 Err.Clear End If 'paste a blank line after each item Clipboard vbCrLf & " " objWordApp.EndOfDocument objWordApp.EditPasteSpecial DataType:="Text" End Sub Function GetFileName() As String Dim strFileName As String 'First check to see if the script was invoked from syntax, 'and a filename is provided as a script parameter. On Error Resume Next 'the following will cause an error in SPSS 7.5 strFileName = objSpssApp.ScriptParameter(0) If Err Then Err.Clear End If If strFileName <> "" Then 'OK to kill file since syntax user requested this If Dir$(strFileName) <> "" Then Kill strFileName End If 'may not be able to kill the file if the document is open If Err = 10101 Then Err.Clear 'activate and close the worksheet; try again If WORD_VERSION < 97 Then 'don't know how to deal with this, cancel strFileName = "" Else 'if the document is open in Word, try to close it CloseOpenDocument strFileName Kill strFileName If Err Then MessageBox( "Error " & Err & vbCrLf & Err.Description, vbExclamation, SCRIPT_NAME) 'that didn't work, cancel the export Err.Clear strFileName = "" End If End If End If GetFileName = strFileName Exit Function End If 'If there wasn't a script parameter, get the filename from the user Do 'get the path and filename where the exported document will be saved '3=Confirm overwrite of existing file strFileName = GetFilePath$("Output.doc","doc",,SCRIPT_NAME, 3) If strFileName = "" Then 'user cancelled Exit Function End If 'OK to kill file since user signed off on this On Error Resume Next If Dir$(strFileName) <> "" Then Kill strFileName End If 'may not be able to kill the file if the document is open If Err = 10101 Then MessageBox( "The file """ & strFileName & _ """ is currently open in Word, and cannot be replaced. " & _ vbCrLf & vbCrLf & _ "Please pick a different file name, " & _ "or close the file and try again.", vbExclamation, _ SCRIPT_NAME) strFileName = "" ElseIf Err Then 'don't know how to deal with any other error Exit Function End If Loop Until strFileName <> "" GetFileName = strFileName End Function Sub CloseOpenDocument(strFileName As String) On Error Resume Next '+++ Made global as part of workaround for Word97 print problem +++ 'Dim objWord As Object 'Set objWord = GetObject(,"Word.Application") '+++ Dim objDoc As Object Set objDoc = objWord.Documents(GetName(strFileName)) objDoc.Close SaveChanges:=0 'wdDoNotSaveChanges Err.Clear End Sub Sub CreateWord On Error Resume Next 'Word 95 will disappear as soon as the script terminates without this If WORD_VERSION < 97 Then If vbNo = MessageBox ("Is Word already running?", vbYesNo+vbQuestion, SCRIPT_NAME) Then Dim dblWordProgID As Double dblWordProgID = Shell(WORD_PATH, vbNormalNoFocus) End If End If 'objWordApp is really not the application (for Word 97), but WordBasic. 'This is for compatibility with older versions of Word. 'What we do is equivalent to using: 'Set objWord = CreateObject("Word.Application") 'Set objWordApp = objWord.WordBasic 'Since for most purposes we don't need the additional properties which 'are available to the application, this is good enough. 'GetObject returns a reference to an existing Word 97, doesn't work on Word 95 Set objWordApp = GetObject(,"Word.basic") 'If Err = 10096 Then Debug.Print "Word is not running, use CreateObject" If objWordApp Is Nothing Then Set objWordApp = CreateObject("Word.basic") End If 'in case we need to diagnose other errors Debug.Print Err; Err.Description Err.Clear If objWordApp Is Nothing Then MessageBox( "Unable to start Word. " & vbCrLf & _ "Script will terminate.", vbExclamation, SCRIPT_NAME) End End If '+++ Added to work around Word97 print problem +++ If WORD_VERSION >= 97 Then Set objWord = GetObject(,"Word.Application") End If Debug.Print "ObjWord Is Nothing: " & ((objWord Is Nothing) = True) '+++ 'objWordApp.FileNewDefault 'copy & paste won't work properly if Word isn't visible objWordApp.AppShow End Sub 'Strips the drive and path from a string. Function GetName(strFileName As String) As String Dim strName As String Dim intPos As Integer Dim intPos1 As Integer strName = strFileName 'Strip the drive letter and colon if present. intPos = InStr(strName, ":") If intPos > 0 Then strName = Mid$(strName, intPos + 1) End If 'Find the last \\. Do intPos = intPos1 intPos1 = InStr(intPos1 + 1, strName, "\\") Loop Until intPos1 = 0 'Remove everything before the last \\. If intPos > 0 Then strName = Mid$(strName, intPos + 1) End If Debug.Print strName 'We don't need to remove the extension... GetName = strName End Function 'Encapsulates Alerts property, which will cause an error in SPSS 7.5. 'Call with False (ALERTS_PRESERVE) to initialize. 'Call with True (ALERTS_RESTORE) to restore the initial setting 'before the script ends. 'If script is invoked from syntax, i.e. (ScriptParameter(0) <> ""), 'it suppresses alerts which would halt execution. Function Alerts(blnRestore As Boolean) As Boolean Static blnInitialized As Boolean Static blnAlerts As Boolean Static blnAlertsInitial As Boolean On Error Resume Next If Not blnInitialized Then blnInitialized = True blnAlertsInitial = objSpssApp.Alerts If Err Then 'spss 7.5 blnAlertsInitial = True Err.Clear End If blnAlerts = (objSpssApp.ScriptParameter(0) = "") If Err Then 'spss 7.5 blnAlerts = True Err.Clear End If End If If blnRestore Then objSpssApp.Alerts = blnAlertsInitial blnAlerts = blnAlertsInitial 'blnInitialized = False End If Err.Clear Alerts = blnAlerts End Function 'Wrapper for MsgBox, asks Alerts if it's OK before putting up the DB. 'Returns result of MsgBox (indicating which button was pushed) or 0 if Alerts = False. Function MessageBox(strAlertMessage As String, intType As Integer, strTitle As String) On Error Resume Next Debug.Print strAlertMessage If Alerts(ALERTS_PRESERVE) Then MessageBox = MsgBox(strAlertMessage, intType, strTitle) Else 'Could put a logging function here, for example. MessageBox = 0 End If End Function