1 (Declarations)
Const xlTop = -4160
Const xlCenter = -4108
Const xlEdgeLeft = 7
Const xlEdgeTop = 8
Const xlEdgeBottom = 9
Const xlEdgeRight = 10
Const xlInsideVertical = 11
Const xlInsideHorizontal = 12
Const xlContinuous = 1
2 (Initialize)
Sub Initialize
'/*************************** Created By With on 2011/04/02 ***************************/
'Dim HaveRight As Variant
'HaveRight = Evaluate(|@Contains(@UserRoles;"[SystemManagers]")|)
'If HaveRight(0) = 0 Then
' Msgbox "你無權執行此動作",48,"提示"
' Exit Sub
'End If
Dim wk As New NotesUIWorkspace
Dim s As New NotesSession
Dim directory As NotesDbDirectory
Dim db As NotesDatabase
Dim serverName As String
serverName = wk.Prompt(PROMPT_OKCANCELEDIT, "提示", "請輸入Server Name,如:INLSZAP01/INL", "", "")
If serverName = "" Then
Exit Sub
End If
'serverName = "INLSZAP01/INL"
Set directory = s.GetDbDirectory(serverName)
'Set directory = New NotesDbDirectory(serverName)
Set db = directory.GetFirstDatabase(DATABASE) '獲取Notes資料庫(.nsf、.nsg或.nsh文件)
'Set db = directory.GetFirstDatabase(TEMPLATE) '獲取Notes資料庫范本(.ntf文件)
Set excelapp = CreateObject("excel.application")
Set ExcelBook=excelapp.Workbooks.Add
Set xlsheet = excelapp.Workbooks(1).Worksheets(1)
xlsheet.Activate
excelapp.Windows(1).DisplayGridlines = True
'另一種Excel匯出的方法可參考“儀校系統”
excelapp.Visible = True
'ExcelBook.Styles("Normal").HorizontalAlignment=-4108
'ExcelBook.Styles("Normal").VerticalAlignment=-4108
'ExcelBook.Styles("Normal").Font.Size=10
excelapp.Sheets("sheet1").Select
excelapp.Sheets("sheet1").Name = "DB List"
excelapp.Range("A1:F1").MergeCells = True
excelapp.Range("A1:F1").FormulaR1C1 = serverName + "下的DB List如下"
excelapp.Range("A1:F1").HorizontalAlignment = xlCenter
excelapp.Range("A1:F1").Font.bold = True
excelapp.Range("A1:F1").Font.Size = 14
excelapp.Range("A1:F1").Font.ColorIndex = 5 '修改字體的顏色(藍色)
'excelapp.Rows(1).Font.ColorIndex = 5 '設置整行字體的顏色
'定義欄位的寬度
excelapp.Columns("A:A").ColumnWidth = 30
excelapp.Columns("B:B").ColumnWidth =16
excelapp.Columns("C:C").ColumnWidth = 20
excelapp.Columns("D:D").ColumnWidth =14
excelapp.Columns("E:E").ColumnWidth =12
excelapp.Columns("F:F").ColumnWidth =14
'標題欄賦值
excelapp.Range("A2").Value = "標題"
excelapp.Range("B2").Value = "檔名"
excelapp.Range("C2").Value = "路徑"
excelapp.Range("D2").Value = "大小(單位M)"
excelapp.Range("E2").Value = "文件數"
excelapp.Range("F2").Value = "Last Modified"
excelapp.Range("A2:F2").HorizontalAlignment = xlCenter '水平居中對齊設置
excelapp.Range("A2:F2").Font.Size = 12
excelapp.Range("A2:F2").Font.bold = True
excelapp.Range("A2:F2").Interior.ColorIndex = 15 '設置單元格的填充顏色(灰色)
'前兩行單元格增加邊框顯示
excelapp.Range("A1:F2").WrapText = True
excelapp.Range("A1:F2").Borders(xlEdgeLeft).LineStyle. = xlContinuous
excelapp.Range("A1:F2").Borders(xlEdgeTop).LineStyle. = xlContinuous
excelapp.Range("A1:F2").Borders(xlEdgeBottom).LineStyle. = xlContinuous
excelapp.Range("A1:F2").Borders(xlEdgeRight).LineStyle. = xlContinuous
excelapp.Range("A1:F2").Borders(xlInsideVertical).LineStyle. = xlContinuous
excelapp.Range("A1:F2").Borders(xlInsideHorizontal).LineStyle. = xlContinuous
InsertNum = 3
While Not db Is Nothing
Call db.Open("", "")
excelapp.Range("A"+Cstr(InsertNum)).Value = db.Title
excelapp.Range("B"+Cstr(InsertNum)).Value = db.FileName
excelapp.Range("C"+Cstr(InsertNum)).Value = db.FilePath
excelapp.Range("D"+Cstr(InsertNum)).Value = Round(db.Size/1024/1024, 2)
excelapp.Range("E"+Cstr(InsertNum)).Value = db.AllDocuments.Count
excelapp.Range("F"+Cstr(InsertNum)).Value = Format(db.LastModified, "yyyy/mm/dd hh:mm")
InsertNum = InsertNum + 1
Set db = directory.GetNextDatabase()
'If InsertNum = 5 Then Goto flag
Wend
%REM
flag:
'Excel的額外功能
'/**************** DB Info內容增加虛線顯示 Begin ******************/
excelapp.range("A3:F"+Cstr(InsertNum -1)).Select
With excelapp.Selection
'.font.name="Arial"
.borders(1).Weight=1 '單元格左邊框顯示虛線
.borders(2).Weight=1 '單元格右邊框顯示虛線
.borders(3).Weight=1 '單元格上邊框顯示虛線
.borders(4).Weight=1 '單元格下邊框顯示虛線
.font.bold=False
'.columns.ColumnWidth=7
.columns.WrapText=True '使單元格的內容自動換行
.VerticalAlignment = xlTop '垂直居頂對齊, xlTop值為-4160
.columns.Shrinktofit=True '自動縮小單元格的字體,使內容全部顯示出來
'.font.Size = 11
'.mergecells=True '合並單元格
'.HorizontalAlignment = xlCenter '水平居中對齊,xlCenter值為-4108
'.VerticalAlignment = xlCenter '垂直居中對齊
End With
'/**************** DB Info內容增加虛線顯示 End ********************/
'/****************** 頁面增加打印邊界顯示 Begin ********************/
With xlsheet.PageSetup
.Orientation =2
.RightFooter = "Page &P" & Chr$(13) & "Date: &D"
End With
'/****************** 頁面增加打印邊界顯示 End **********************/
%ENDREM
Messagebox "已經成功匯出 " + Cstr(InsertNum-3) + " 筆資料!"
End Sub
来自 “ ITPUB博客 ” ,链接:http://blog.itpub.net/24998103/viewspace-700386/,如需转载,请注明出处,否则将追究法律责任。
转载于:http://blog.itpub.net/24998103/viewspace-700386/