' アドレス帳 --> Excel データ 
'       AIT Consulting              http://www.aitjapan.com
' ----------------------------------------------------------
' このコードは"leslie brezer" <ldbrezer@hotmail.com>
'  がメーリングリストlnotesl に投稿したものを元にしている。
' ----------------------------------------------------------
'
' 個人アドレス帳の「ユーザビュー」にアクションボタンを追加して以下の
' コードを挿入する。
' ユーザビューでユーザ文書を選択してボタンをクリックすると
' "C:\MailLabelsFromPAB.xls" に内容を書き出す。
'
'
Sub Click(Source As Button)
     
     Dim workspace As New NotesUIWorkspace
     Dim Session As New NotesSession
     Dim db As NotesDatabase
     Dim Doc As NotesDocument
     Dim j As Long
     Dim dc As NotesDocumentCollection
     Dim notesformula As String
     
REM now Dim the Variables for EXCEL
     
     Dim xlApp As Variant
     Dim xlsheet As Variant
     Dim ExcelARange As String
     Dim ExcelBRange As String
     Dim ExcelCRange As String
     Dim ExcelDRange As String
     Dim ExcelERange As String
     Dim ExcelFRange As String
     Dim datetime As New NotesDateTime("12/01/80")
     
REM now set it for the Current session and selected documents
     
     Set db = Session.currentdatabase
     Set dc = db.UnprocessedDocuments
     
     If dc.count = 0 Then
          Messagebox "Excel住所一覧を作成するユーザを選択してください。"
          Exit Sub
     End If
     
     Set doc = dc.getnthdocument(dc.count)
     ' ステータスバーへメッセージ表示
     Print Str(dc.count) & " 人の住所録を作成します。"
     
REM now open Excel and create the workbook
     
     Set xlApp = CreateObject("Excel.application")
     xlApp.Visible = False
     xlApp.Workbooks.Add
     Set xlsheet = xlApp.Workbooks(1).Worksheets(1)
     With xlsheet
          .Range("A1").Value = "氏名"
          .Range("B1").Value = "会社名"
          .Range("C1").Value = "郵便番号"
          .Range("D1").Value = "都道府県"
          .Range("E1").Value = "市/区"
          .Range("F1").Value = "町村名と番地"
          .Range("G1").Value = "電話番号"
     End With
     For j = 1 To Dc.count
          Set doc = dc.getnthdocument(j)
          PO$ = doc.MailingPOBox(0)
          k = j + 1
          ExcelARange = "A" & Trim(Str(k))
          ExcelBRange = "B" & Trim(Str(k))
          ExcelCRange = "C" & Trim(Str(k))
          ExcelDRange = "D" & Trim(Str(k))
          ExcelERange = "E" & Trim(Str(k))
          ExcelFRange = "F" & Trim(Str(k))
          ExcelGRange = "G" & Trim(Str(k))
          
REM now name the items to go to EXCEL
          
          With xlsheet
               .Range(ExcelARange).value = doc.FullName(0)
               .Range(ExcelBRange).value = doc.CompanyName(0)
               .Range(ExcelCRange).value = doc.OfficeZIP(0)
               .Range(ExcelDRange).value = doc.OfficeState(0)
               .Range(ExcelERange).value = doc.OfficeCity(0)
               .Range(ExcelFRange).value = doc.OfficeStreetAddress(0)
               .Range(ExcelGRange).value = doc.OfficePhoneNumber
               If PO$ <> "" Then
                    .Range(ExcelCRange).value = "PO Box #" & PO$
                    
               End If
          End With
     Next
     
     Xlapp.columns("A:G").Select
     XlApp.Selection.Columns.AutoFit
     XlApp.Rows("1:1").Select
     XlApp.Selection.Font.Bold = True
     XlApp.Range("A1:G1").Select
     With Xlapp.Selection
          .Borders(1).Weight = 3
          .Borders(2).Weight = 3
          .Borders(3).Weight = 3
          .Borders(4).Weight = 3
     End With
     XlApp.Range("A2:G2" & Trim(Str(Cell))).Select
     With XlApp.Selection
          .Borders(1).Weight = 2
          .Borders(2).Weight = 2
          .Borders(3).Weight = 2
          .Borders(4).Weight = 2
     End With
     XlApp.Worksheets(1).pagesetup.orientation=1
     XlApp.Range("A1:G2" & Trim(Str(Cell))).Select
     XlApp.Selection.Font.Name = "Arial"
     XlApp.Selection.Font.Size = 9
     
     With XlApp.Worksheets(1)
          .PageSetup.PrintTitleRows = "$1:$7"
          .Pagesetup.centerheader="System Worksheet - Confidential"
          .Pagesetup.RightFooter = "Page &P" & Chr$(13) & "Date: &D"
          .Pagesetup.CenterFooter = ""
     End With
     On Error Resume Next
     
REM    now delete the file if there is one already and create a new one
     
     Kill "C:\MailLabelsFromPAB.xls"
     On Error Goto 0
     xlapp.activeworkbook.saveas "C:\MailLabelsFromPAB.xls"
     xlapp.activeworkbook.close
     xlapp.quit
     Set xlapp = Nothing
REM tell the user that the data is ready - go to next step in WORD
     Messagebox "作成が終了しました ( Excel シート C:\MailLabelsFromPAB.xls)" &_
     Chr$(10) & "ワードを開いて「宛名ラベル」作成のデータファイルに使用できます。"
End Sub