开发可复用的从Domino中导出数据到Excel的类-阿里云开发者社区

开发可复用的从Domino中导出数据到Excel的类
2017-01-10 989
版权
本文内容由阿里云实名注册用户自发贡献，版权归原作者所有，阿里云开发者社区不拥有其著作权，亦不承担相应法律责任。具体规则请查看《阿里云开发者社区用户服务协议》和《阿里云开发者社区知识产权保护指引》。如果您发现本社区中有涉嫌抄袭的内容，填写侵权投诉表单进行举报，一经查实，本社区将立刻删除涉嫌侵权内容。
简介：
在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 
  
       
     

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