Notes 视图,表单,IE页面与EXCEL相互转换- -

                                      

 

（转贴），视图转换为EXCEL的通用代码，在视图按钮、导航器中均测试无误。

Sub Click(Source As Button)
 Dim Session As New NotesSession ,db As NotesDatabase
 Dim sourceview As NotesView,sourcedoc As NotesDocument
 Dim dataview As NotesView, dc As NotesDocumentCollection
 Dim datadoc As NotesDocument, maxcols As Integer
 Dim WS As New Notesuiworkspace
 Dim ViewString As String, Scope As String, GetField As Variant
 Dim C As NotesViewColumn, FieldName As String, K As Integer,N As Integer
 Dim xlApp As Variant, xlsheet As Variant, rows As Integer, cols As Integer
 Dim nitem As NotesItem , entry As NotesViewEntry, vwNav As NotesViewNavigator
 Dim ShowView() As Variant, i As Integer, VList As Variant, ColVals As Variant
 
 Set db = session.CurrentDatabase 
 
 Vlist= db.views
 K=Ubound(Vlist) 
 Redim Preserve ShowView(K)
 N=-1
 For i = 0 To K
  If Len(Vlist(i).Name) >0 Then
   FieldName=Trim(Vlist(i).Name)
   If Mid(Fieldname,1,1) <>"(" Then

N=N+1
    ShowView(N) = FieldName
   End If
  End If
 Next i
 
 
 Redim Preserve ShowView(N)
'now sort the list - by default views are listing in the order that they were created
 For i=0 To N
  For K=i To N
   If ShowView(i) > ShowView(k) Then
    FieldName=ShowView(i)
    ShowView(i) = ShowView(k)
    ShowView(k)=FieldName
   End If
  Next k
 Next i
 
 viewstring= ws.Prompt(PROMPT_OKCANCELLIST,"***数据库视图列表","请选择您需要生成Excel格式的视图：","",ShowView )
 
 If Len(viewstring)=0 Then Exit Sub
'ViewString ="Dan's View"
 
 Set dataview = db.getview(ViewString) 'get selected view
 
 Set vwnav= dataview.createViewnav()
 
 rows = 1
 cols = 1
 maxcols=dataview.ColumnCount 'how many columns?
 
 Set xlApp = CreateObject("Excel.Application") 'start Excel with OLE Automation
 xlApp.StatusBar = "正在创建工作表，请稍候..."
 xlApp.Visible = True
 xlApp.Workbooks.Add
 xlApp.ReferenceStyle = 2
 Set xlsheet = xlApp.Workbooks(1).Worksheets(1) 'select first worksheet
 
'worksheet title
 xlsheet.Cells(rows,cols).Value ="视图名称: " + ViewString + ", Notes数据库名称: " + db.title +", 创建时间: " + Format(Now,"mm/dd/yyyy HH:MM")
 
 xlApp.StatusBar = "正在创建列标题，请稍候..."
 
 rows=2 'column headings starts in row 2
 For K=1 To maxcols
  Set c=dataview.columns(K-1)
  xlsheet.Cells(rows,cols).Value = c.title
  cols = cols + 1
 Next K
 
 Set entry=vwnav.GetFirstDocument
 rows=3 'data starts in third row
 Do While Not (entry Is Nothing)
  
  For cols=1 To maxcols
   colvals=entry.ColumnValues(cols-1) 'subscript =0
   scope=Typename(colvals)
   Select Case scope
   Case "STRING"
    xlsheet.Cells(rows,cols).Value ="'" + colvals
   Case Else
    xlsheet.Cells(rows,cols).Value = colvals
   End Select
  Next cols
  xlApp.StatusBar = "正在引入《***数据库》视图信息 - 文档 " & rows-1 '& " of " & dc.count & "."
  rows=rows+1
  Set entry = vwnav.getnextdocument(entry)
 Loop
 
 xlApp.Rows("1:1").Select
 xlApp.Selection.Font.Bold = True
 xlApp.Selection.Font.Underline = True
 xlApp.Range(xlsheet.Cells(2,1), xlsheet.Cells(rows,maxcols)).Select
 xlApp.Selection.Font.Name = "宋体"
 xlApp.Selection.Font.Size = 10
 xlApp.Selection.Columns.AutoFit
 
 xlApp.ReferenceStyle = 1
 xlApp.Range("A1").Select
 xlApp.StatusBar = "已完成从《***数据库》视图信息到Excel格式的转换！" & "共计" & maxcols & "列，" & (rows-3) & "行。"
