导入Excel到Notes的通用ScriptLibrary

看到好多人要求找怎样导入Excel, 做了一个导入Excel到Notes的通用ScriptLibrary, 很方便哦,

Excel文件的要求:Excel的第一行一定要和Notes Form中FieldName一样.

用法实例：

Call ImportExcel("")        ' 会给出当前数据的所有Form给用户选择一个

或者

Call ImportExcel(Formname)

创建一个Script Library:

Function ImportExcel(FormName As String)
 Dim session As New NotesSession
 Dim uiws As New NotesUIWorkspace
 Dim form As NotesForm
 Dim db As NotesDatabase
 Dim doc As NotesDocument
 Dim item As NotesItem
 Dim row As Integer
 Dim xlFilename As String
 Dim xlsApp As Variant
 Dim xlsWorkBook As Variant
 Dim xlsSheet As Variant
 Dim rows As Long
 Dim cols As Integer
 Dim x As Integer
 Dim itemName As String
 Dim flag As Integer
 Dim formAlias As String
 Dim sortEval As String
 Dim sortedList As Variant
 Dim indexLo As Long
 Dim indexHi As Long
 Dim t As Integer
 Dim askme As Integer
 
 
 On Error Goto ErrorHandler
' ====== 1. Set form name, not select from form list ======
 
 Set db = session.CurrentDatabase
 
 fn= uiws.Prompt(1, "Reminder- Excel Worksheet Setup", "Make sure that the first row of your worksheet contains the EXACT Notes document field names from your form.")
 
'Get Excel file name
 fn =uiws.OpenFileDialog(False, "Select the Excel File to Import", "Excel files | *.xls", "c:\My Documents")
 xlFilename = Cstr(fn(0)) ' This is the name of the Excel file that will be imported
 
 If formname="" Then
  'Get list of form names
  x=0
  
  Print "Preparing List of Database Forms ..."
  
  Forall f In db.Forms
   Redim Preserve formlist(x)
   formlist(x)=f.name
   x=x+1
   Print "Preparing List of Database Forms ..."& Cstr(x)
  End Forall
  
'Sort the form names for the dialog box
  indexLo= Lbound(formlist)
  indexHi= Ubound(formlist)
  Call QuickSort(formlist , indexLo, indexHi)
  
'Choose the form to use for import
  formname = uiws.Prompt(4, "Choose Import Form", "Please select which form is to be used for this input.", formlist(0), formlist)
  If formname= "" Then End
 End If
 
'Get the form object so that we can check field names
 Set form= db.GetForm(formname)
 
'If the form has an alias, use it to select the form
 If Not Isempty(form.Aliases) Then
  Forall a In form.Aliases
   formname=a
  End Forall 'a In form.Aliases
 End If 'Not Isempty(form.Aliases)
 
'Next we connect to Excel and open the file. Then start pulling over the records.
 Print "Connecting to Excel..."
 
' Create the excel object
 Set xlsApp = CreateObject("Excel.Application")
 
'Open the file
 Print "Opening the file : " & xlfilename
 xlsApp.Workbooks.Open xlfilename
 Set xlsWorkBook = xlsApp.ActiveWorkbook
 Set xlsSheet = xlsWorkBook.ActiveSheet
 xlsApp.Visible = False ' Do not show Excel to user
 xlsSheet.Cells.SpecialCells(11).Activate
 rows = xlsApp.ActiveWindow.ActiveCell.Row ' Number of rows to process
 cols = xlsApp.ActiveWindow.ActiveCell.Column ' Number of columns to process
 
'Make sure we start at row 0
 row = 0
 Print "Starting import from Excel file..."
 
 Do While True
  row = row + 1
  
'Check to make sure we did not run out of rows
  If row= rows+1 Then Goto Done
  
'field definitions for notes come from first row (row, column)
  If row=1 Then
   Redim misFD(0)
   t=0
   For i=1 To cols
    Redim Preserve fd(i)
'the replace function used here removes spaces from the field definitions in the first row
    fd(i)= Replace(xlsSheet.Cells( row, i ).Value, " ", "")
    
    flag=0
    
    Forall f In form.Fields
     If Lcase(fd(i)) = Lcase(f) Then flag=1
    End Forall 'f In form.Fields
    
    If flag=1 Then
     Goto Skip
    End If ' flag=1
    
    If Not flag=1 Then
     misFD(t)=fd(i)
     t=t+1
     Redim Preserve misFD(t)
    End If 'flag=1
    
