ExportTablesToSingleExcelSheetV4

' Changed version of Export_to_Excel_(BIFF).SBS
' Posted to SPSSX-L on 2002/1/15 by K.Asselberghs
' The ExcelMacro to format the tables was added by Raynald Levesque 2002/05/19
' macro modified on 2002/10/10 to add a constant to each tables number.
' The ExcelMacro to export CHARTS and IGRAPHS was added on 2003/01/15 by Ray.
' NEW in v4: All layers of Pivot Tables are exported
'    The Pivoting of each layer is done using AnswerNet solution number: 24365
'    the above pivoting was added by Ray on 2004/04/03

' Paste pivot tables from a SPSS output document in a single Excel worksheet,
' the tables seperated by empty rows.
' * To paste other objects also change the script in ExportItems().

' * NOTE
'    Before executing this script, Open a worksheet In Excel And Select the
'    cell/row where pasting should start.

'*****************************************************************************.

'Begin Description
'This script will export SPSS PivotTables into Excel using BIFF (Binary Interchange File Format).
'End Description
'
Dim nrows As Integer
Dim tablenb As Integer		'the table number used to define the range name in excel
Dim chartnb As Integer
Dim strTableNb As String	'a constant to be added to the table number
Const xlMoveAndSize As Integer =1

Dim lngInitial As Long
Type PivotLayerState
	Pivot As Object 'PivotTable
	PivotManager As Object 'ISpssPivotMgr
	NumLayers As Long
	NumLayerDimensions As Long
	NumCategories As Variant
	index As Long
End Type

Dim State As PivotLayerState

'******************************************************
'NO FURTHER CHANGES SHOULD BE NEEDED
'******************************************************

'used for dialog titles
Const SCRIPT_NAME As String = "Export to Excel Workbook"
'used for preserving and restoring Alerts, to prevent unwanted dialog boxes
Const ALERTS_PRESERVE As Boolean = False
Const ALERTS_RESTORE As Boolean = True
Const xlDown = -4121
Const xlToRight = -4161
Option Explicit
'Windows API call, more control than Sax Basic Wait (seconds)
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'global variables, used by most subroutines
Dim objExcelApp As Object
Dim objOutput As ISpssOutputDoc

'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)
	tablenb = 0
	Debug.Clear

    'Cancel the export if there is no output.
    If objSpssApp.Documents.OutputDocCount > 0 Then
        Set objOutput = objSpssApp.GetDesignatedOutputDoc
    Else
        'ErrorBox passes its arguments to MsgBox, but checks Alerts first.
        ErrorBox "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

    'Start Excel and save a reference in the global variable objExcelApp.
    CreateExcel

	strTableNb = InputBox$("Enter constant to be added to Table numbers (eg 1000):","Enter constant","1000")
	If strTableNb="" Then Exit Sub 'Cancel was selected

    'Here is where we actually do something!
    ExportItems

    'Save the file.  This would be a subroutine, if it weren't one line.
    '@ objExcelApp.ActiveWorkbook.SaveAs FileName:=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.
        ErrorBox "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


'Finds items suitable for export.  Pastes them into Excel, and applies a formatting macro.
Sub ExportItems()
	Dim objPivotTable As PivotTable
	Dim objItems As ISpssItems
    Dim objItem As ISpssItem
    Dim i As Long
    Dim intFootnotes As Integer
	Dim idx As Long

    On Error Resume Next
    '@ objExcelApp.Workbooks.Add

    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     'omit Notes tables if commented out
                    'PasteIntoExcel objItem, "Picture (Enhanced Metafile)"
                    'comment out the remainder of this case if pasting as picture
					Set objPivotTable = objItem.Activate()
					'Get info on number of layers
					Call NewLayerState (objPivotTable, State)
					lngInitial = GetIndex(State)
					idx = lngInitial
					ForceItemUpdate objItem

					' Do all Layers of the Pivot Table
					Do
						Call PasteIntoExcel (objItem, "Biff", False)
	                    'apply an Excel Macro to format the table
	 					nrows = objExcelApp.Selection.Areas(1).Rows.Count + 1 'KA
	                    Call ExcelMacro(State.NumLayerDimensions)
	                    objExcelApp.ActiveCell.Offset(nrows, 0).Activate  'KA This line moved here by RL
						Call NextCategory(State)
						ForceItemUpdate objItem
						idx = GetIndex(State)
					Loop Until idx = lngInitial

               'Case SPSSPageTitle 'SPSSLog, SPSSText 'Does NOT work yet
                    'Call PasteIntoExcel (objItem, "Text", True)
					'nrows = objExcelApp.Selection.Areas(1).Rows.Count + 1

				Case SPSSChart, SPSSIGraph
                    Call PasteIntoExcel (objItem, "Picture (Enhanced Metafile)", True)
					objExcelApp.Selection.Placement = xlMoveAndSize
					Call ExcelMacroCharts(objItem.Label)
                Case Else
                    'do nothing
            End Select
        End If
    Next
    Err.Clear
