>PROCEDURE grid2xls >LPARAMETERS oGrid, oParameters >*!* Program: grid2xls >*!* Author: Dorin Vasilescu >*!* Copyright: freeware >*!* Description: save table/cursor data to Excel using a grid as reference >* ( data ,columns, formatting, headers, DynamicBackColor) >* >* Parameters: > >* oGrid: grid reference >* oParameters parameters objects, collection class, used to pass header rows, SaveAs file name, Subtotals >* >*Example: >* - headers: >* oP = NEWOBJECT('Collection') >* oP.Add(NEWOBJECT('Empty'),'headers') &&headers item, empty class >* AddProperty(oP.Item(1),'aHeaders[2,8]',.f.) &&aHeaders, array property, 8 columns >* WITH oP.Item(1) >* * 1st header >* .aHeaders[1,1] = 'Header 1 text:' >* .aHeaders[1,2] = 1 &&row >* .aHeaders[1,3] = 1 &&column >* .aHeaders[1,4] = 'Arial' &&FontName >* .aHeaders[1,5] = 16 &&FontSize >* .aHeaders[1,6] = .T. &&FontBold >* .aHeaders[1,7] = .T. &&FontItalic >* *2nd header >* .aHeaders[2,1] = 'Header 2 text' >* .aHeaders[2,2] = 4 &&row >* .aHeaders[2,3] = 4 &&column >* .aHeaders[2,8] = -4108 &&Alignment ( xlCenter ) >* ENDWITH >* >* - SaveAs filename >* >* ADDPROPERTY(oP,'fileName','C:\Windows\Temp\test.xls') >* >* >* - subtotals (using comma delimited values) >* >* ADDPROPERTY(oP,'subtotals','1,3,4,5') >* >* first value ( 1 ) : group by column >* next values (3,4,5) : summed columns >* >* >* Call : grid2xls( oGrid, oP ) >* >* OR : grid2xls( oGrid ) > >#DEFINE xlLeft -4131 >#DEFINE xlCenter -4108 >#DEFINE xlRight -4152 >#DEFINE xlSum -4157 >#DEFINE PIXEL_PER_UNIT 7.5 >#DEFINE MSG_ROWS_PROCESSED "Inregistrari exportate: " > >#IF .f. > LOCAL oGrid as Grid > LOCAL oParameters as Collection >#ENDIF > >LOCAL oExcel as 'Excel.Application' >oExcel = .null. > >TRY > oExcel = CREATEOBJECT('Excel.Application') >CATCH > MESSAGEBOX('Eroare initializare Excel.' + CHR(13) + 'Posibil neinstalat' ; > , 0+16+4096 , 'Start Excel', 10000) >ENDTRY > >*check if we continue or not >IF ISNULL(oExcel) > RETURN >ENDIF >IF NOT VARTYPE(oGrid) = 'O' > RETURN >ELSE > IF NOT oGrid.BaseClass == 'Grid' > RETURN > ENDIF >ENDIF > > > >LOCAL i, iItem, nFirstDataRow, nRowsProcessed, lHasParams, nHeaderRow, oParmObj, oColumn >LOCAL cHdItem, nRow, nColumn, nRecno, cRange, nDBColor, nDFColor, oCell >LOCAL oCols &&columns collection, needed to sort by ColumnOrder > >nHeaderRow = 1 >nFirstDataRow = 2 >nRowsProcessed = 0 >lHasParams = (TYPE('oParameters') = 'O') >oCols = NEWOBJECT('Collection') >oCols.KeySort = 2 > >IF oGrid.RecordSourceType = 1 > SELECT (oGrid.RecordSource) >ELSE > *alias needed to be selected before calling >ENDIF > >nRecno = RECNO() > >*add columns ref to columns collection >FOR i = 1 TO oGrid.ColumnCount > oCols.Add(oGrid.Columns(i), PADL(STR(i,3),3,'0')) >ENDFOR > >oExcel.DisplayAlerts = .f. >oExcel.ScreenUpdating = .f. >oExcel.Workbooks.Add >FOR i=2 TO oExcel.Sheets.Count > oExcel.Sheets(2).Delete >ENDFOR > >*set columns width/font >i = 0 >FOR EACH oColumn IN oCols > i = i + 1 > WITH oColumn > oExcel.Columns(i).Font.Name = .FontName > oExcel.Columns(i).Font.Size = .FontSize > oExcel.Columns(i).Font.Bold = .FontBold > oExcel.Columns(i).ColumnWidth = (.Width + 2*.Parent.GridLineWidth) / PIXEL_PER_UNIT > ENDWITH >ENDFOR > >IF lHasParams > IF PEMSTATUS(oParameters,'GetKey',5) > iItem = oParameters.GetKey('headers') > ELSE > iItem = 0 > ENDIF > > IF iItem <> 0 > oParamObj = oParameters.Item(iItem) > ENDIF > > IF TYPE('oParamObj.aHeaders[1,1]') <> 'U' > > WITH oParamObj > > FOR i=1 TO ALEN(.aHeaders,1) > *verify header item type > IF TYPE('.aHeaders[i,1]') = 'L' > cHdItem = '' > ELSE > cHdItem = .aHeaders[i,1] > ENDIF > *verify header item row location type > IF TYPE('.aHeaders[i,2]') <> 'N' > nRow = i > ELSE > nRow = .aHeaders[i,2] > ENDIF > *verify header item column location type > IF TYPE('.aHeaders[i,3]') <> 'N' > nColumn = 1 > ELSE > nColumn = .aHeaders[i,3] > ENDIF > *set header size, if necessary > IF nFirstDataRow < nRow + 2 > nFirstDataRow = nRow + 2 > ENDIF > > oExcel.Cells(nRow,nColumn).Select > oExcel.Selection.Value = cHdItem > > IF TYPE('.aHeaders[i,4]') = 'C' > oExcel.Selection.Font.Name = .aHeaders[i,4] > ENDIF > > IF TYPE('.aHeaders[i,5]') = 'N' > oExcel.Selection.Font.Size = .aHeaders[i,5] > ENDIF > > oExcel.Selection.Font.Bold = .aHeaders[i,6] > oExcel.Selection.Font.Italic = .aHeaders[i,7] > > IF TYPE('.aHeaders[i,8]') = 'N' > oExcel.Selection.HorizontalAlignment = .aHeaders[i,8] > ENDIF > ENDFOR > ENDWITH > ENDIF >ENDIF > >*Column Headers >nHeaderRow = nFirstDataRow - 1 >i = 0 >FOR EACH oColumn IN oCols > i = i + 1 > oExcel.Rows(nHeaderRow).RowHeight = oGrid.HeaderHeight > WITH oColumn > oExcel.Cells(nHeaderRow,i).Select > oExcel.Selection.Value = .Objects(1).Caption > oExcel.Selection.HorizontalAlignment = xlCenter > oExcel.Selection.VerticalAlignment = xlCenter > oExcel.Selection.WrapText = .t. > oExcel.Columns(i).ColumnWidth = ; > .Width / PIXEL_PER_UNIT > ENDWITH >ENDFOR > >WAIT WINDOW MSG_ROWS_PROCESSED + STR( nRowsProcessed ) NOWAIT > >SCAN > i = 0 > FOR EACH oColumn IN oCols > i = i + 1 > WITH oColumn > > IF NOT EMPTY(.ControlSource) > > oCell = oExcel.Cells(nFirstDataRow + nRowsProcessed, i) > IF NOT EMPTY(EVALUATE(.ControlSource)) OR TYPE(.ControlSource) = 'N' > oCell.Value = EVALUATE(.ControlSource) > ENDIF > > IF NOT EMPTY(.DynamicBackColor) > nDBColor = EVALUATE(.DynamicBackColor) > IF nDBColor <> oGrid.BackColor > oCell.Interior.Color = nDBColor > ENDIF > > ENDIF > > IF NOT EMPTY(.DynamicForeColor) > nDFColor = EVALUATE(.DynamicForeColor) > IF nDFColor <> oGrid.ForeColor > oCell.Font.Color = nDFColor > ENDIF > > ENDIF > > ENDIF > > ENDWITH > > ENDFOR > > nRowsProcessed = nRowsProcessed + 1 > IF MOD(nRowsProcessed,SET("Odometer")) = 0 > WAIT WINDOW MSG_ROWS_PROCESSED + STR( nRowsProcessed ) NOWAIT > ENDIF > >ENDSCAN > >IF oGrid.ColumnCount <= 26 > cRange = 'A'+TRANSFORM(nHeaderRow) + ':' + CHR(64+oGrid.ColumnCount) ; > + TRANSFORM(nHeaderRow + nRowsProcessed ) >ELSE > cRange = 'A'+TRANSFORM(nHeaderRow ) + ':' ; > + CHR(64+FLOOR(oGrid.ColumnCount/26)-1) ; > + CHR(64+IIF(MOD(oGrid.ColumnCount,26)=0,26,MOD(oGrid.ColumnCount,26))) ; > + TRANSFORM(nHeaderRow + nRowsProcessed ) >ENDIF >oExcel.Range(cRange).Select >oExcel.Selection.Borders(1).LineStyle = 1 >oExcel.Selection.Borders(2).LineStyle = 1 >oExcel.Selection.Borders(3).LineStyle = 1 >oExcel.Selection.Borders(4).LineStyle = 1 >oExcel.ActiveSheet.PageSetup.PrintTitleRows = "$1:$" + TRANSFORM(nHeaderRow) > >*subtotals, if needed, transmitted as comma delimited integers, first is group by column >*from 2nd, summed columns >IF lHasParams AND TYPE('oParameters.subTotals') = 'C' > LOCAL ARRAY aTemp1[1], aTemp2[1] > LOCAL iGroupCount, iGroupColumn > iGroupCount = ALINES(aTemp,oParameters.subtotals,1,[,]) > IF iGroupCount > 1 > FOR i = 1 TO iGroupCount > aTemp[i] = INT(VAL(aTemp[i])) > ENDFOR > iGroupColumn = aTemp[1] > ADEL(aTemp,1) > DIMENSION aTemp[iGroupCount - 1] > oExcel.Selection.Subtotal(iGroupColumn, xlSum, @aTemp, .T., .F., .T.) > ENDIF >ENDIF > >IF lHasParams AND TYPE('oParameters.fileName') = 'C' > oExcel.ActiveSheet.SaveAs(oParameters.fileName) >ENDIF > >IF nRecno > 0 AND nRecno <= RECCOUNT() > GOTO nRecno >ENDIF >oExcel.Cells(1,1).Select >oExcel.ScreenUpdating = .T. >oExcel.Visible = .t. >WAIT CLEAR >Thanks.