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