End Sub


'Handles the details of Copy and Paste.
'Uses an exponential back-off to deal with clipboard latency errors.
'This sub was written by SPSS
Sub PasteIntoExcel (objItem As ISpssItem, strFormat As String, bolSkip2Lines As Boolean )
    Static intSheet As Integer

    On Error Resume Next
    Dim lngSleep As Long
    'Dim nrows As Integer

	If bolSkip2Lines Then
		With objExcelApp
			'Move down 2 cells in sheet to create space for title
			'.Range(.Cells(.Selection.Row + 2, 1), .Cells(.Selection.Row + 2, 1)).Select
			objExcelApp.ActiveCell.Offset(2, 0).Activate
		End With
	End If
    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
        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
        strFormat = "Text"
        s_intErrorCount = s_intErrorCount + 1
        Err.Clear
    End If

 '@ intSheet = intSheet + 1
 '@ If intSheet > objExcelApp.Sheets.Count Then
 '@     objExcelApp.Sheets.Add
 '@ Else
 '@     objExcelApp.Sheets("Blad" & Trim$(CStr$(intSheet))).Select
 '@ End If

    lngSleep = 100
    Do
        Sleep lngSleep
        objExcelApp.ActiveSheet.PasteSpecial Format:=strFormat, Link:=False, DisplayAsIcon:= False

        'MsgBox CStr(nrows)
        If Err Then
            Debug.Print "Paste Error: " & Err; Err.Description
            '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

    'objExcelApp.ActiveCell.Offset(nrows, 0).Activate  'KA (line moved to ExportItems by RL)

End Sub


Sub ExcelMacro(NumLayerDim As Long)
' This macro
'	adds a Table number to the title of each table
'	turns that line bold and blue
'	groups the other lines of the table so that it is easy to
'	have only titles visible in excel (this facilitates locating
'	any given table). The Table number facilitates the programming of Word
' 	to insert a given table in word in a specified point in a document.
' 	Raynald Levesque 2002/05/19

	Dim line1 As Long
	Dim line2 As Long
	Dim col1 As Integer
	Dim col2 As Integer

	On Error GoTo ErrExcelMacro
	With objExcelApp

		If tablenb=0 Then
			tablenb = CInt(strTableNb) + tablenb +1

			'Format whole excel sheet to comma with no decimals
			'Dim intRow, intCol As Integer
			'intRow = .Selection.Row
			'intCol = .Selection.Column
			'.Range(.ActiveCell, .ActiveCell.End(xlDown).End(xlToRight)).Select
			'.Selection.style = "Comma"
			'.Selection.NumberFormat = "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-"
			'.Cells(intRow, intCol).Select
		Else
			tablenb = tablenb +1
		End If

		line1 = .Selection.Row
		line2 = .Selection.Rows(.Selection.Rows.Count).Row
		col1 = .Selection.Column
		col2 = .Selection.Columns(.Selection.Columns.Count).Column
		' Add a table number in the first line, make title bold & blue

		.Cells(line1, col1)= "Table" & Str(tablenb) & " " & .Cells(line1, col1)
		If NumLayerDim > 0 Then
				.Cells(line1, col1)= .Cells(line1, col1) & " " & .Cells(line1 + 1, col1)
		End If
		.cells(line1,col1).font.bold=True
		.cells(line1,col1).Font.ColorIndex = 5
		.ActiveWorkbook.Names.Add Name:="Table" & LTrim(Str(tablenb)), RefersTo:=.Selection

		'Select the table lines (except the title) and group the lines
		.Range(.Cells(line1 + 1, col1), .Cells(line2 + 2, col2)).Select
		.Selection.Rows.Group
	End With
	Exit Sub

	ErrExcelMacro:
		Debug.Print Err.Number & Err.Description
		MsgBox Err.Number & Err.Description
		Exit Sub
