Visual FoxPro Grid2Xls

Cum se poate exporta Grid VFP in Excel?

SELECT cFacturiTotal

op = NEWOBJECT('Collection')
op.ADD(NEWOBJECT('Empty'),'headers') &&headers item, empty class

ADDPROPERTY(op.ITEM(1),'aHeaders[3,8]',.F.) &&aHeaders, array property, 8 columns
WITH op.ITEM(1)
* 1st header
.aheaders[1,1] = mHeader
.aheaders[1,2] = 1 &&row
.aheaders[1,3] = 2 &&column
.aheaders[1,4] = 'Arial' &&FontName
.aheaders[1,5] = 6 &&FontSize
.aheaders[1,6] = .T. &&FontBold
.aheaders[1,7] = .T. &&FontItalic

*2nd header
.aheaders[2,1] = mTitlu
.aheaders[2,2] = 2 &&row
.aheaders[2,3] = 2 &&column
.aheaders[2,4] = 'Arial' &&FontName
.aheaders[2,5] = 12 &&FontSize
.aheaders[2,6] = .T. &&FontBold
.aheaders[2,7] = .F. &&FontItalic
.aheaders[2,8] = -4108 &&Alignment ( xlCenter )

*3nd header
.aheaders[3,1] = mPerioada
.aheaders[3,2] = 3 &&row
.aheaders[3,3] = 2 &&column
.aheaders[3,4] = 'Arial' &&FontName
*.aheaders[3,5] = 16 &&FontSize
.aheaders[3,6] = .T. &&FontBold
.aheaders[3,7] = .F. &&FontItalic
.aheaders[3,8] = -4108 &&Alignment ( xlCenter )

ENDWITH

ADDPROPERTY(oP,'subtotals','11,3,4,5,6,7,8,9,10')
* first value ( 11 ) : group by column
* next values (3,4,5,6,7,8,9,10) : summed columns

Grid2Xls( THis.Parent.Grid1, op, 'cFacturiTotal', 2 )


Sursa PRG Gris2Xls:

PROCEDURE grid2xls
LPARAMETERS ogrid, oparameters , xrap, nHeaderObject
IF PCOUNT()< 4
nHeaderObject = 1
ENDI
*!* 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, lhasrap
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')
lhasrap = (TYPE('xrap') = 'C')
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
*WAIT WINDOW ogrid.COLUMNS(i).controlsource
ocols.ADD(ogrid.COLUMNS(i), PADL(STR(i,3),3,'0'))
ENDFOR

*SUSPEND

oexcel.displayalerts = .F.
oexcel.screenupdating = .F.
*oexcel.workbooks.ADD
obook = 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(nHeaderObject).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
ctype = TYPE(.CONTROLSOURCE)


DO CASE
CASE ctype = 'C'
ocell.HorizontalAlignment = 2
OTHERWISE
ocell.HorizontalAlignment = 1
ENDC
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

osheet = obook.activesheet

WITH oexcel
*WITH .worksheets(1)
* .COLUMNS.AUTOFIT
* .ROWS.AUTOFIT
*ENDWITH

WITH .activesheet

*OS=oexcel.activesheet && Daca faci asa va functiona IntelliSense in VFP ...
.pagesetup.ORIENTATION= 2 && xlLandscape
.pagesetup.topmargin=5
.pagesetup.bottommargin=5
.pagesetup.leftmargin=31
.pagesetup.rightmargin=2

lnpaperorientation = .pagesetup.ORIENTATION
DO CASE
CASE lnpaperorientation = 2
lnpapersize = 1
lnprintorientation = 2

CASE lnpaperorientation = 3
lnpapersize = 5
lnprintorientation = 1

CASE lnpaperorientation = 4
lnpapersize = 5
lnprintorientation = 2

OTHERWISE
lnpapersize = 1
lnprintorientation = 1

ENDCASE

lctotalrangeexpr = ["A1:] + columnletter(FCOUNT()) + ALLTRIM(STR(RECCOUNT() + 6)) + ["]
lctotalprintarea = ["$A$1:$] + columnletter(FCOUNT()) + [$]+ALLTRIM(STR(RECCOUNT() + 6)) + ["]

