Foxpro 报表转成Excel_vf form导出excel-CSDN博客

本文链接：https://blog.csdn.net/great801225/article/details/5945647

VF报表指令的完整格式：

REPORT FORM FileName1 | ? [ENVIRONMENT] [Scope]

[FOR lExpression1] [WHILE lExpression2] [NOOPTIMIZE]

[RANGE nStartPage [, nEndPage]]

[HEADING cHeadingText] [SUMMARY] [NORESET] [PLAIN]

[NOCONSOLE | OFF] [PDSETUP]

[NAME ObjectName]

[OBJECT oReportListener | TYPE iExpression]

[TO OutputDestination [NODIALOG]]

[PREVIEW [PreviewDestination] [NOWAIT] [WINDOW WindowName]]

OBJECT oReportListener：这个参数很重，他提供了VF报表在运行时的监听功能。有兴趣的朋友可以仔细阅读一下VF提供ReportListener这个类，帮助文件有详细说明，下面我就针对Report转Excel做简单的介绍。

在Report转Excel过程中会用ReportListener这个类的三个Event、一个Method。一般报表结构都有分页头、明细、页尾三个区域，在看下面的内容前要对VF报表结构有一定了解。

Event:

AfterBand：是报表在处理每个区域之后触发的事件

BeforeBand：是报表在处理每个区域之前触发的事件

EvaluateContents：是报表在处理显示字段时触发的事件

Method:    Render：这个函数负责报表所有显示内容的处理，包括文字、图形、字段。

知道这些用途后我们就可以用ReportListener派生一个新的类，利用这些功能去做自己想做事情。下面是一段Report转Excel代码提供给大家，这对那些想了解VF报表和Ｅxcel外部控制的朋友来说很有参考价值。有兴趣的朋友可以对代码进行优化，还有很大的优化空间。

代码直接在VF 9.0下执行，可以用报表向导生成一个报表。然后用下面的代码执行即可。

Select ReportDataAlias

loListener = CreateObject("XlsListenner", ReportFileName)

loListener.ReportOutXls()

Define Class XlsListenner As ReportListener

lbUnit = 10000 / 72 &&用报表度量单位与Excel度量单位(磅)的转换，VF报表度量除10000得到的是英寸，1英寸=72磅

GrpSpaceHeight = 2082.916 &&这个值是自己计算出来的，是报表每个之间的横栏的高度

XlsOutRow = 0 &&记录输出到第几行

XlsFileName = "" &&要生成的Excel文件名

ReportFileName = "" &&VF报表文件名

m_Ljvalue = 0 &&类定义Sum函数的累计变量

XlscolWidthScale = 1 &&Excel宽与高的度量是不同的，这个变量用于记录宽的与磅之间的比例

ReportInfoAlias = "" &&用于记录报表信息的Ａlias

objExcel = Null &&以下是Excel对象存储变量

objWorkBook = Null

objWorkSheet = Null

Procedure ReportOutXls()

This.ListenerType = -1

Report Form (This.ReportFileName) For Preview Object This

Endproc

Procedure LabelOutXls()

This.ListenerType = -1

Label Form (This.ReportFileName) Object This

Endproc

Procedure DoStatus(cMessage) &&去除进度提示

Nodefault

Endproc

Procedure Init(rptName As String, xlsName As String) &&对报表结构进行分析

Local lcAlias

lcAlias = Alias()

This.ReportFileName = rptName

This.XlsFileName = xlsName

Use (rptName) In 0 Alias rptAlias

This.OpenExcel()

Select rptAlias

Locate For objtype = 1 And objcode = 53

If Found()

lnHPosMargin = Round(hpos / (This.lbUnit), 0)

lnVPosMargin = Round(Height / (This.lbUnit), 0)

Else

lnHPosMargin = 0

lnVPosMargin = 0

Endif

This.SetPageMargin(lnHPosMargin, lnHPosMargin, lnVPosMargin, lnVPosMargin, lnVPosMargin, lnVPosMargin)

This.m_Ljvalue = 0