dataview.clear
 
 Set xlapp=Nothing 'stop OLE
 Set db=Nothing
 
End Sub

 

[代理]-将Excel导入Notes表单的示例

使用方法：程序执行以后，先选择目录F:/CD2/下的Excel文件，然后打开循环寻找多个Sheet的数据，按照设定的规则将Excel的列和Form的域进行一一对应。 Sub Click(Source As Button)  Dim session As New NotesSession  Dim db As NotesDatabase  Dim Doc As NotesDocument  Dim TempDate As New NotesDateTime ("")  Dim DocCounter As Integer  Dim answer As Integer  Set db=session.CurrentDatabase   ExcelPath:  ExcelPath=Inputbox$("Excel File Directory","Excel Import","F:/cd2/")  If ExcelPath = "" Then   BoxType& = MB_OKCANCEL+MB_ICONSTOP   answer = Messagebox ("Please enter the Excel File Directory Path",BoxType&,"Enter Excel File Directory")   If answer = 2 Then    Goto finish   Else    Goto ExcelPath   End If  End If  If Right(ExcelPath,1)<>"/" Then ExcelPath=ExcelPath+"/"   ExcelFiles:  ExcelFiles=Inputbox$("Enter Excel Filename (or wildcard for multiple files)","Excel Import","*.xls")  If ExcelFiles = "" Then   BoxType& = MB_OKCANCEL+MB_ICONSTOP   answer = Messagebox ("Please enter the Excel Filename",BoxType&,"Enter Excel Filename")   If answer = 2 Then    Goto finish   Else    Goto ExcelFiles   End If  End If  ExcelFile=Dir$(ExcelPath+ExcelFiles)  If ExcelFile = "" Then   Goto NoFile  End If    While ExcelFile<>""   Set xls=GetObject(ExcelPath+ExcelFile,"")         Forall sheet In xls.Worksheets    SheetName$=Trim(sheet.name) 'CellValueB5$=Trim(sheet.range("B5").value)    Print "Started Cycle"    DocCounter = 1        For A = 2 To 20000     CellValueA$=sheet.range("A" & Ltrim(Str(A))).value     CellValueB$=sheet.range("B" & Ltrim(Str(A))).value     CellValueC$=sheet.range("C" & Ltrim(Str(A))).value     CellValueD$=sheet.range("D" & Ltrim(Str(A))).value     CellValueE$=sheet.range("E" & Ltrim(Str(A))).value     CellValueF$=sheet.range("F" & Ltrim(Str(A))).value          If CellValueA$ = "" And CellValueB$ = "" And CellValueC$ = "" And CellValueD$ = "" And CellValueE$ = "" And CellValueF$ = "" Then      Exit For     End If          Set Doc= New NotesDocument(db)     Doc.Form="iptable" 'Doc.Sheet=SheetName$          Doc.number=CellValueA$     Doc.name=CellValueB$     Doc.tel=CellValueC$     Doc.data=CellValueD$     Doc.telephone=CellValueE$     Doc.ipaddr=CellValueF$     Doc.Information="数据由Excel倒入而来."          DocCounter = DocCounter+1     Print "Importing Record # " & Str(DocCounter)     Call Doc.Save (True,True) 'Delete Doc         Next       End Forall   ExcelFile=Dir$  Wend  Goto Finish   NoFile:  BoxType& = MB_OKCANCEL+MB_ICONINFORMATION  answer = Msgbox ("There is no Excel file with ("& ExcelFiles &") name. Please check the Filename",BoxType&,"Excel File Information")  If answer = 2 Then   Goto finish  Else   Goto ExcelFiles  End If   Finish: End Sub 表单可以自己设计，比如做成Excel样式，更接近用户的习惯。