Skip:
   Next 'For i=1 To cols
   
   If t>0 Then Redim Preserve misFD(t-1)
   If misFD(0)<>"" Then
    msg="Below Field(s) does not appear in the form you have chosen, Are you sure continue?"+Chr(10)+Chr(10)
    For i=0 To Ubound(misFD)
     msg=msg+misFD(i)+Chr(10)
    Next
    askme=uiws.Prompt(2,"Please Notice",msg)
    If askme<>1 Then
     Goto ErrorHandler
    End If
   End If
   
  End If 'row=1
  
  
  
'Import each row into a new document
  If Not row = 1 Then
   
'Create a new doc
   Set doc = db.CreateDocument
   doc.Form = FormName
   doc.HidDeleted=0
   For i= 1 To cols
    Set item = doc.ReplaceItemValue( fd(i), xlsSheet.Cells( row, i ).Value )
   Next ' i= 1 To cols
   
'Save the new doc
   Call doc.Save( True, True )
   
  End If 'Not row = 1 Then
  
  Print "Processing document number "& Cstr(row) & " of " & Cstr(rows)
  
  Loop 'Do while true
  
Done:
  
  Print "Disconnecting from Excel..."
'Close the Excel file without saving (we made no changes)
  xlsWorkbook.Close False
'Close Excel
  xlsApp.Quit
'Free the memory that we'd used
  Set xlsApp = Nothing
  
'Clear the status line
  Print " "
  
  
ErrorHandler:
  If Err = 184 Then
   Msgbox "No file chosen. Exiting Import."
   Print "No file chosen. Exiting Import."
   Resume ErrorOut
  End If ' err=184
  
  If Err = 6 Then
   Messagebox "Make sure that you do not have more than 65,536 rows of data to import." ,MB_OK+MB_ICONINFORMATION,"Error! "
   Print "Too many rows in Excel document. Exiting Import. Disconnecting from Excel..."
'Close the Excel file without saving (we made no changes)
   xlsWorkbook.Close False
'Close Excel
   xlsApp.Quit
'Free the memory that we'd used
   Set xlsApp = Nothing
   Resume ErrorOut
  End If ' err=184
  
  If (Err) And (Not Err = 184) And (Not Err = 6) Then
   
   Msgbox "Lotus Notes Error # " & Err &". Please contact your Notes administrator for help. Exiting Import."
   Print "Error # "& Err
   
   If Not xlsWorkbook Is Nothing Then
    xlsWorkbook.Close False
   End If ' Not xlsWorkbook Is Nothing
   
   If Not xlsApp Is Nothing Then
    xlsApp.Quit False
   End If 'Not xlsApp Is Nothing
   
   Resume ErrorOut
   
  End If '(Err) And (Not Err = 184) And (Not Err = 6)
  
ErrorOut:
End Function

Function QuickSort( anArray As Variant, indexLo As Long, indexHi As Long) As Variant
 
 Dim lo As Long
 Dim hi As Long
 Dim midValue As String
 Dim tmpValue As String
 
 lo = indexLo
 hi = indexHi
 If ( indexHi > indexLo) Then
'get the middle element
  midValue = anArray( (indexLo + indexHi) /2)
  While ( lo <= hi )
'find first element greater than middle
   While (lo < indexHi) And (anArray(lo) < midValue )
    lo = lo+1
   Wend
'find first element smaller than middle
   While ( hi > indexLo ) And ( anArray(hi) > midValue )
    hi = hi - 1
   Wend
'if the indexes have not crossed, swap
   If ( lo <= hi ) Then
    tmpValue = anArray(lo)
    anArray(lo) = anArray(hi)
    anArray(hi) = tmpValue
    lo = lo+1
    hi = hi -1
   End If
  Wend
' If the right index has not reached the left side of array, sort it again
  If( indexLo < hi ) Then
   Call QuickSort( anArray, indexLo, hi )
  End If
'If the left index has not reached the right side of array, sort it again
  If( lo < indexHi ) Then
   Call QuickSort( anArray, lo, indexHi )
  End If
 End If
 
 QuickSort = anArray
 
End Function

Trackback: http://tb.blog.csdn.net/TrackBack.aspx?PostId=1764020