' 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. ' 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 Sub ExcelMacro() ' 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 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) .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 ' '****************************************************** '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 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 '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 '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 will 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 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","0") '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 ' MsgBox "Klaar" '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 objItems As ISpssItems Dim objItem As ISpssItem Dim i As Long Dim intFootnotes As Integer 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 'SELECTEER HIER OUTPUT ITEMS DIE JE WILT EXPORTEREN NAAR EXCEL 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 PasteIntoExcel objItem, "Biff",False 'apply an Excel Macro to format the table nrows = objExcelApp.Selection.Areas(1).Rows.Count + 1 'KA Call ExcelMacro objExcelApp.ActiveCell.Offset(nrows, 0).Activate 'KA This line moved here by RL 'Case SPSSLog, SPSSText, SPSSTitle 'PasteIntoExcel objItem, "Text" Case SPSSChart, SPSSIGraph 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 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