web导出Excel(Xml格式)

 
'***************************************************
'* 类：CNotesDocumentCollection1
' 重定义CNotesDocumentCollection类，本处用于导出excel时，如果存在多值域，则按多行显示，非多值域合并单元格，b0110510,pan guangbiao
'***************************************************
Public Class CNotesDocumentCollection1
 m_dc As NotesDocumentCollection
 m_ViewPath As String
 Sub New (dc As NotesDocumentCollection,viewPath As String)
  Set m_dc=dc
  m_ViewPath=viewPath
 End Sub
 Public Property Get dc As NotesDocumentCollection
  Set dc=m_dc
 End Property
 '**********************************
 '方法：拷贝文档到新数据库
 '日期：2008.11.14
 '**********************************
 Public Function copyToDatabase(db As NotesDatabase,Byval isCopyResponses As Boolean) As Integer
  Dim newdoc As NotesDocument
  Dim doc As NotesDocument
  Dim cdoc As CNotesDocument
  Dim docs() As NotesDocument
  Dim responses As Variant
  
  Redim docs(0)
  Redim responses(0)
  Set doc=m_dc.GetFirstDocument
  Do While Not doc Is Nothing
   Set docs(Ubound(docs))=doc
   Set cdoc=New CNotesDocument(doc)
   If isCopyResponses Then
    If doc.IsResponse Then
     Redim Preserve responses(Ubound(responses)+1)
    Else
     Redim Preserve docs(Ubound(docs)+1)
     Call cdoc.copyToDatabase(db,Nothing,True)
    End If
   Else
    Call doc.copyToDatabase(db)
   End If
   Set doc=m_dc.GetNextDocument(doc)
  Loop
  For i=0 To Ubound(responses)-1
   Set cdoc=New CNotesDocument(responses(i))
   '待续...
  Next
  
 End Function
 '修改时间：2009.04.21
 Public Function PrintToWebByXML(view As Variant,lCount As Long,lStart As Long)
  On Error Goto ERR_Handle
  
  Dim aColumns As Variant
  Dim doc As NotesDocument 
  Dim docViewColumn As NotesDocument
  Dim dc As NotesDocumentCollection
  Dim i As Long
  Dim j As Integer
  Dim iOutCount As Integer
  Dim tmp As Variant
  Dim sViewType As String
  Dim sColumnValue As String
  Dim sColumnText As String
  
  Print |Content-Type: text/xml; charset=UTF-8|
  Print "Cache-Control: no-cache"
  Print "Pragma: no-cache"
  Print "Expires: 0"
  Print |<?xml version="1.0" encoding="UTF-8"?>|
  
  Set dc=m_dc
  sViewType=Typename(view)
L_ViewType:
  Select Case sViewType
  Case "NOTESVIEW"
   
  Case "CNOTESCUSTOMVIEW"
   Print |<viewentries toplevelentries="|+Cstr(dc.Count)+|" database="|+dc.Parent.FilePath+|">|
   i=0
   Set doc=dc.GetFirstDocument()
   Do While Not doc Is Nothing
    If (iOutCount+1)>lCount Then
     Exit Do
    End If
    If (i+1)<lStart Then
     Goto L_Continue
    End If
    Print |<viewentry position="|+Cstr(i+1)+|" unid="|+doc.UniversalID+|" children="0">|
    aColumns=view.AllVisibleColumns
    For j=0 To Ubound(aColumns)
     On Error Resume Next
     Set docViewColumn=aColumns(j)
     If docViewColumn.Value(0)="" Then
      sColumnValue=Cstr(i+1)
     Else
      sColumnValue=Join(Evaluate(docViewColumn.Value(0),doc),",")
     End If
     If docViewColumn.DisplayValue(0)="" Then
      sColumnText=""
     Else
      sColumnText=Join(Evaluate(docViewColumn.DisplayValue(0),doc),",")
      If Lenbp(sColumnText)>150 Then
       sColumnText=Leftbp(sColumnText,150)+"..."
      End If
     End If
     Print |<entrydata columnnumber="|+Cstr(j)+|"| _
     +| name="|+docViewColumn.Name(0) +|"| _
     +| category="false"| _
     +| width="|+docViewColumn.Width(0)+|"| _
     +| align="|+docViewColumn.Align(0)+|"| _
     +|>|
     Print |<text>|+EncodeXMLData(sColumnValue)+|</text>|
     Print |<displaytext>|+EncodeXMLData(sColumnText)+|</displaytext>|
     Print |</entrydata>|
    Next
    Print |</viewentry>|
    iOutCount=iOutCount+1
L_Continue:
    Set doc=dc.GetNextDocument(doc)
    i=i+1
    If i=dc.Count Then Exit Do 'Count有时和结果不一致，比如在限定搜索结果数时
   Loop
   Print |</viewentries>|
  Case Else
   If Instr(sViewType,"NOTESCUSTOMVIEW")>0 Then
    sViewType="CNOTESCUSTOMVIEW"
    Goto L_ViewType
   Else
    Error 0,"input view type "+Typename(view)+ "error !"
   End If
  End Select
  Exit Function
