Export Pivot Tables to Word2

'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