Dim objExcelWorkbook 'as Excel.Workbook Set objExcelWorkbook = copyObjectsToExcelSheet(ActiveDocument, aryExport)
''// Now either just leave Excel open or do some other stuff here ''// like saving the excel, some formatting stuff, ... end sub
'// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! '// YOU DO NOT NEED TO CHANGE THE CODE BELOW !!!!!!!!!!!!!!!!!!!!!!! '// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'// **************************************************************** '// copyObjectsToExcel '// ~~ '// Parameters: '// qvDoc - Reference to the QlikView document (normally just use '// "ActiveDocument", but you can also use copyObjectsToExcel '// outside of QlikView ... '// aryExportDefinition - array of settings '// ~~ '// Version 1.02 '// ~~ '// The aryExportDefinition is used to pass the following properties to '// copyObjectsToExcelSheet: '// '// Index Description '// ------------------------ '// 0 - Id of the QlikView object to copy from '// 1 - Name of the sheet (in Excel) where the object should be copied to '// '// (If a sheet with the same name already exists no new '// sheet will be created, instead the existing sheet will '// be used for pasting the object) '// '// Note: the sheetName can be max 31 characters long '// '// 2 - Range in Excel where the object should be pasted to '// 3 - PasteMode ["data", "image"] '// Defines if the objects underlaying data should be '// pasted ("data") or the the image representing the object '// should be used '// Introdotto da A.Saccone '// 4 - Range in Excel where object's caption should be pasted '// **************************************************************** Private Function copyObjectsToExcelSheet(qvDoc, aryExportDefinition) 'as Excel.Workbook
Dim i 'as Integer Dim objExcelApp 'as Excel.Application Dim objExcelDoc 'as Excel.Workbook
Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Visible = true 'false if you want to hide Excel objExcelApp.DisplayAlerts = false
Set objExcelDoc = objExcelApp.Workbooks.Add
Dim strSourceObject
Dim qvObjectId 'as String Dim sheetName Dim sheetRange Dim pasteMode Dim objSource Dim objCurrentSheet Dim objExcelSheet Dim sheetRangeCapt
for i = 0 to UBOUND(aryExportDefinition)
'// Get the properties of the exportDefinition array qvObjectId = aryExportDefinition(i,0) sheetName = aryExportDefinition(i,1) sheetRange = aryExportDefinition(i,2) pasteMode = aryExportDefinition(i,3) sheetRangeCapt = aryExportDefinition(i,4)
Set objExcelSheet = Excel_GetSheetByName(objExcelDoc, sheetName) if (objExcelSheet is nothing) then Set objExcelSheet = Excel_AddSheet(objExcelApp, sheetName) if (objExcelSheet is nothing) then msgbox("No sheet could be created, this should not occur!!!") end if end if
objExcelSheet.Select
set objSource = qvDoc.GetSheetObject(qvObjectId) Call objSource.GetSheet().Activate() objSource.Maximize qvDoc.GetApplication.WaitForIdle
if (not objSource is nothing) then
if (pasteMode = "image") then Call objSource.CopyBitmapToClipboard() else Call objSource.CopyTableToClipboard(true) '// default & fallback end if
Set objCurrentSheet = objExcelDoc.Sheets(sheetName) objExcelDoc.Sheets(sheetName).Range(sheetRange).Select objExcelDoc.Sheets(sheetName).Paste
'Inserimento del Caption dell'oggetto chartCaption = objSource.GetCaption.Name.v objCurrentSheet.Range(sheetRangeCapt) = chartCaption
if (pasteMode <> "image") then With objExcelApp.Selection .WrapText = False .ShrinkToFit = False End With end if
objCurrentSheet.Range("A1").Select end if
next
Call Excel_DeleteBlankSheets(objExcelDoc)
'// Finally select the first sheet objExcelDoc.Sheets(1).Select
'// Return value Set copyObjectsToExcelSheet = objExcelDoc
end function '// ________________________________________________________________
'// **************************************************************** '// Internal function for getting the Excel sheet by sheetName '// **************************************************************** Private Function Excel_GetSheetByName(ByRef objExcelDoc, sheetName) 'as Excel.Sheet
For Each ws In objExcelDoc.Worksheets If (trim(ws.Name) = Excel_GetSafeSheetName(sheetName)) then Set Excel_GetSheetByName = ws exit function End If Next
'// default return value Set Excel_GetSheetByName = nothing
End Function '// ________________________________________________________________
Private Function Excel_GetSafeSheetName(sheetName)
'// can be max 31 characters long retVal = trim(left(sheetName, 31))
Excel_GetSafeSheetName = retVal End Function
'// **************************************************************** '// Internal function for adding a new sheet '// **************************************************************** Private Function Excel_AddSheet(objExcelApplication, sheetName) ' as Excel.Sheet
'// add a sheet to the last position objExcelApplication.Sheets.Add , objExcelApplication.Sheets(objExcelApplication.Sheets.Count)
Dim objNewSheet Set objNewSheet = objExcelApplication.Sheets(objExcelApplication.Sheets.Count) objNewSheet.Name = left(sheetName,31)
'// return the newly created sheet Set Excel_AddSheet = objNewSheet
End function '// ________________________________________________________________
'// **************************************************************** '// Delete all empty sheets '// **************************************************************** Private Sub Excel_DeleteBlankSheets(ByRef objExcelDoc)
For Each ws In objExcelDoc.Worksheets If (not HasOtherObjects(ws)) then If objExcelDoc.Application.WorksheetFunction.CountA(ws.Cells) = 0 Then On Error Resume Next Call ws.Delete() End If End If Next
End Sub '// ________________________________________________________________
'// **************************************************************** '// Helper function to determine if there are other objects placed '// on the sheet ... '// **************************************************************** Public Function HasOtherObjects(ByRef objSheet) 'As Boolean Dim c If (objSheet.ChartObjects.Count > 0) Then HasOtherObjects = true Exit function End If If (objSheet.Pictures.Count > 0) Then HasOtherObjects = true Exit function End If If (objSheet.Shapes.Count > 0) Then HasOtherObjects = true Exit function End If
HasOtherObjects = false End Function '//__________________________________________________________________
