notes数据导出到excel代码,Domino代码库,德仔网

代码语言
代码分类
【Domino】 notes数据导出到excel
作者:entry / 发布于2014/7/25/ 1140

	'Export to Excel v2.06:
	Option Public
	%REM
	================================================================================
	Export-Script
	================================================================================
	This script exports a UIView 'As-Is' from Notes 5 to Excel 2000
	It has been tested with Notes 5.03/5.05 into Excel97 & 2000

	--> every column (include headers) is a column in Excel
	 and every value displayed of a document is a row in Excel
	Every Value will be inserted as Text into Excel
	================================================================================
	Implementation
	================================================================================
	It is only a script without any Dialog-Boxes by exception --> Distribution and
	Implementation is very easy

	Simply copy this whole file into an Agent:
	Name: Export to Excel
	Run: Manually from Actions Menu
	act on: All documents in View
	Run: Lotus Script

	%ENDREM

	' Set Papersize: 10*14=16 / 11*17=17 / A3=8 / A4=9 / A4small=10 / A5=11 / B4=12 / B5=13
	Const psize = 9
	Const visualproc = True 'Display VisualProgress true = yes /false = no
	Const AppConst = "Excel.Application"
	Const AppConst2 = "Excel.Application.8"
	Const NPB_TWOLINE% = 1 '1 is for the big "in its window" progress bar and 32 is for the small blue line at the bottom of the screen

	' Procedures in nnotesws.dll (undocumented!!).

	Dim db As NotesDatabase
	Dim view As NotesView
	Dim doc As NotesDocument
	Dim nc, nl, nmore
	Dim selList(0 To 16) As String
	Dim vcol List As String
	Dim indoresp As Integer, inleaveString As Integer
	Dim excelAppObject As Variant
	Declare Function NEMProgressBegin Lib "nnotesws.dll" ( Byval wFlags As Integer ) As Long
	Declare Sub NEMProgressEnd Lib "nnotesws.dll" ( Byval hwnd As Long )
	Declare Sub NEMProgressSetBarPos Lib "nnotesws.dll" ( Byval hwnd As Long, Byval dwPos As Long)
	Declare Sub NEMProgressSetBarRange Lib "nnotesws.dll" ( Byval hwnd As Long, Byval dwMax As Long )
	Declare Sub NEMProgressSetText Lib "nnotesws.dll" ( Byval hwnd As Long, Byval pcszLine1 As String, _
	Byval pcszLine2 As String )
	Class ProgressBar
	' Objects
	Private hwnd As Long
	
	' Constructor.
	Sub New (BarRange As Long)
	 On Error Goto ErrorHandler
	
	' Create the progress bar.
	 Me.hwnd = NEMProgressBegin (NPB_TWOLINE)
	
	' Set the bar range.
	 Call NEMProgressSetBarRange (Me.hwnd, BarRange)

	 Exit Sub
	
	ErrorHandler:
	 Dim TheError As String
	 TheError = "Constructor: Error " + Str(Err) + ": " + Error$
	 Messagebox TheError, 0 + 48, "Progress Bar Error"
	End Sub
	
	' Destructor.
	Sub Delete
	' Destroy the progress bar.
	 Call NEMProgressEnd (Me.hwnd)
	End Sub
	
	Public Sub UpdatePosition (BarPos As Long)
	' Update the bar position.
	 Call NEMProgressSetBarPos (Me.hwnd, BarPos)
	End Sub
	
	Public Sub UpdateProgressText (BarMsg As String, UpdateMsg As String)
	' Update progress text.
	 Call NEMProgressSetText (Me.hwnd, BarMsg, UpdateMsg)
	End Sub
	End Class

	Sub Initialize
	On Error Goto ExitExcel
	'Main Code
	Dim session As New NotesSession
	Dim workspace As New NotesUIWorkspace
	Dim UIview As NotesUIView
	Dim collection As NotesDocumentCollection
	Dim coldoc As NotesDocument
	Dim BarMsg As String, UpdateMsg As String
	Dim countall As Long, countthis As Long, countallsel As Long, countthissel As Long
	Dim NChar As String
	
	Set UIview = workspace.CurrentView
	Set db = session.CurrentDatabase
	UIViewname = UIView.ViewName
	UIViewAlias = UIView.Viewalias
	Set view = db.GetView( UIViewName )
	
	Set collection = db.UnprocessedDocuments
	gowithselection = False
	goonall = True
	
	'Determine if it is a collection
	countallsel = collection.count
	If countallsel >=1 Then
	 gowithselection = workspace.Prompt(PROMPT_YESNO, "Selection found", "Export only selected documents?")
	 Set doc=collection.getfirstdocument
	 'Check if there is really a doc selected
	 If (doc Is Nothing) And (goonwithselection) Then
	 Msgbox "Invalid selection"
	 Exit Sub
	 End If
	 Set doc = Nothing
	 BarMsg = "Exporting selected documents ..."
	Else
	 goonall = workspace.Prompt(PROMPT_YESNO, "No Selection found", "Export all documents?" + Chr$(13) + "Info: If you want to export only selected documents," + Chr$(13) + "please select these documents before running this script.")
	 If goonall=False Then
	 Print "Exiting..."
	 Exit Sub
	 End If
	 Set collection = Nothing
	 BarMsg = "Exporting documents ..."
	End If
	
	doformat = Messagebox("Format the Excel-Sheet?", 36)
	If doFormat = 6 Then
	 'SET THE AUTOFORMAT
	 Call SetSelList()
	 SelForm = workspace.Prompt(PROMPT_OKCANCELLIST, "AutoFormat-Form","Select the Autoformat-Form", "Simple" , SelList)
	 TitleBar = Cint(Inputbox ( "How many degrees shall the Title-Line be turned", "Title-Turn", "0"))
	 If Titlebar > 90 Then
	 TitleBar = 90
	 Elseif TitleBar < -90 Then
	 TitleBar = -90
	 End If
	End If
	
	SelAutoForm = getAutoForm( selForm )
	
	indoresp = Messagebox("Exporting also possible Response-Documents?", 36)
	inleaveString = Messagebox("Export all as text (Numbers converted to Text)?", 36)
	
	'Launch Excel and open it in the UI
	On Error Goto 0
	Set excelAppObject = CreateObject( AppConst )
	'Try other AppConst
	If excelAppObject Is Nothing Then
	 Set excelAppObject = CreateObject( AppConst2 )
	 If excelAppObject Is Nothing Then
	 Msgbox "Could not create an Excel Object"
	 Exit Sub
	 End If
	End If
	On Error Goto ExitExcel
	excelAppObject.Visible = False
	Call excelAppObject.Workbooks.Add
	Set excelWorksheetObject = excelAppObject.ActiveSheet
	
	'Add the table labels
	nc=64
	nmore=0
	Forall c In view.Columns
	 'do not export hidden columns or those with fixed vals (not displayed as doc.columnvalues!!!!)
	 If Not c.ishidden And Not c.IsIcon And Not (c.IsFormula And Not Instr(1, c.Formula, "@") And Not Instr(1, c.Formula, "+")) Then
	 nchar = countcol(nChar)
	 excelWorksheetObject.Range( nchar + "1").Value = Trim(c.Title)
	 End If
	End Forall
	
	m_let = nchar
	nl=1
	
	'Export Documents
	Set doc = view.GetFirstDocument
	If gowithselection Then countall = countallsel Else countall = view.AllEntries.Count
	countthis = 0
	countthissel = 0
	exitnow = False
	If visualProc Then Dim RefreshProgress As New ProgressBar (countall) 'display the ProcessWindow/Bar
	
	While Not ( doc Is Nothing Or exitnow)
	 countthis = countthis + 1
	 If gowithselection Then
	 Set coldoc = Nothing
	 Set coldoc = collection.GetDocument(doc)
	 If Not coldoc Is Nothing Then 'Exports only if doc is part of collection
	 If (doc.isResponse And indoresp=6) Or Not doc.isResponse Then
	 Call ExportDoc(excelWorksheetObject)
	 countthissel = countthissel + 1
	 End If
	 End If
	 If visualproc Then
	 UpdateMsg = "Exporting document " + Cstr(countthissel) + " of " + Cstr(countall) + Chr$(13) + "Processing Doc in View: " + Cstr(countthis)
	 Call RefreshProgress.UpdatePosition (countthissel)
	 Else
	 Print "Exporting document " + Cstr(countthissel) + " of " + Cstr(countall) + " / " + "Processing Doc in View: " + Cstr(countthis)
	 End If
	 'Exit routine if all selected docs are exported
	 If countall = countthissel Then exitnow = True
	 Else
	 If (doc.isResponse And indoresp=6) Or Not doc.isResponse Then
	 Call ExportDoc(excelWorksheetObject)
	 UpdateMsg = "Exporting document " + Cstr(countthis) + " of " + Cstr(countall)
	 If visualproc Then
	 Call RefreshProgress.UpdatePosition (countthis)
	 Else
	 Print UpdateMsg
	 End If
	 End If
	 End If
	 If visualproc Then Call RefreshProgress.UpdateProgressText (BarMsg, UpdateMsg)
	 Set doc = view.GetNextDocument(doc)
	Wend
	
	
	'formating the Worksheet
	If doformat = 6 Then
	 BarMsg = "One moment please..."
	 UpdateMsg = "Formating the document..."
	 If visualproc Then Call RefreshProgress.UpdateProgressText (BarMsg, UpdateMsg) Else Print Updatemsg
	 If titlebar=0 Then
	 excelWorksheetObject.Range("A2:" + m_let + Cstr(nl) ).Select
	 Else
	 excelWorksheetObject.Range("A1:" + m_let + Cstr(nl) ).Select
	 End If
	 excelAppObject.Selection.Columns.AutoFit
	 excelWorksheetObject.Range("A1:" + m_let + Cstr(nl)).Select
	 With excelAppObject.Selection
	 .AutoFormat SelAutoForm, False, True, False, True, True, False
	 .VerticalAlignment = -4160
	 End With
	
	 excelWorksheetObject.Rows("1:1").Select
	 With excelAppObject.Selection
	 .VerticalAlignment = -4107
	 .HorizontalAlignment = -4108
	 .WrapText = True
	 .Orientation = Cint(titlebar)
	 .ShrinkToFit = False
	 .MergeCells = False
	' .RowHeight = 215
	 End With
	
	 excelWorksheetObject.Range("A:" + m_let).Select
	 With excelAppObject.Selection.Font
	 .Name = "Arial"
	 .Size = 10
	 End With
	
	 excelAppObject.Selection.Columns.Autofit
	 excelWorksheetObject.Range("A1").Select
	
	 With excelAppObject.Windows(1)
	 .SplitRow=1
	 .FreezePanes=True
	 End With
	
	 With excelWorksheetObject.PageSetup
	 .Orientation = 2
	 .LeftHeader = "&""Arial,Bold""&18"+db.Title+" - "+ UIViewAlias
	 .CenterHeader = ""
	 .RightHeader = "Datum: &D"
	 .LeftFooter = ""
	 .CenterFooter = ""
	 .RightFooter = "Seite &P"
	 .PrintArea = ("A1:"+ m_let + Cstr(nl))
	 .PaperSize = 9
	 .CenterHorizontally = True
	 .FitToPagesTall =False
	 .zoom = False
	 .FitToPagesWide=1
	 .PrintTitleRows=excelWorksheetObject.Rows("1:1").Address
	 End With
	End If
	excelAppObject.Visible = True
	Exit Sub
	
	ExitExcel:
	Print "Error in Line " + Cstr(Erl) + " : " + Cstr(Error)
	excelAppObject.DisplayAlerts = False
	excelAppObject.Quit
	Exit Sub
	End Sub
	Function countcol( nChar As String)
	nc=nc+1
	If nc=91 Then
	 nmore = nmore+1 'PreChar = Axx (AC23)
	 nc=65 'reset to A
	End If
	If nmore > 0 Then
	 nchar=Cstr(Chr(nmore+64))+Cstr(Chr(nc))
	Else
	 nchar = Cstr(Chr(nc))
	End If
	countcol = nchar
	End Function

	Function getAutoForm( selForm) As Integer
	Select Case SelForm
	Case "Simple"
	 SelAutoForm = -4154
	Case "Classic1"
	 SelAutoForm =1
	Case "Classic2"
	 SelAutoForm =2
	Case "Classic3"
	 SelAutoForm =3
	Case "Accounting1"
	 SelAutoForm =4
	Case "Accounting2"
	 SelAutoForm =5
	Case "Accounting3"
	 SelAutoForm =6
	Case "Color1"
	 SelAutoForm =7
	Case "Color2"
	 SelAutoForm =8
	Case "Color3"
	 SelAutoForm =9
	Case "List1"
	 SelAutoForm =10
	Case "List2"
	 SelAutoForm =11
	Case "List3"
	 SelAutoForm =12
	Case "D3Effects1"
	 SelAutoForm =13
	Case "D3Effects2"
	 SelAutoForm =14
	Case "Accounting4"
	 SelAutoForm =17
	Case Else
	 SelAutoForm =-4142
	End Select
	GetAutoForm = SelAutoForm
	End Function

	Sub SetSelList()
	SelList(0) = "Simple"
	SelList(1) = "Classic1"
	SelList(2) = "Classic2"
	SelList(3) = "Classic3"
	SelList(4) = "Accounting1"
	SelList(5) = "Accounting2"
	SelList(6) = "Accounting3"
	SelList(7) = "Accounting4"
	SelList(8) = "Color1"
	SelList(9) = "Color2"
	SelList(10) = "Color3"
	SelList(11) = "List1"
	SelList(12) = "List2"
	SelList(13) = "List3"
	SelList(14) = "D3Effects1"
	SelList(15) = "D3Effects2"
	SelList(16) = "None"
	End Sub

	Sub ExportDoc(excelWorksheetObject)
	On Error Goto ErrorEntry
	Dim nChar As String, MyString As String
	Dim MyVal As Variant, MyRepl(1) As Variant
	Dim inisString As Integer
	nl= nl+1
	nc=64
	nmore=0
	ocount = 0
	MyRepl(0) = Chr$(13)+Chr$(10)
	MyRepl(1) = Chr$(13)
	inisString = True
	Forall c In view.Columns
	 'do not export hidden columns!
	 If Not c.ishidden And Not c.IsIcon And Not (c.IsFormula And Not Instr(1, c.Formula, "@") And Not Instr(1, c.Formula, "+")) Then
	 nchar = countcol(nChar)
	 MyVal = doc.ColumnValues(ocount)
	 If Isarray(MyVal) Then
	 MyString = ListToText(MyVal)
	 Else
	 If Isnumeric(MyVal) Then inisString = False
	 MyString = MyVal
	 End If
	 MyString = ReplaceSubString( MyString , MyRepl , Chr$(10) )
	 With excelWorksheetObject.Range(nchar + Cstr(nl))
	 If Not inisString And inleaveString=7 Then
	 .NumberFormat = "0"
	 Else
	 .NumberFormat = "@"
	 End If
	 .Value = MyString
	 End With
	 End If
	 ocount=ocount+1
	End Forall
	Exit Sub
	
	ErrorEntry:
	With excelWorksheetObject.Range(nchar + Cstr(nl))
	 .NumberFormat = "@"
	 .Value = "ERROR: WRONG VALUE"
	End With
	Resume Next
	End Sub
	Function ListtoText ( MyVal As Variant )
	Dim NewVal As String
	NewVal = ""
	
	Forall x In MyVal
	 If NewVal = "" Then
	 NewVal = x
	 Else
	 NewVal = NewVal + Chr$(10) + x
	 End If
	End Forall
	
	If NewVal = "" Then NewVal = MyVal Else ListtoText = NewVal
	End Function
	Function ReplaceSubString(stOriginal As String , vaAll As Variant , stTo As String) As String
	Dim stString As String
	Dim inFound As Integer,inStart As Integer,inDone As Integer
	stString=stOriginal
	Forall stWhat In vaAll
	 If (stWhat<>stTo) Then
	 inFound=Instr(stString,stWhat)
	 inDone=(inFound=0)
	 While Not inDone
	 stString=Left(stString,inFound-1)+stTo+Mid(stString,inFound+Len(stWhat))
	 inStart=inFound+1
	 inFound=Instr(inStart,stString,stWhat)
	 If inFound=0 Then inFound=Instr(stString,stWhat)
	 inDone=(inFound=0)
	 Wend
	 End If
	End Forall
	ReplaceSubString=stString
	End Function
评论列表
本站所提供的代码，版权归原作者所有，若有侵犯作者版权，请与我们联系，我们将立即删除或修改。谢谢!
本站所有代码发布及提供者。
试试其它关键字
同语言下
可能有用的
entry贡献的其它代码(10)