End Sub

Sub ExcelMacroCharts(strLabel As String )
' This macro
'	adds a Chart number to the title of each chart
'	turns that line bold and blue
'	groups the other lines of the table so that it is easy to
'	have only titles visible in excel (this facilitates locating
'	any given table). The Chart number facilitates the programming of Word
' 	to insert a given table in word in a specified point in a document.
' 	Raynald Levesque 2003/02/27

	Dim line1 As Long
	Dim line2 As Long
	Dim col1 As Integer
	Dim col2 As Integer
	Dim HauteurLigne As Double
	Dim HauteurGraph As Double
	Dim NbLigne As Integer

	On Error GoTo ErrExcelMacro

	With objExcelApp

		HauteurLigne = .Rows(1).RowHeight
		HauteurGraph = .Selection.ShapeRange.Height
		NbLigne = Int(HauteurGraph / HauteurLigne) + 1
		line1 = .ActiveCell.Row
		line2 = line1 + NbLigne - 1
		.Range(.Cells(line1-2, 1), .Cells(line2, 1)).EntireRow.Select

		If chartnb=0 Then
			chartnb = CInt(strTableNb) + chartnb +1
		Else
			chartnb = chartnb +1
		End If

		col1 = 1	'.Selection.Column
		col2 = 10 	'.Selection.Columns(.Selection.Columns.Count).Column
		' Add a table number in the first line, make title bold & blue
		.ActiveWorkbook.Names.Add Name:="Chart" & LTrim(Str(tablenb)), RefersTo:=.Selection
		.Cells(line1-2, col1)= "Chart" & Str(chartnb) & " " & strLabel
		.cells(line1-2,col1).font.bold=True
		.cells(line1-2,col1).Font.ColorIndex = 5

		'Select the table lines (except the title) and group the lines
		.Range(.Cells(line1-1, col1), .Cells(line2 + 2, col2)).Select
		.Selection.Rows.Group
		.Range(.Cells(line2 + 3, 1), .Cells(line2+3, 1)).Select
	End With
	Exit Sub

