Option Public
Sub Initialize
On Error Goto err_handle
Dim s As New NotesSession
Dim db As NotesDatabase
Dim thisView As NotesView, AttachView As NotesView
Dim thisDoc As NotesDocument
Dim ExcelPath As String, ExcelFileName As String, MSAction As String, path As String
Dim oExcel As Variant, oWorkbook As Variant
Dim prog As Integer
Dim CategoryField$
Set db = s.CurrentDatabase
Set oExcel = Nothing
Set thisView = db.GetView ( "People")
DefaultFileName$="c:\temp\person"+".xls"
Call thisView.Refresh
If thisView Is Nothing Then Error 10002
Set thisDoc = thisView.GetFirstDocument
If thisDoc Is Nothing Then Error 10003
Set oExcel = CreateObject ( "Excel.Application" )
ExcelPath = DefaultPath$
path = oExcel.Path
oExcel.Quit
Set oExcel = Nothing
'___ Process export to oExcel
Call ExportToExcel ( ExcelPath, DefaultFileName$, thisView, "Экспорт контактов в Excel" )
If Instr ( ExcelFileName, " " ) > 0 Then
DefaultFileName$ = {"} & DefaultFileName$ & {"}
End If
prog = Shell ( path & "\excel.exe " &DefaultFileName$, 3 )
exit_sub:
Print ""
If Not oExcel Is Nothing Then
oExcel.Quit
Set oExcel = Nothing
End If
Exit Sub
err_handle:
Select Case Err
Case 75
Dim oExcelErr As Variant, MSBookErr As Variant
Set oExcelErr = GetObject ( ExcelFileName )
Set MSBookErr = oExcelErr.Application.Workbooks.Item ( DefaultFileName$ )
MSBookErr.Activate
MSBookErr.Close True, ExcelFileName
Set MSBookErr = Nothing
Set oExcelErr = Nothing
Resume 0
Case 10001
Messagebox "You must save the document before using this action.", 0 + 48, "Export -- Error"
Case 10002
Messagebox "View doesn't exist.", 0 + 48, "Export -- Error"
Case 10004
Messagebox """Attachment"" view not found. Contact your administrator.", 0 + 48, "Export -- Error"
Case 208
Messagebox "MS Excel is not installed on this machine. Please install it before you use this option.", 0 + 48, "Export -- Error"
Case Else
Messagebox {Error: "} & Error & {"} & nl$ & {Number = } & Cstr ( Err ) & nl$ & {Line = } & Cstr ( Erl ), 0 + 16, "Export -- Error"
End Select
Resume exit_sub
End Sub
Sub ExportToExcel ( ExcelPath As String, ExcelFileName As String, thisView As NotesView, Title$ )
Dim s As New NotesSession
Dim db As NotesDatabase
Dim thisDoc As NotesDocument
Dim oExcel As Variant, oWorkbook As Variant, oWorkSheet As Variant
Dim i As Double
Print "Exporting to Excel..."
Set oExcel = CreateObject ( "Excel.Application" )
'Set oWorkbook = oExcel.Workbooks.Add ( ExcelPath & DefaultFileTemplate$ )
'If choice = promptlist(0) Or choice = promptlist(1) Then
'Set oWorkbook = oExcel.Workbooks.Add
'Else
'Set oWorkbook = oExcel.Workbooks.Open(ExcelFileName)
'End If
Set oWorkbook = oExcel.Workbooks.Add
Set oWorkSheet= oWorkbook.Sheets ( 1 )
Set thisDoc = thisView.GetFirstDocument
If thisDoc Is Nothing Goto exit_sub
' to title
oWorkSheet.Range ( "A1").Value=Title$
i = 2'start from the second row underneth title
While Not thisDoc Is Nothing
LastName$ = thisDoc.LastName(0)
FirstName$ = thisDoc.FirstName(0)
MiddleInitial$ = thisDoc.MiddleInitial(0)
InternetAddress$ = thisDoc.InternetAddress(0)
JobTitle$ = thisDoc.JobTitle(0)
Department$ = thisDoc.Department(0)
OfficePhoneNumber$ = thisDoc.OfficePhoneNumber(0)
CellPhoneNumber$ = thisDoc.CellPhoneNumber(0)
Location$ = thisDoc.Location(0)
CompanyName$ = thisDoc.CompanyName(0)
'A row
oWorkSheet.Range ( "A" & Cstr ( i ) ).Value = LastName$
oWorkSheet.Range ( "B" & Cstr ( i ) ).Value = FirstName$
oWorkSheet.Range ( "C" & Cstr ( i ) ).Value = MiddleInitial$
oWorkSheet.Range ( "D" & Cstr ( i ) ).Value = InternetAddress$
oWorkSheet.Range ( "E" & Cstr ( i ) ).Value = JobTitle$
oWorkSheet.Range ( "F" & Cstr ( i ) ).Value = Department$
oWorkSheet.Range ( "G" & Cstr ( i ) ).Value = OfficePhoneNumber$
oWorkSheet.Range ( "H" & Cstr ( i ) ).Value = CellPhoneNumber$
oWorkSheet.Range ( "I" & Cstr ( i ) ).Value = Location$
oWorkSheet.Range ( "J" & Cstr ( i ) ).Value = CompanyName$
i = i + 1
Set thisDoc = thisView.GetNextDocument ( thisDoc )
Wend
exit_sub:
Set oWorkSheet= Nothing
oWorkbook.SaveAs ( "c:\temp\person.xls" )
Set oWorkbook = Nothing
oExcel.Quit
Set oExcel = Nothing
Print "Done"
End Sub
|
)
