谁有Qlikview宏DEMO发来参考一下

我来提供一个自动导出QV报表到Excel里的宏，供大家参考，附带详细解释说明。
sub exportToExcel_Variant1

Dim aryExport(0,3)

aryExport(0,0) = "objSalesPerYearAndRegion"     
aryExport(0,1) = "Sales per Region a. Year" 
aryExport(0,2) = "A1"
aryExport(0,3) = "data"

Dim objExcelWorkbook 'as Excel.Workbook
Set objExcelWorkbook = copyObjectsToExcelSheet(ActiveDocument, aryExport)

end sub
 
 
'// ****************************************************************
'// 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
'// ~~
'// ~~
'// 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
'// ****************************************************************

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




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)
               
 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
  
  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
'//__________________________________________________________________