ERR_Handle:
  Msgbox |Script "CNotesDocumentCollection.PrintToWebByXML()" error on line: |+Cstr(Erl)+| , error: |+Error
 End Function
 Public Function PrintToWebByExcel(view As Variant,fileName As String)
  On Error Goto ERR_Handle
  
  Dim aColumns As Variant
  Dim doc As NotesDocument 
  Dim docViewColumn As NotesDocument
  Dim dc As NotesDocumentCollection
  Dim i As Long
  Dim j As Integer
  Dim tmp As Variant
  Dim sViewType As String
  
  'Print |Content-Type: text/xml; charset=UTF-8|
  Print |Content-Type:application/vnd.ms-excel; charset=utf-8|
  Print |Content-Disposition:Attachment;filename="|+fileName+|"|
  Print "Cache-Control: no-cache"
  Print "Pragma: no-cache"
  Print "Expires: 0"
  
  Print |<?xml version="1.0" encoding="UTF-8"?>|
  Print |<?mso-application progid="Excel.Sheet"?>|
  Print |<Workbook xmlns="urn:schemas-microsoft-com:office:spreadsheet"|
  Print | xmlns:o="urn:schemas-microsoft-com:office:office"|
  Print | xmlns:x="urn:schemas-microsoft-com:office:excel"|
  Print | xmlns:ss="urn:schemas-microsoft-com:office:spreadsheet"|
  Print | xmlns:html=" http://www.w3.org/TR/REC-html40">|
  Print |  <Styles>|
  Print |  <Style ss:ID="Default" ss:Name="Normal">|
  Print |   <Alignment ss:Vertical="Center"/>|
  Print |   <Font ss:Size="10"/>|
  Print |   <Interior/>|
  Print |   <NumberFormat/>|
  Print |   <Protection/>|
  Print |  </Style>|
  Print |  <Style ss:ID="ViewTitle">|
  Print |   <Font ss:Bold="1"/>|
  Print |  </Style>|
  Print |  <Style ss:ID="ViewEntry">|
  Print |  </Style>|
  Print |  <Style ss:ID="ViewTitleElement">|
  Print |   <Borders>|
  Print |    <Border ss:Position="Bottom" ss:LineStyle="Continuous" ss:Weight="1"/>|
  Print |    <Border ss:Position="Left" ss:LineStyle="Continuous" ss:Weight="1"/>|
  Print |    <Border ss:Position="Right" ss:LineStyle="Continuous" ss:Weight="1"/>|
  Print |    <Border ss:Position="Top" ss:LineStyle="Continuous" ss:Weight="1"/>|
  Print |   </Borders>|
  Print |   <Font ss:Bold="1"/>|
  Print |  </Style>|
  Print |  <Style ss:ID="ViewElement">|
  Print |   <Borders>|
  Print |    <Border ss:Position="Bottom" ss:LineStyle="Continuous" ss:Weight="1"/>|
  Print |    <Border ss:Position="Left" ss:LineStyle="Continuous" ss:Weight="1"/>|
  Print |    <Border ss:Position="Right" ss:LineStyle="Continuous" ss:Weight="1"/>|
  Print |    <Border ss:Position="Top" ss:LineStyle="Continuous" ss:Weight="1"/>|
  Print |   </Borders>|
  Print |  </Style>|
  Print|<Style ss:ID="s65">|
  Print|<Font ss:FontName="宋体" x:CharSet="134"/>|
  Print|</Style>|
  Print |<Style ss:ID="s22">}|
  Print |<Alignment ss:Vertical="Bottom" ss:WrapText="1"/>|
  Print  |</Style>|  
  Print | </Styles>|
  
  Print | <Worksheet ss:Name="Sheet1">|
  Print |  <Table>|
  Print |<Column ss:Index="1" ss:AutoFitWidth="0" />|
  Print |<Column ss:Index="2" ss:AutoFitWidth="0" />|
  Print |<Column ss:Index="3" ss:AutoFitWidth="0" />|
  Print |<Column ss:Index="4" ss:AutoFitWidth="0" />|
  Print |<Column ss:Index="5" ss:AutoFitWidth="0" />|
  Print |<Column ss:Index="6" ss:AutoFitWidth="0" />|
  Print |<Column ss:Index="7" ss:AutoFitWidth="0" />|
  
  Set dc=m_dc
  sViewType=Typename(view)
