Export To Excel Current View Using Lotus Script with Visual Bar
THIS AGENT IS USED
TO EXPORT THE CURRENT VIEW DATA TO EXCEL-
Procedure :
Procedure :
1. Create New Lotus Script Agent with Menu Selection property
2. Copy Below Complete Lotus Script Code and Paste it in Initialize
3. Save this agent with proper name
4. Close the agent and goto any view in your database
5. Find your agent name in "Action" Menu and run it.
6. Excel File will be ready to desktop.
7. Done.
EXPORT TO EXCEL ANY VIEW :
Const visualproc = True 'Display Visualvisual
progress bar true = yes /false = no
Const AppConst = "Excel.Application"
Const AppConst2 = "Excel.Application.8"
Const NPB_TWOLINE% = 1
' 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 20) As String
Dim vcol List As String
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 visual
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, "visual progress bar
Error"
End Sub
' Use Destructor.
Sub Delete
' Destroy the visual
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 starts here
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
)
'Launch The Excel and
open it in the Quickly on user's machine
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
excelAppObject.Visible = False
Call excelAppObject.Workbooks.Add
Set excelWorksheetObject = excelAppObject.ActiveSheet
'Addition of the table
labels
nc=64
nmore=0
'do
not export hidden columns or those with fixed valus
Forall c In view.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)
excelWorksheetObject.Range( nchar
+ "1").Value = c.Title
End If
End Forall
m_let = nchar
nl=1
'Export
the Documents
Set doc = view.GetFirstDocument
If gowithselection Then countall = countallsel Else countall = view.AllEntries.Count
countthis = 0
countthissel = 0
If visualProc Then Dim RefreshProgress As New ProgressBar (countall) 'Show the Visual ProcessWindow/Bar
exitnow=False
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 when doc
is part of this collection
Call ExportDoc(excelWorksheetObject)
countthissel = countthissel
+ 1
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
Else
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
If visualproc Then Call RefreshProgress.UpdateProgressText (BarMsg, UpdateMsg)
If countall = countthissel Then exitnow = True 'Exit
routine
Set doc = view.GetNextDocument(doc)
Wend
'formatting
the Excel Worksheet
If doformat = 6 Then
BarMsg = "One moment please..."
UpdateMsg = "Formating the document..."
If visualproc Then Call RefreshProgress.UpdateProgressText (BarMsg, UpdateMsg)
Else
Print Updatemsg
excelWorksheetObject.Range("A2:" + m_let
+ Cstr(nl) ).Select
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
on 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
nc=65
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 "Format1"
SelAutoForm =15
Case "Format2"
SelAutoForm =16
Case "Accounting4"
SelAutoForm =17
Case "Format3"
SelAutoForm =19
Case "Format4"
SelAutoForm =20
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) = "Format1"
SelList(17) = "Format2"
SelList(18) = "Format3"
SelList(19) = "Format4"
SelList(20) = "None"
End Sub
Sub ExportDoc(excelWorksheetObject)
On Error Goto IfAnyErrorEntry
Dim nChar As String
nl= nl+1
nc=64
nmore=0
ocount = 0
Forall c In view.Columns
If Not c.ishidden And Not c.isicon Then 'Hide hidden columns
from export , avoid hidden columns to export!
nchar = countcol(nChar)
With excelWorksheetObject.Range(nchar + Cstr(nl))
.NumberFormat = "@"
.Value = doc.ColumnValues(ocount)
End With
End If
ocount=ocount+1
End Forall
Exit Sub
IfAnyErrorEntry:
With excelWorksheetObject.Range(nchar + Cstr(nl))
.NumberFormat = "@"
.Value = "ERROR: WRONG VALUE"
End With
Resume Next
End Sub
Subscribe to:
Post Comments
(
Atom
)
No comments :
Post a comment