oexcelsheet = osheet
oexcelsheet.cells.SELECT
oexcelsheet.cells.entirecolumn.AUTOFIT
oexcelsheet.RANGE(&lctotalrangeexpr.).SELECT


WITH oexcelsheet.pagesetup

*!* This area sets to Title Rows of the spreadsheet that will be printed *!*
*!* on each page. Since this example contains the table field names on *!*
*!* the top row, and then an empty row of cells that was inserted by this *!*
*!* program, then we will set row 1 through row 2 as the title rows. *!*

*.printtitlerows = "$1:$2"

*!* Setting Title Columns would work in similar fashion to Setting Title *!*
*!* Rows. Here, however, the column letter would be used in syntax *!*
*!* similar to the above example. Here, however, a null string is *!*
*!* passed. This example simply shows that the option is available. *!*
*.printtitlecolumns = ""
*.printarea = &lctotalprintarea.

*.leftheader = lcexcelfile

*.CenterHeader = "&A"

*.centerheader = "Facturi Client"
*.rightheader = ""
*!* The below referenced "cStamp" is a procedure contained in this *!*
*!* program. It builds out a string which contains the computer system *!*
*!* date and time on which the resulting Excel file was created. *!*
*.leftfooter = cstamp()
.rightfooter = "Page &P of &N"
.centerhorizontally = .T.
.centervertically = .F.
.ORIENTATION = lnprintorientation
.PAPERSIZE = lnpapersize
.ZOOM = .F.
.fittopageswide = 1
*.fittopagestall = 99
ENDWITH
ENDWITH

ENDWITH

oexcel.cells(1,1).SELECT
oexcel.screenupdating = .T.
oexcel.VISIBLE = .T.

WAIT CLEAR


*!* iif(_soldinitial , m.tsid, m.trd)
*!* iif(_soldinitial , m.tsic, m.trc)
*!* m.tcd
*!* m.tcc
*!* m.ttd
*!* m.ttc
*!* m.tsd
*!* m.tsc

***EVERYTHING BELOW HERE IS MSDN SUPPLIED
*!****************************************************************************!*
*!* Beginning of PROCEDURE ColumnLetter *!*
*!* This procedure derives a letter reference based on a numeric value. It *!*
*!* uses the basis of the ASCII Value of the upper case letters A to Z (65 *!*
*!* through 90) to return the proper letter (or letter combination) for a *!*
*!* provided numeric value. *!*
*!****************************************************************************!*
PROCEDURE columnletter

PARAMETER lncolumnnumber

lnfirstvalue = INT(lncolumnnumber/27)
lcfirstletter = IIF(lnfirstvalue=0,"",CHR(64+lnfirstvalue))
lcsecondletter = CHR(64+MOD(lncolumnnumber,26))

RETURN lcfirstletter + lcsecondletter

*!****************************************************************************!*
*!* End of procedure ColumnLetter *!*
*!****************************************************************************!*


*!****************************************************************************!*
*!* Beginning of PROCEDURE cStamp *!*
*!* This procedure derives a text representation of the system date and time *!*
*!* in the form of: *!*
*!* 01/01/2000 11:59:00 would be rendered as: *!*
*!* Saturday, January 1, 2000 @ 11:59 am *!*
*!****************************************************************************!*
PROCEDURE cstamp

cdtstring1 = CDOW(DATE()) + ", "
cdtstring2 = CMONTH(DATE()) + " "
cdtstring3 = ALLTRIM(STR(DAY(DATE()))) + ", "
cdtstring4 = ALLTRIM(STR(YEAR(DATE()))) + " @ "
cdtstring5 = IIF(VAL(LEFT(TIME(), 2)) > 12, ;
ALLTRIM(STR(VAL(LEFT(TIME(), 2)) - 12)) +;
SUBSTR(TIME(), 3, 3), LEFT(TIME(), 5))
cdtstring6 = IIF(VAL(LEFT(TIME(),2))=>12,"pm","am")
cdtstring = "Created on " + cdtstring1 + ;
cdtstring2 + cdtstring3 + cdtstring4 + cdtstring5 + cdtstring6

RETURN cdtstring

*!****************************************************************************!*
*!* End of procedure cStamp *!*
*!****************************************************************************!*