L_ViewType:
  Select Case sViewType
  Case "NOTESVIEW"
   
  Case "CNOTESCUSTOMVIEW"
   aColumns=view.Columns
   Print |<Row ss:AutoFitHeight="0" ss:Height="15" ss:StyleID="ViewTitle">|
   Forall column In aColumns
    Print |<Cell ss:StyleID="ViewTitleElement"><Data ss:Type="String">|+column.Title(0)+|</Data></Cell>|
   End Forall
   Print |</Row>|
   i=0
   Set doc=dc.GetFirstDocument()
   Dim total As Long
   Dim printValue As Variant
   total=0
   Dim brCount As Integer'单值的换行数目
   Dim printXml As String
   Do While Not doc Is Nothing 
    '获取所有列的值，存储在二维数组中
    Dim arrFieldValue As Variant
    Dim arrTemp As Variant
    Dim maxIndex As Integer'存放某列多值域最大的下标
    Dim maxRow As Integer'所有列的值中
    maxIndex=0
    For j=0 To Ubound(aColumns)
     Set docViewColumn=aColumns(j)
     If docViewColumn.Value(0)="" Then
      tmp=Cstr(i+1)
      tmps=Split(tmp,",")
     Else
      tmps=Evaluate(docViewColumn.Value(0),doc)
      If Ubound(tmps)>maxIndex Then
       maxIndex=Ubound(tmps)
      End If
     End If
     
     Call ArrayXPush(arrFieldValue,arrFieldValue,tmps)
    Next    
    
    '将所有列的值显示为xml格式，多值显示为多行，单值合并单元格
    Dim m As Integer'列
    Dim n As Integer'行
    Dim arrTempValue As Variant'某列值的集合
    Dim datasType As String
    Dim arrTmp As Variant
    For n=0 To maxIndex
     
     printXml=""
     brCount=1
     For m=0 To Ubound(arrFieldValue)
      arrTempValue=arrFieldValue(m)
      datasType="String"      
      If Ubound(arrTempValue)=0 Then'为单值域
       If n=0 Then
        '计算值的回车数目
        arrTmp=Split(arrTempValue(n),"<br>")
        brCount=Ubound(arrTmp)+1
        '-------end----------
        printValue=ReplaceSubstring(arrTempValue(n),"&","&amp;")
        printValue=ReplaceSubstring(printValue,"<br>","&#13;&#10;")
        printXml=printXml+|<Cell  ss:MergeDown="|+Cstr(maxIndex)+|" ss:StyleID="s22"><Data ss:Type="|+datasType+|">|+printValue+|</Data></Cell>|
        
       End If
      Else
       '计算值的回车数目
       arrTmp=Split(arrTempValue(n),"<br>")
       If Ubound(arrTmp)+1>brCount Then
        brCount=Ubound(arrTmp)+1
       End If
       '--------end--------
       printValue=ReplaceSubstring(arrTempValue(n),"&","&amp;")
       printValue=ReplaceSubstring(printValue,"<br>","&#13;&#10;")
       printXml=printXml+ |<Cell  ss:Index="|+Cstr(m+1)+|"  ss:StyleID="s22"><Data ss:Type="|+datasType+|">|+printValue+|</Data></Cell>|
      End If
      If Me.m_ViewPath="VD_Print_TestRequisition"Then
       '实验费用求和
       If m=Ubound(arrFieldValue)Then
        If Isnumeric(arrTempValue(n))Then
         total=total+Int(arrTempValue(n))
        End If        
       End If
      End If
      
     Next
     Msgbox Cstr(12*brCount)
     printXml=|<Row  ss:Height="|+Cstr(12*brCount)+|">|+printXml+ |</Row>|
     Print printXml
    Next
    
    arrFieldValue=arrTemp
    Set doc=dc.GetNextDocument(doc)
    i=i+1
    If i=dc.Count Then Exit Do 'Count有时和结果不一致，比如在限定搜索结果数时
   Loop
   
  Case Else
   If Instr(sViewType,"NOTESCUSTOMVIEW")>0 Then
    sViewType="CNOTESCUSTOMVIEW"
    Goto L_ViewType
   Else
    Error 0,"input view type "+Typename(view)+ "error !"
   End If
  End Select
  If Me.m_ViewPath="VD_Print_TestRequisition"Then   
   Print|<Row>|
   Print|<Cell ss:Index="|+Cstr(Ubound(aColumns))+|" ss:StyleID="ViewElement"><Data ss:Type="String">Total：</Data></Cell>|
   Print|<Cell ss:Index="|+Cstr(Ubound(aColumns)+1)+|" ss:StyleID="ViewElement"><Data ss:Type="String">|+Cstr(total)+|</Data></Cell>|
   Print|</Row>|
  End If
  '---------------------------------------
  
  Print |  </Table>|
  Print | </Worksheet>|
  Print |</Workbook>|
  Msgbox "***********************************************"
  Exit Function
ERR_Handle:
  Msgbox |Script "CNotesDocumentCollection.PrintToWebByExcel()" error on line: |+Cstr(Erl)+| , error: |+Error
 End Function
End Class