Level Extreme platform
Subscription
Corporate profile
Products & Services
Support
Legal
Français
Printing a Grid...
Message
From
01/06/2006 01:15:28
Dorin Vasilescu
ALL Trans Romania
Arad, Romania
 
General information
Forum:
Visual FoxPro
Category:
Reports & Report designer
Environment versions
Visual FoxPro:
VFP 9 SP1
OS:
Windows XP SP2
Network:
Windows 2000 Server
Database:
Visual FoxPro
Miscellaneous
Thread ID:
01126303
Message ID:
01126385
Views:
54
>Is there an easy way to print a grid?

You can export to Excel and print from there
Try this utility of mine. It knows subtotals and extra header rows if needed.
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
Previous
Next
Reply
Map
View

Click here to load this message in the networking platform