1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
'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