Now Test : Personal view export (Local Database) => result OK
: Personal view export (Server) => result NG
Error message => Error 91 occurred whilst setting objects,execution aborted
Code see below :
Sub Click(Source As Button)
Dim workspace As NotesUIWorkspace
Dim uiview As NotesUIView
Dim view As NotesView
Dim column As NotesViewColumn
Dim viewentries As NotesViewEntryCollection
Dim viewnav As NotesViewNavigator
Dim viewentry As NotesViewEntry
Dim session As NotesSession
Dim db As NotesDatabase
Dim dc As NotesDocumentCollection
Dim doc As NotesDocument
Dim entryvalues As Variant, handle As Variant, wbook As Variant, wsheet As Variant, viewcolumns As Variant
Dim currententry As String, currentprocess As String, viewname As String, filename As String
Dim columnheadings As String, columnvalues As String, columntitle As String
Dim counter As Integer, x As Integer, y As Integer ,slashpos As Integer, spacepos As Integer
Dim hyphenpos As Integer, filenum As Integer, mycounter As Integer, commapos As Integer
On Error Goto processerror
'set objects
currentprocess = "setting objects"
Set workspace = New NotesUIWorkspace
Set uiview = workspace.CurrentView
Set view = uiview.View
Set viewnav = view.CreateViewNav()
Set session = New NotesSession
Set db = session.CurrentDatabase
'get the current view's name and replace all backslashes with a hyphen
currentprocess = "getting the view name and replacing backslashes with hyphens"
viewname = view.Name
slashpos = Instr(viewname, "\")
If slashpos > 0 Then
Do While slashpos > 0
Mid(viewname, slashpos) = "-"
slashpos = Instr(viewname, "\")
Loop
End If
'now replace all forward slashes with a hyphen
currentprocess = "replacing all forward slashes in the view name with hyphens"
slashpos = Instr(viewname, "/")
If slashpos > 0 Then
Do While slashpos > 0
Mid(viewname, slashpos) = "-"
slashpos = Instr(viewname, "/")
Loop
End If
'reduce view name to a maximum of 31 characters but keep whole words only (cut at first space or hyphen encountered)
currentprocess = "truncating the view name to 31 characters (whole words only)"
If Len(viewname) > 31 Then
viewname = Right(viewname, 31)
spacepos = Instr(viewname, " ")
hyphenpos = Instr(viewname, "-")
If spacepos < hyphenpos Then
viewname = Right(viewname, Len(viewname) - spacepos)
Else
viewname = Right(viewname, Len(viewname) - hyphenpos)
End If
End If
'collect the selected documents
currentprocess = "collecting the selected documents"
Set dc = db.UnprocessedDocuments
'check that documents have been selected at all
currentprocess = "checking that documents were selected at all"
If dc.count = 0 Then
Msgbox "You must select the documents you wish to export. Press CTRL+A to select all documents", 0 + 48, "Error !"
Exit Sub
End If
'if documents have been selected create text file
currentprocess = "creating a text file for output"
filenum = Freefile()
filename = "C:\マイ ドキュメント\Export\" & viewname & ".csv"
Open filename For Output As filenum
'create header row in text file
currentprocess = "recreating the column names as header in the text file"
viewcolumns = view.Columns
Set column = viewcolumns(Lbound(viewcolumns))
columnheadings = column.Title
For x = (Lbound(viewcolumns) + 1) To Ubound(viewcolumns)
Set column = viewcolumns(x)
columnheadings = columnheadings & "," & column.Title
Next
Print #filenum, columnheadings
'access each selected document in turn
currentprocess = "starting to process each document in turn"
Set doc = dc.GetFirstDocument
mycounter = 0
counter = 1
Do
counter = counter + 1
currentprocess = "accessing the view entry corresponding to the current document"
'get the view entry corresponding to the current selected document
Set viewentry = viewnav.GetEntry(doc)
If viewentry Is Nothing Then
Print #filenum, "Document ID " & doc.UniversalID & _
" appears under multiple categories. Unable to export, please transfer the data manually."
Else
Redim entryvalues(0)
entryvalues = viewentry.ColumnValues
If Isarray(entryvalues) Then
currentprocess = "creating each column value in its respective cell"
'create each column value in its respective cell
columnvalues = entryvalues(Lbound(entryvalues))
For y = (Lbound(entryvalues)+1) To Ubound(entryvalues)
currentprocess = "replacing any comma in the entry with a semicolon"
'seek and replace commas in entry
currententry = entryvalues(y)
commapos = Instr(currententry, ",")
If commapos > 0 Then
Do While commapos > 0
Mid(currententry, commapos) = ";"
commapos = Instr(currententry, ",")
Loop
entryvalues(y) = currententry
End If
columnvalues = columnvalues & "," & entryvalues(y)
Next
currentprocess = "writing the current view entry to the file"
Print #filenum, columnvalues
End If
End If
'reporting how many documents of how many in total have been exported so far
currentprocess = "reporting progress in status bar"
mycounter = mycounter + 1
Print "Exporting " & Cstr(mycounter) & "/" & dc.Count & " documents."
currentprocess = "accessing the next selected document in the list"
'get the next selected document
Set doc = dc.GetNextDocument(doc)
Loop Until (doc Is Nothing)
currentprocess = "closing the file"
Close filenum
currentprocess = "terminating the export job"
Exit Sub
processerror:
Msgbox "Error " & Err & " occurred whilst " & currentprocess & ", execution aborted.", 0 + 48, "Error !"
Exit Sub
End Sub
รบกวนด้วยคะ |