• 开发可复用的从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
        
       
    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


    该类还有很多不完善的地方,一点一点慢慢来吧。
    作者:生鱼片
             
    本文版权归作者和博客园共有,欢迎转载,但未经作者同意必须保留此段声明,且在文章页面明显位置给出原文连接,否则保留追究法律责任的权利。
  • 相关阅读:
    ZOJ3861 Valid Pattern Lock
    ZOJ 3866 Cylinder Candy
    hdu 1729 Stone Game SG函数
    hdu 2546 饭卡 01背包
    hdu 2084 数塔
    中国科学院大学生创新实践训练计划-
    中国科技论文在线期刊模板出现了格式问题,怎么解决?
    1015. 德才论 (25)
    1014. 福尔摩斯的约会 (20)
    Ubuntu 14.0的安装及联网
  • 原文地址:https://www.cnblogs.com/carysun/p/DominoExcel.html
Copyright © 2020-2023  润新知