ErrExcelMacro:
		Debug.Print Err.Number & Err.Description
		MsgBox Err.Number & Err.Description
		Exit Sub
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 the document is open in Excel, try to close it
            CloseOpenDocument strFileName
            Kill strFileName
            If Err Then
                'that didn't work, cancel the export
                Err.Clear
                strFileName = ""
            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.xls","xls",,SCRIPT_NAME, 3)
        If strFileName = "" Then    'user cancelled
            Exit Function
        End If
        'OK to kill file since user signed off on 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
            ErrorBox "The file """ & strFileName & _
                """ is currently open in Excel, and cannot be replaced. " & _
                vbCrLf & vbCrLf & _
                "Please pick a different file name, " & _
                "or close the file and try again.", vbExclamation, _
                SCRIPT_NAME
            Err.Clear
            strFileName = ""
        ElseIf Err Then
            'don't know how to deal with any other error
            Err.Clear
            Exit Function
        End If
    Loop Until strFileName <> ""

    GetFileName = strFileName
End Function


Sub CloseOpenDocument(strFileName As String)
    On Error Resume Next
    CreateExcel
    objExcelApp.Workbooks(GetName(strFileName)).Activate
    objExcelApp.ActiveWorkbook.Close
    Err.Clear
End Sub


'returns a reference to Excel in the global variable objExcelApp.
Sub CreateExcel()
    On Error Resume Next

    'GetObject returns a reference to an existing app.
    Set objExcelApp = GetObject(,"Excel.Application")
 '@ If Err = 10096 Then Debug.Print "Excel is not running, use CreateObject"
    'CreateObject starts Excel when it's not already running.
 '@ If objExcelApp Is Nothing Then
 '@     Set objExcelApp = CreateObject("Excel.Application")
 '@ End If
    'in case we need to diagnose other errors
    Debug.Print Err; Err.Description
    Err.Clear

    If objExcelApp Is Nothing Then
        ErrorBox "Open a Excel workbook before executing this script," & vbCrLf & _
            "and select the cell where you want to start pasting SPSS-output.", vbExclamation, SCRIPT_NAME
        'Always restore settings before quitting!
        Alerts(ALERTS_RESTORE)
        End
    End If
    objExcelApp.Visible = True

    If objExcelApp.ActiveWorkbook Is Nothing Then
        ErrorBox "No open workbook found in Excel." & vbCrLf & _
           "Open a Excel workbook before executing this script," & vbCrLf & _
           "and select the cell where you want to start pasting SPSS-output.", vbExclamation, SCRIPT_NAME
       'Always restore settings before quitting!
       Alerts(ALERTS_RESTORE)
       End
    End If

    'objExcelApp.Workbooks.Add
    'objExcelApp.ActivateMicrosoftApp
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.
Function ErrorBox(strAlertMessage As String, intType As Integer, strTitle As String)
    On Error Resume Next
    Debug.Print strAlertMessage
    If Alerts(ALERTS_PRESERVE) Then
        ErrorBox = MsgBox(strAlertMessage, intType, strTitle)
    Else
        'Could put a logging function here, for example.
        ErrorBox = 0
    End If
End Function

'-----------------------------------------------------------------
' BEGIN Routines added to pivot to each layer
'-----------------------------------------------------------------
' These come from AnswerNet solution number: 24365
'-----------------------------------------------------------------
' Type added to pivot to each layer
'-----------------------------------------------------------------

'-----------------------------------------------------------------

Sub NewLayerState(objPivot As PivotTable, State As PivotLayerState)
	Dim i As Long
	Dim lngNumCat() As Long
	Dim lngNumLayers As Long
	Dim index As Long
	Dim objPivotMgr As ISpssPivotMgr
	Dim objDim As ISpssDimension

	Set State.Pivot = objPivot
	Set objPivotMgr = objPivot.PivotManager
	Set State.PivotManager = objPivotMgr
	State.NumLayerDimensions = objPivotMgr.NumLayerDimensions

	ReDim lngNumCat(State.NumLayerDimensions)

	lngNumLayers = 1
	'construct an index for the current state
	'save the state information along the way
	For i = 0 To State.NumLayerDimensions - 1
		Set objDim = objPivotMgr.LayerDimension(i)
		lngNumCat(i) = objDim.NumCategories
		'the test is probably unnecessary; why would a Dimension have no levels?
		If lngNumCat(i) > 0 Then
			index = index * lngNumCat(i) + objDim.CurrentCategory
			lngNumLayers = lngNumLayers * lngNumCat(i)
		End If
	Next
	State.NumLayers = lngNumLayers
	State.NumCategories = lngNumCat
	State.Index = index
End Sub

Function GetIndex(State As PivotLayerState) As Long
	'This will be valid, as long as SetIndex
	'or NewLayerState are used; i.e. never set Index directly
	GetIndex = State.Index
End Function

Sub SetIndex(State As PivotLayerState, index As Long)
	If State.Pivot Is Nothing Then Exit Sub
	If VarType(State.NumCategories ) <> vbArray + vbLong Then Exit Sub

	Dim i As Long
	Dim lngNumCat As Long
	Dim lngIndex As Long
	Dim objPivotMgr As ISpssPivotMgr
	Dim vntNumCat As Variant
	Dim objDim As ISpssDimension

	Set objPivotMgr = State.PivotManager
	vntNumCat = State.NumCategories

	lngIndex = index

	'translate back into categories
	For i = State.NumLayerDimensions - 1 To 0 Step -1
		Set objDim = objPivotMgr.LayerDimension(i)
		'if we skipped this dimension before, we'll skip it again
		lngNumCat = vntNumCat(i)
		If lngNumCat > 0 Then
			objDim.CurrentCategory = lngIndex Mod lngNumCat
			lngIndex = lngIndex \\ lngNumCat
		End If
	Next

	State.Index = index Mod State.NumLayers
End Sub

Sub NextCategory(State As PivotLayerState)
	'Cycles through *all* categories of *all* layer dimensions.
	'Advances to the next category of the bottom layer dimension.
	'When it gets to the last category of that dimension, it wraps
	'around to the first category, and it also advances to the next
	'category of the next higher dimension, and so on.

	SetIndex State, GetIndex(State) + 1
End Sub

'---------------------------------------------------------------------------
'This subroutine activates, then deactivates an Output item.
'This should be unnecessary, but will force a re-draw of the item.
'This usually corrects problems when the appearance is changed by a script.
'---------------------------------------------------------------------------
Sub ForceItemUpdate(objItem)
	On Error Resume Next
	With objItem
		.Deactivate
		.Activate
		.Deactivate
	End With
End Sub
'---------------------------------------------------------------------------

'-----------------------------------------------------------------
' END Routines added to pivot to each layer