Select a.*, b.*, Recno() As xlsRow, Recno() As xlsBCol, Recno() As xlsECol From (;

Select objcode As Grpcode, Recno() As GrpRecNum, ;

this.Sum(Iif(objtype = 9, Height, 0)) - Height As GrpVpos, ;

Height As GrpHeight;

From rptAlias Where objtype = 9;

) a Inner Join (;

Select Recno() As RecNum, objtype, objcode, Expr, vpos, hpos, Height, Width ;

From rptAlias Where Inlist(objtype, 5,6,7,8) ;

) b On a.GrpVpos < b.vpos And b.vpos + b.Height < a.GrpVpos + a.GrpHeight ;

Order By b.vpos Into Table csr_grp_info

Use In rptAlias

Replace GrpVpos With GrpVpos - (GrpRecNum - 2) * This.GrpSpaceHeight ;

vpos With vpos - (GrpRecNum - 2) * This.GrpSpaceHeight ;

All In csr_grp_info

Replace GrpVpos With Round(GrpVpos / (This.lbUnit), 1) ;

GrpHeight With Round(GrpHeight / (This.lbUnit), 1) ;

vpos With Round(vpos / This.lbUnit, 1) ;

Height With Round(Height / This.lbUnit, 1);

hpos With Round(hpos / (This.lbUnit) / This.XlscolWidthScale, 2);

Width With Round(Width / (This.lbUnit) / This.XlscolWidthScale, 2);

All In csr_grp_info

Delete For Inlist(objtype, 6, 7) And (Height > Width Or Height = 0 Or Width = 0 ) In csr_grp_info

Pack In csr_grp_info

Replace Height With 14 For Inlist(objtype, 5, 8) And Height < 14 In csr_grp_info

Select vpos, Max(Height) As Height From csr_grp_info Where Inlist(objtype, 5, 8);

Group By vpos Into Cursor csr_tz_height

Select csr_tz_height

Scan

lnVpos = vpos

lnHeight = Height

Replace Height With lnHeight For vpos = lnVpos In csr_grp_info

Endscan

Use In csr_tz_height

Select *, vpos As VSpace, Recno() As xlsRow From (;

Select 0 As Y, Grpcode, GrpRecNum, objtype, RecNum, vpos ;

From csr_grp_info ;

Union;

Select 1 As Y, Grpcode, GrpRecNum, objtype, RecNum, vpos + Height As vpos ;

From csr_grp_info;

)a Order By vpos, RecNum Into Table csr_vspace

lnTzvalue = 0

lnVpos = 0

lnSpace = 0

Select csr_vspace

Scan

If vpos - lnVpos != 0

lnSpace = vpos - lnVpos

Else

lnSpace = lnTzvalue

Endif

Replace VSpace With lnSpace

lnTzvalue = lnSpace

lnVpos = vpos

Endscan

Select Distinct Grpcode, GrpRecNum, vpos, Grpcode As xlsRow From csr_vspace Into Table csr_grp_xlsrow

Select Distinct Grpcode, GrpRecNum From csr_vspace Into Cursor csr_grp

Select csr_grp

Scan

lnGrpcode = Grpcode

lnGrpRecNum = GrpRecNum

Select csr_grp_xlsrow

Locate For Grpcode = lnGrpcode And GrpRecNum = lnGrpRecNum

If Found()

lnRecno = Recno() - 1

Replace xlsRow With Recno("csr_grp_xlsrow") - lnRecno ;

For Grpcode = lnGrpcode And GrpRecNum = lnGrpRecNum In csr_grp_xlsrow

Endif

Endscan

Use In csr_grp

Select csr_grp_xlsrow

Scan

lnGrpcode = Grpcode

lnVpos = vpos

lnXlsRow = xlsRow

Replace xlsRow With lnXlsRow For Grpcode = lnGrpcode And vpos = lnVpos In csr_vspace

Endscan

Use In csr_grp_xlsrow

Select csr_vspace

Scan For Y = 1

lnRecnum = RecNum

lnXlsRow = xlsRow

Replace xlsRow With lnXlsRow For RecNum = lnRecnum In csr_grp_info

Endscan

Select Distinct Grpcode, GrpRecNum, VSpace, xlsRow ;

From csr_vspace Order By Grpcode, xlsRow Into Cursor csr_V_space

Use In csr_vspace

