macro

[#1]

Hi Friends,

i have created macro to export the multiple objects to excel,

when i will click on the test, objects are exporting to excel, but when i give OK and clicking on the text object it is not working.

i have to give any condition to text object to run macro?

what might be the problem? if any one knows please help me. here is my code for Macro...

sub exportToExcel_Variant3

Dim aryExport(4,3)

aryExport(0,0) = "CH20"

aryExport(0,1) = "Breakdown"

aryExport(0,2) = "A1"

aryExport(0,3) = "data"

aryExport(1,0) = "CH21"

aryExport(1,1) = "Breakdown"

aryExport(1,2) = "A20"

aryExport(1,3) = "data"

'aryExport(2,0) = "CH06"

'aryExport(2,1) = "Breakdown"

'aryExport(2,2) = "E1"

'aryExport(2,3) = "data"

'aryExport(3,0) = "CH50"

'aryExport(3,1) = "Sales Overview"

'aryExport(3,2) = "H1"

'aryExport(3,3) = "image"

Dim objExcelWorkbook 'as Excel.Workbook

Set objExcelWorkbook = copyObjectsToExcelSheet(ActiveDocument, aryExport)

end sub

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)

          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.Minimize

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

objExcelDoc.Sheets(1).Select

Set copyObjectsToExcelSheet = objExcelDoc

end function

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

Set Excel_GetSheetByName = nothing

End Function

Private Function Excel_GetSafeSheetName(sheetName)

          retVal = trim(left(sheetName, 31))

          Excel_GetSafeSheetName = retVal

End Function

Private Function Excel_AddSheet(objExcelApplication, sheetName) ' as Excel.Sheet

          objExcelApplication.Sheets.Add , objExcelApplication.Sheets(objExcelApplication.Sheets.Count)

          Dim objNewSheet

          Set objNewSheet = objExcelApplication.Sheets(objExcelApplication.Sheets.Count)

          objNewSheet.Name = left(sheetName,31)

          Set Excel_AddSheet = objNewSheet

End function

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

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

[#2]

Hi Macrus,

Do we have any other option to export multiple objects into excel sheet instead of Macro?

[marcus_sommer]

Maybe it is an alternatively to create those excel-files per macro or maybe NPrinting for the most probably needed user-sheet-object-dataselection combinations. Another way could be to export the data behind those objects into xls or csv and the excel-applications (with own tables and charts) read those data as external data.

But this needs some efforts and to apply security-rules to them like section access made it very complicated. Otherwise I think there aren't many options ...

- Marcus