在domino开发中我们不可避免的要和报表打交道,一般就是生成各种Excel报表,本人主要为了自己在开发中方便,简单实现了一个基本类,现在功能有限,当然这个类我慢慢的根据以后遇到的需求逐渐完善。
Const EXCEL_APPLICATION = "Excel.application"
Private Const BASEERROR = 1200
'Private Const ERROR_NOSUCHCELL = BASEERROR + 0
'Private Const ERRORTEXT_NOSUCHCELL = "Excel Report - Could not get data from cell."
Const REG_97 = "Software\\Microsoft\\Office\\8.0\\Common\\InstallRoot" 'Registry Key Office 97
Const REG_2000 = "Software\\Microsoft\\Office\\9.0\\Common\\InstallRoot" 'Registry Key Office 2000
Const REG_XP = "Software\\Microsoft\\Office\\10.0\\Common\\InstallRoot" 'Registry Key Office XP
Const REG_2003 ="Software\\Microsoft\\Office\\11.0\\Common\\InstallRoot" 'Registry Key Office 2003
Const NAME_97 = "Office 97"
Const NAME_2000 = "Office 2000"
Const NAME_XP = "Office XP"
Const NAME_2003 = "Office 2003"
Class ExcelHelper
Private xlApp As Variant ' Application object
Private strFilePath As String
Sub new(xlFilename As String, isVisible As Boolean)
On Error Goto GeneralError
Set xlApp = CreateObject(EXCEL_APPLICATION) ' open the application
xlApp.Workbooks.Add xlFilename ' create an Excel workbook
xlApp.Visible = isVisible ' make it visible (or not)
strFilePath = xlFilename ' store the filename
Goto ExitSub
GeneralError:
If Not (xlApp Is Nothing) Then xlApp.quit ' quit, if there is an error
Resume ExitSub
ExitSub:
End Sub
Public Function save
xlApp.ActiveWorkbook.SaveAs( strFilePath )
End Function
Public Function saveAs(newFilename)
xlApp.ActiveWorkbook.SaveAs( newFileName )
End Function
Public Function setCell( Sheet As Variant , row As Integer , column As Variant , value As Variant )
xlApp.Workbooks(1).Worksheets( Sheet ).Cells( row , column ).Value = value
End Function
Public Function getCell( Sheet As Variant , row As Integer , column As Variant ) As String
On Error Goto GeneralError
getCell = xlApp.Workbooks(1).Worksheets( Sheet ).Cells( row , column ).Value
Goto ExitSub
GeneralError:
getCell = ""
Resume ExitSub
ExitSub:
End Function
Public Function quit
If Not (xlApp Is Nothing) Then
xlApp.Quit
Set xlApp = Nothing
End If
End Function
Public Function setVisibility(isVisible As Boolean)
If (isVisible And Not xlApp.Visible) Then xlApp.Visible = True
If (Not isVisible And xlApp.Visible) Then xlApp.Visible = False
End Function
Public Function setSheetName(Sheet As Variant,sheetName As String)
xlApp.Workbooks(1).Worksheets( Sheet ).Select
xlApp.Workbooks(1).Worksheets( Sheet ).Name=sheetName
End Function
Public Function setCellColor(Sheet As Variant, row As Integer, column As Variant, innercolor As Variant)
On Error Goto GeneralError
If Cstr(innercolor) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Cells( row , column ).Interior.ColorIndex = innercolor
End If
Goto ExitSub
GeneralError:
Resume ExitSub
ExitSub:
End Function
Public Function setCellFont(Sheet As Variant, row As Integer, column As Variant, style As Variant, size As Variant, color As Variant)
On Error Goto GeneralError
If Cstr(style) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Cells( row , column ).Font.FontStyle = style
End If
If Cstr(size) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Cells( row , column ).Font.Size = size
End If
If Cstr(color) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Cells( row , column ).Font.ColorIndex = color
End If
Goto ExitSub
GeneralError:
Resume ExitSub
ExitSub:
End Function
Public Function setRowFont(Sheet As Variant, row As Integer, style As Variant, size As Variant, color As Variant)
On Error Goto GeneralError
Dim rowpara As String
rowpara=Cstr(row)+":"+Cstr(row)
If Cstr(style) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Rows(rowpara).Select
xlApp.Selection.Font.FontStyle = style
End If
If Cstr(size) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Rows(rowpara).Select
xlApp.Selection.Font.Size = size
End If
If Cstr(color) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Rows(rowpara).Select
xlApp.Selection.Font.ColorIndex = color
End If
Goto ExitSub
GeneralError:
Resume ExitSub
ExitSub:
End Function
Public Function getVersion() As String
On Error Goto GeneralError
Dim formula As String
Dim SWVersion As String
Dim Versions List As String
Dim v As Variant
Versions(NAME_97) = REG_97
Versions(NAME_2000) = REG_2000
Versions(NAME_XP) = REG_XP
Versions(NAME_2003) = REG_2003
Forall vers In Versions
formula$ = | (@RegQueryValue("HKEY_LOCAL_MACHINE"; "| & vers & |";"Path")) |
v = Evaluate( formula$ )
If v(0) <> "" Then
getVersion = Listtag(vers)
Goto ExitSub
End If
End Forall
getVersion = ""
Goto ExitSub
GeneralError:
getVersion = ""
Resume ExitSub
ExitSub:
End Function
Public Function exportNotesView(view As NotesView, Sheet As Variant, OffsetRow As Integer, OffsetCol As Integer, isWithheader As Boolean, includeIcons As Boolean, includeColors As Boolean, includeHidden As Boolean)
Dim viewnav As NotesViewNavigator
Dim entry As NotesViewEntry
Dim viewcolumns As Variant
Dim column As Integer
Dim row As Integer
Dim i As Integer
Dim array(0 To 9) As String
array(0)="A"
array(1)="B"
array(2)="C"
array(3)="D"
array(4)="E"
array(5)="F"
array(6)="G"
array(7)="H"
array(8)="I"
array(9)="J"
Set viewnav = view.CreateViewNav()
Set entry = viewnav.GetFirstDocument()
viewcolumns = view.Columns
row = OffsetRow + 1
column = OffsetCol + 1
If isWithHeader Then
Forall vc In viewcolumns
Call Me.setCell(Sheet, row, column, vc.title)
column = column + 1
End Forall
End If
While Not (entry Is Nothing)
row = row + 1
column = OffsetCol + 1
Forall cv In entry.ColumnValues
If doColumnExport(viewcolumns(column - OffsetCol - 1), includeHidden, IncludeIcons, includeColors) Then
Call Me.setCell(Sheet, row, column, Cstr(cv))
End If
column = column + 1
End Forall
Set entry = viewnav.GetNextDocument(entry)
Wend
For i=0 To (column-1)
Call Me.autoFit(Sheet,array(i))
Next
End Function
Private Function doColumnExport (viewcol As NotesViewColumn, includeHidden As Boolean, IncludeIcons As Boolean, includeColors As Boolean) As Boolean
Dim isHiddenOK As Boolean
Dim isIconOK As Boolean
Dim isColorOK As Boolean
isHiddenOK = (viewcol.isHidden And IncludeHidden) Or Not viewcol.isHidden
isIconOK = (viewcol.isIcon And IncludeIcons) Or Not (viewcol.isIcon)
isColorOK = True
doColumnExport = isHiddenOK And isIconOK And isColorOK
End Function
Public Function autoFit(Sheet As Variant,col As String)
xlApp.Workbooks(1).Worksheets(Sheet).Columns(col+":"+col).EntireColumn.AutoFit
End Function
End Class
测试程序调用的代理代码如下:
该类还有很多不完善的地方,一点一点慢慢来吧。
Private Const BASEERROR = 1200
'Private Const ERROR_NOSUCHCELL = BASEERROR + 0
'Private Const ERRORTEXT_NOSUCHCELL = "Excel Report - Could not get data from cell."
Const REG_97 = "Software\\Microsoft\\Office\\8.0\\Common\\InstallRoot" 'Registry Key Office 97
Const REG_2000 = "Software\\Microsoft\\Office\\9.0\\Common\\InstallRoot" 'Registry Key Office 2000
Const REG_XP = "Software\\Microsoft\\Office\\10.0\\Common\\InstallRoot" 'Registry Key Office XP
Const REG_2003 ="Software\\Microsoft\\Office\\11.0\\Common\\InstallRoot" 'Registry Key Office 2003
Const NAME_97 = "Office 97"
Const NAME_2000 = "Office 2000"
Const NAME_XP = "Office XP"
Const NAME_2003 = "Office 2003"
Class ExcelHelper
Private xlApp As Variant ' Application object
Private strFilePath As String
Sub new(xlFilename As String, isVisible As Boolean)
On Error Goto GeneralError
Set xlApp = CreateObject(EXCEL_APPLICATION) ' open the application
xlApp.Workbooks.Add xlFilename ' create an Excel workbook
xlApp.Visible = isVisible ' make it visible (or not)
strFilePath = xlFilename ' store the filename
Goto ExitSub
GeneralError:
If Not (xlApp Is Nothing) Then xlApp.quit ' quit, if there is an error
Resume ExitSub
ExitSub:
End Sub
Public Function save
xlApp.ActiveWorkbook.SaveAs( strFilePath )
End Function
Public Function saveAs(newFilename)
xlApp.ActiveWorkbook.SaveAs( newFileName )
End Function
Public Function setCell( Sheet As Variant , row As Integer , column As Variant , value As Variant )
xlApp.Workbooks(1).Worksheets( Sheet ).Cells( row , column ).Value = value
End Function
Public Function getCell( Sheet As Variant , row As Integer , column As Variant ) As String
On Error Goto GeneralError
getCell = xlApp.Workbooks(1).Worksheets( Sheet ).Cells( row , column ).Value
Goto ExitSub
GeneralError:
getCell = ""
Resume ExitSub
ExitSub:
End Function
Public Function quit
If Not (xlApp Is Nothing) Then
xlApp.Quit
Set xlApp = Nothing
End If
End Function
Public Function setVisibility(isVisible As Boolean)
If (isVisible And Not xlApp.Visible) Then xlApp.Visible = True
If (Not isVisible And xlApp.Visible) Then xlApp.Visible = False
End Function
Public Function setSheetName(Sheet As Variant,sheetName As String)
xlApp.Workbooks(1).Worksheets( Sheet ).Select
xlApp.Workbooks(1).Worksheets( Sheet ).Name=sheetName
End Function
Public Function setCellColor(Sheet As Variant, row As Integer, column As Variant, innercolor As Variant)
On Error Goto GeneralError
If Cstr(innercolor) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Cells( row , column ).Interior.ColorIndex = innercolor
End If
Goto ExitSub
GeneralError:
Resume ExitSub
ExitSub:
End Function
Public Function setCellFont(Sheet As Variant, row As Integer, column As Variant, style As Variant, size As Variant, color As Variant)
On Error Goto GeneralError
If Cstr(style) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Cells( row , column ).Font.FontStyle = style
End If
If Cstr(size) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Cells( row , column ).Font.Size = size
End If
If Cstr(color) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Cells( row , column ).Font.ColorIndex = color
End If
Goto ExitSub
GeneralError:
Resume ExitSub
ExitSub:
End Function
Public Function setRowFont(Sheet As Variant, row As Integer, style As Variant, size As Variant, color As Variant)
On Error Goto GeneralError
Dim rowpara As String
rowpara=Cstr(row)+":"+Cstr(row)
If Cstr(style) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Rows(rowpara).Select
xlApp.Selection.Font.FontStyle = style
End If
If Cstr(size) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Rows(rowpara).Select
xlApp.Selection.Font.Size = size
End If
If Cstr(color) <> "" Then
xlApp.Workbooks(1).Worksheets( Sheet ).Rows(rowpara).Select
xlApp.Selection.Font.ColorIndex = color
End If
Goto ExitSub
GeneralError:
Resume ExitSub
ExitSub:
End Function
Public Function getVersion() As String
On Error Goto GeneralError
Dim formula As String
Dim SWVersion As String
Dim Versions List As String
Dim v As Variant
Versions(NAME_97) = REG_97
Versions(NAME_2000) = REG_2000
Versions(NAME_XP) = REG_XP
Versions(NAME_2003) = REG_2003
Forall vers In Versions
formula$ = | (@RegQueryValue("HKEY_LOCAL_MACHINE"; "| & vers & |";"Path")) |
v = Evaluate( formula$ )
If v(0) <> "" Then
getVersion = Listtag(vers)
Goto ExitSub
End If
End Forall
getVersion = ""
Goto ExitSub
GeneralError:
getVersion = ""
Resume ExitSub
ExitSub:
End Function
Public Function exportNotesView(view As NotesView, Sheet As Variant, OffsetRow As Integer, OffsetCol As Integer, isWithheader As Boolean, includeIcons As Boolean, includeColors As Boolean, includeHidden As Boolean)
Dim viewnav As NotesViewNavigator
Dim entry As NotesViewEntry
Dim viewcolumns As Variant
Dim column As Integer
Dim row As Integer
Dim i As Integer
Dim array(0 To 9) As String
array(0)="A"
array(1)="B"
array(2)="C"
array(3)="D"
array(4)="E"
array(5)="F"
array(6)="G"
array(7)="H"
array(8)="I"
array(9)="J"
Set viewnav = view.CreateViewNav()
Set entry = viewnav.GetFirstDocument()
viewcolumns = view.Columns
row = OffsetRow + 1
column = OffsetCol + 1
If isWithHeader Then
Forall vc In viewcolumns
Call Me.setCell(Sheet, row, column, vc.title)
column = column + 1
End Forall
End If
While Not (entry Is Nothing)
row = row + 1
column = OffsetCol + 1
Forall cv In entry.ColumnValues
If doColumnExport(viewcolumns(column - OffsetCol - 1), includeHidden, IncludeIcons, includeColors) Then
Call Me.setCell(Sheet, row, column, Cstr(cv))
End If
column = column + 1
End Forall
Set entry = viewnav.GetNextDocument(entry)
Wend
For i=0 To (column-1)
Call Me.autoFit(Sheet,array(i))
Next
End Function
Private Function doColumnExport (viewcol As NotesViewColumn, includeHidden As Boolean, IncludeIcons As Boolean, includeColors As Boolean) As Boolean
Dim isHiddenOK As Boolean
Dim isIconOK As Boolean
Dim isColorOK As Boolean
isHiddenOK = (viewcol.isHidden And IncludeHidden) Or Not viewcol.isHidden
isIconOK = (viewcol.isIcon And IncludeIcons) Or Not (viewcol.isIcon)
isColorOK = True
doColumnExport = isHiddenOK And isIconOK And isColorOK
End Function
Public Function autoFit(Sheet As Variant,col As String)
xlApp.Workbooks(1).Worksheets(Sheet).Columns(col+":"+col).EntireColumn.AutoFit
End Function
End Class
测试程序调用的代理代码如下:
Sub Initialize
Dim view As NotesView
Dim excelfilepath As String
Dim Sheet As Variant
Dim OffsetX As Integer
Dim OffsetY As Integer
Dim isWithHeader As Boolean
Dim includeIcons As Boolean
Dim includeColors As Boolean
Dim includeHidden As Boolean
Dim session As New NotesSession
Dim currdb As NotesDatabase
Const Font_Style = "Bold"
Const Font_Size =12
Const Font_Color =5
Set currdb=session.CurrentDatabase
Sheet = 1
OffsetX = 1
OffsetY = 1
isWithHeader = True
includeIcons = True
includeColors = True
includeHidden = True
excelfilepath = "" ' create an empty excel file
'Set view = ws.CurrentView.View
Set view=currdb.GetView("chunainfo")
Set report= New ExcelHelper("", True)
'Call report.setCellFont(1, 2, 2, Font_Style, Font_Size, Font_Color)
Call report.setRowFont(1, 2, Font_Style, Font_Size, Font_Color)
Call report.exportNotesView(view, Sheet, OffsetX, OffsetY, isWithheader, includeIcons, includeColors, includeHidden)
Call report.exportNotesView(view, 2, OffsetX, OffsetY, isWithheader, includeIcons, includeColors, includeHidden)
Call report.setVisibility(True)
Call report.setSheetName(Sheet,"请假单")
Call report.setSheetName(2,"出差报核单")
Msgbox "成功导出报表"
End Sub
Dim view As NotesView
Dim excelfilepath As String
Dim Sheet As Variant
Dim OffsetX As Integer
Dim OffsetY As Integer
Dim isWithHeader As Boolean
Dim includeIcons As Boolean
Dim includeColors As Boolean
Dim includeHidden As Boolean
Dim session As New NotesSession
Dim currdb As NotesDatabase
Const Font_Style = "Bold"
Const Font_Size =12
Const Font_Color =5
Set currdb=session.CurrentDatabase
Sheet = 1
OffsetX = 1
OffsetY = 1
isWithHeader = True
includeIcons = True
includeColors = True
includeHidden = True
excelfilepath = "" ' create an empty excel file
'Set view = ws.CurrentView.View
Set view=currdb.GetView("chunainfo")
Set report= New ExcelHelper("", True)
'Call report.setCellFont(1, 2, 2, Font_Style, Font_Size, Font_Color)
Call report.setRowFont(1, 2, Font_Style, Font_Size, Font_Color)
Call report.exportNotesView(view, Sheet, OffsetX, OffsetY, isWithheader, includeIcons, includeColors, includeHidden)
Call report.exportNotesView(view, 2, OffsetX, OffsetY, isWithheader, includeIcons, includeColors, includeHidden)
Call report.setVisibility(True)
Call report.setSheetName(Sheet,"请假单")
Call report.setSheetName(2,"出差报核单")
Msgbox "成功导出报表"
End Sub
该类还有很多不完善的地方,一点一点慢慢来吧。