Hi,
Please find the macros which I have used for my project...Need to modify as per your needs. This is just a sample.
'//Sub Procedure which perform an action of exporting all charts and tables from qlikview application to excel application
sub Export_to_excel
v_No_of_Sheets = ActiveDocument.NoOfSheets
'v_No_of_obj = ActiveDocument.NoOfSheetObjects
Dim objarr_SheetObject(150,150,4)
Dim sn
Dim objSheetVariable
for i = 0 to ActiveDocument.NoOfSheets - 1
'for i = 0 to 0
set ss= ActiveDocument.GetSheet(i)
set s = ActiveDocument.Sheets(ss.GetProperties.SheetId)
for j = 0 to s.NoOfSheetObjects - 1
'for j = 0 to 10
s.SheetObjects(j).Minimize
set so = s.SheetObjects(j)
' id = so.GetObjectID
obj_id = Mid(so.GetObjectID,10)
'sheet_id = Mid(ss.GetProperties.SheetId,10)
set sn = ss.GetProperties
set objSheetVariable = ActiveDocument.Variables(Mid(sn.Name,Instr(sn.Name,"=")+1,Len(sn.Name)))
if (objSheetVariable is nothing) then
sheet_id = sn.Name
else
sheet_id = objSheetVariable.GetContent.String
end if
set gso = ActiveDocument.GetSheetObject(obj_id)
gso.Minimize
objarr_SheetObject(i,j,0) = obj_id
objarr_SheetObject(i,j,1) = sheet_id
objarr_SheetObject(i,j,2) = gso.GetRect.Left
objarr_SheetObject(i,j,3) = gso.GetRect.Top
objarr_SheetObject(i,j,4) = so.GetObjectType
next
next
Set objExcelWorkbook = copyWidgetsToExcel(ActiveDocument, objarr_SheetObject)
end sub
'Function Procedure which returns a value to the sub procedure
Private Function copyWidgetsToExcel(qvDoc, byref objarr_SheetObject)
Dim i
Dim objExcelApp
Dim objExcelDoc
Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Visible = true
objExcelApp.DisplayAlerts = false
Set objExcelDoc = objExcelApp.Workbooks.Add
Dim strSourceObject
Dim qvObjectId
Dim sheetName
Dim sheetRange
Dim pasteMode
Dim chartX
Dim chartY
Dim objSource
Dim objCurrentSheet
Dim objExcelSheet
for i = 0 to ActiveDocument.NoOfSheets - 1 'UBOUND(objarr_SheetObject)
for j = 0 to ActiveDocument.Sheets(ActiveDocument.GetSheet(i).GetProperties.SheetId).NoOfSheetObjects - 1 'UBOUND(objarr_SheetObject)
'for i = 0 to 1
'for j = 0 to 10
qvObjectId = objarr_SheetObject(i,j,0)
sheetName = objarr_SheetObject(i,j,1)
chartX = objarr_SheetObject(i,j,2)
chartY = objarr_SheetObject(i,j,3)
pasteMode = objarr_SheetObject(i,j,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()
ActiveDocument.ClearCache
objSource.Maximize
qvDoc.GetApplication.WaitForIdle
if (not objSource is nothing) then
'if (pasteMode = 5) then
' exit function
'end if
if (pasteMode <> 4 and pasteMode <> 11) then
'msgbox("here:2")
Call objSource.CopyBitmapToClipboard()
else
'if(pasteMode <>5) then
'msgbox("here:3")
Call objSource.CopyTableToClipboard(true) '// default & fallback
end if
Set objCurrentSheet = objExcelDoc.Sheets(left(Replace(sheetName,":"," "),31))
chartX = Ceil(chartX/64,1)
chartY = Ceil(chartY/20,1)
objExcelDoc.Sheets(left(Replace(sheetName,":"," "),31)).Cells(chartY,chartX).Select
objExcelDoc.Sheets(left(Replace(sheetName,":"," "),31)).Paste
if (pasteMode = 4 or pasteMode = 11 ) then
With objExcelApp.Selection
.WrapText = True
.ShrinkToFit = false
End With
end if
objCurrentSheet.Range("A1").Select
end if
next
next
Call Excel_DeleteBlankSheets(objExcelDoc)
'// select the 1st sheet
objExcelDoc.Sheets(1).Select
'// This will return value
Set copyWidgetsToExcel = objExcelDoc
'objExcelApp.ActiveWorkBook.SaveAs "C:\Publish\Mar2012_GTS TTS Monthly Stability Report_qvd_new_server1_LEVEL4_ard_new_sfs_tts.xls"
'objExcelApp.ActiveWorkBook.Close
end function
Private Function Ceil (X,Factor)
' X is the value you want to round
' is the multiple to which you want to round
Ceil = (Int(X / Factor) - (X/Factor - Int(X / Factor) > 0)) * Factor
End Function