Select Distinct RecNum, Width, hpos From csr_grp_info Order By hpos Into Table csr_hspace

Select Distinct hpos From csr_hspace ;

Union;

Select Max(hpos+Width) As hpos From csr_hspace;

into Cursor csr_hpos

lnPreHpos = 0

Select csr_hpos

Scan

lnHpos = hpos

Replace Width With lnHpos - hpos For lnPreHpos < hpos + Width And hpos + Width < lnHpos In csr_hspace

lnPreHpos = lnHpos

Endscan

Use In csr_hpos

Select csr_hspace

Scan

lnRecnum = RecNum

lnWidth = Width

Replace Width With lnWidth For RecNum = lnRecnum In csr_grp_info

Endscan

Select Distinct *, hpos As HSpace, Recno() As xlsCol From (;

Select hpos From csr_hspace;

Union;

Select hpos + Width As hpos From csr_hspace;

)a Order By hpos Into Table csr_hSpace_tz

Use In csr_hspace

lnHpos = 0

Select csr_hSpace_tz

Scan

Replace HSpace With hpos - lnHpos, xlsCol With Recno()

lnHpos = hpos

Endscan

Select a.RecNum, b.xlsCol As xlsBCol, c.xlsCol As xlsECol ;

From csr_grp_info a Inner Join csr_hSpace_tz b On a.hpos = b.hpos;

Inner Join csr_hSpace_tz c On Round(a.hpos + a.Width, 3) = c.hpos Into Cursor csr_xls_cols

Select csr_xls_cols

Scan

lnRecnum = RecNum

lnXlsBcol = xlsBCol

lnXlsEcol = xlsECol

Replace xlsBCol With lnXlsBcol, xlsECol With lnXlsEcol For RecNum = lnRecnum In csr_grp_info

Endscan

Use In csr_xls_cols

Select csr_hSpace_tz

Scan

This.objWorkSheet.Columns(xlsCol).ColumnWidth = HSpace

Endscan

Use In csr_hSpace_tz

Select &lcAlias

Endproc

Procedure Destroy()

Local lcAlias

lcAlias = Alias()

This.CloseExcel()

If Used("csr_v_space")

Use In csr_V_space

Endif

If Used("csr_grp_info")

Use In csr_grp_info

Endif

If !Empty(lcAlias)

Select &lcAlias

Endif

Endproc

Procedure OpenExcel() &&调用Excel

This.objExcel = Createobject("Excel.Application")

This.objExcel.Visible = .F.

This.objWorkBook = This.objExcel.Workbooks.Add()

This.objWorkSheet = This.objWorkBook.WorkSheets(1)

This.objWorkSheet.Select

This.objExcel.ActiveWindow.DisplayGridlines = .F.

This.XlscolWidthScale = Round(This.objWorkSheet.Range("A1").Width / This.objWorkSheet.Columns(1).ColumnWidth, 3)

Endproc

Function SetPageMargin(pLeftMargin As Integer, pRightMargin As Integer, pTopMargin As Integer, pBottomMargin As Integer;

, pHeaderMargin As Integer, pFooterMargin As Integer) &&设置Excel页边距

With This.objWorkSheet.PageSetup

.LeftMargin = pLeftMargin

.TopMargin = pTopMargin

.HeaderMargin = pHeaderMargin

.RightMargin = 1

.FooterMargin = pBottomMargin

.BottomMargin = pBottomMargin + 55

Endwith

Endfunc

Procedure CloseExcel() &&关闭Excel并保存文件

If Type("this.XlsFileName") == "C" And !Empty(This.XlsFileName)

If File(This.XlsFileName, 1)

Delete File (This.XlsFileName)

Endif

This.objWorkBook.SaveAs(This.XlsFileName)

This.objWorkBook.Close()

This.objExcel.Quit()

Else

This.objExcel.Visible = .T.

Endif

Endproc

Function Sum(fld) As Integer

This.m_Ljvalue = This.m_Ljvalue + fld + Iif(Recno() > 2, This.GrpSpaceHeight, 0)

Return This.m_Ljvalue

Endfunc

oProgFrom = Null

Procedure BeforeReport &&启用进度显示

