开发可复用的从Domino中导出数据到Excel的类

在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 Class ExcelHelper
    
    Private xlApp As Variant                    ' Application object
    Private strFilePath As String    
    
    Sub new()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()Function save
        xlApp.ActiveWorkbook.SaveAs( strFilePath )
    End Function    
    
    Public Function saveAs()Function saveAs(newFilename)
        xlApp.ActiveWorkbook.SaveAs( newFileName )
    End Function    
    
    Public Function setCell()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()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()Function quit
        If Not (xlApp Is Nothing) Then
            xlApp.Quit
            Set xlApp = Nothing    
        End If
    End Function    
    
    Public Function setVisibility()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()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()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()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()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()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()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()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()Function autoFit(Sheet As Variant,col As String)
        xlApp.Workbooks(1).Worksheets(Sheet).Columns(col+":"+col).EntireColumn.AutoFit
    End Function
    
    
End Class

测试程序调用的代理代码如下：

Sub Initialize() 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

该类还有很多不完善的地方，一点一点慢慢来吧。

转载于:https://www.cnblogs.com/hannover/archive/2011/05/31/2065208.html