This.oProgFrom = Createobject("ProcessForm")

This.oProgFrom.pb.Max = Reccount()

This.oProgFrom.pb.Value = 0

This.oProgFrom.Caption = "Report To Excel"

This.oProgFrom.Show()

Endproc

Procedure AfterReport &&关闭进度显示

This.oProgFrom.Release()

Endproc

Procedure AfterBand(nBandObjCode, nFRXRecNo)

Local lcAlias, lisFound

If This.PageTotal < 1

Return

Endif

lcAlias = Alias()

lnXlsRow = 0

Select csr_V_space

Locate For Grpcode = nBandObjCode And GrpRecNum = nFRXRecNo

lisFound = Found()

If lisFound

Do While lisFound

This.objWorkSheet.Rows(This.XlsOutRow + xlsRow).RowHeight = VSpace

lnXlsRow = xlsRow

Continue

lisFound = Found()

Enddo

If nBandObjCode == 4

This.oProgFrom.pb.Add()

Endif

This.XlsOutRow = This.XlsOutRow + lnXlsRow

Select &lcAlias

Endproc

Function XlsColName(pColNumber As Integer) &&数字转Excel列名

Local divVal, divMod, cHeight

divMod = Mod( pColNumber, 26 )

divVal = Int( pColNumber / 26 )

If divVal <= 0

Return Chr( 65 + divMod )

Endif

cHeight = This.XlsColName( divVal - 1 )

Return cHeight + Chr( 65 + divMod )

Endfunc

Function XlsCellAddr(pRowNumber As Integer, pColNumber As Integer)

Local lcColName As String

lcColName = This.XlsColName(pColNumber - 1)

If Type("pRowNumber") = "N" And pRowNumber > 0

Return lcColName + Alltrim(Str(pRowNumber, 5, 0))

Endif

Return lcColName

Endfunc

PrePageNo = 1

Procedure Render(nFRXRecNo, nLeft,nTop,nWidth,nHeight, nObjectContinuationType, cContentsToBeRendered, GDIPlusImage)

Local lcAlias, lcCells

lcAlias = Alias()

If This.PageTotal < 1

Return

Endif

Select csr_grp_info

Locate For RecNum = nFRXRecNo

If Found()

If This.PrePageNo != This.PageNo

This.AddPageBreak()

This.PrePageNo = This.PageNo

Endif

Do Case

Case objtype = 6

lcCells = This.XlsCellAddr(This.XlsOutRow + xlsRow, xlsBCol)+":"+This.XlsCellAddr(This.XlsOutRow + xlsRow, xlsECol)

This.objWorkSheet.Application.Range(lcCells).Interior.Color = Rgb(0, 0, 0)

Case Inlist(objtype, 5, 8)

This.objWorkSheet.Application.Cells(This.XlsOutRow + xlsRow, xlsBCol + 1).Value = Strconv(cContentsToBeRendered, 6)

If xlsBCol + 1 <> xlsECol

lcCells = This.XlsCellAddr(This.XlsOutRow + xlsRow, xlsBCol+1)+":"+This.XlsCellAddr(This.XlsOutRow + xlsRow, xlsECol)

This.objWorkSheet.Application.Range(lcCells).Merge()

Endif

Endcase

Endif

Select &lcAlias

Endproc

Procedure AddPageBreak()

This.objWorkSheet.HPageBreaks.Add(This.objWorkSheet.Rows(This.XlsOutRow + 1))

Endproc

Enddefine

Define Class Progress Form as Form

Add Object pb as ProgressBar

BorderStyle = 2

AutoCenter = .t.

Width = 500

Height = 50

pb.left = 5

pb.top = 10

pb.Width = 500 - 10

pb.height = 25

ControlBox = .f.

AlwaysOnTop = .t.

BackColor = Rgb(255,255,220)

EndDefine

Define class ProgressBar as OleControl

OleClass = "MSComctlLib.ProgCtrl.2"

BorderStyle = 1

Scrolling = 0

Step = 1

Function Add

this.Value = Iif(this.Value >= this.Max, this.Value, this.Value + 1)

If Mod(this.Value, this.Step) = 0

this.Refresh()

EndIf

EndFunc

EndDefine