VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています（切り貼りとも言います）。
  1. ホーム
  2. Other
  3. shortcode4notes


Notesのオブジェクト理解のための短いコード

短いコードで、Notesのオブジェクト（Lotus Scriptではクラスと呼称）を操作する事で、階層を理解しようとした履歴。

  1. メールデータベースのViewを列挙
  2. フィールド名を取得する
  3. メールを読み込み、各フィールドを取得する
  4. 添付ファイルを取得する
  5. DBを検索する
  6. 検索してヒットした文書を含むデータベースをワークスペースに開き、次いで文書を開く
  7. メール文書のUniversal IDを取得する
  8. Universal ID 指定でメール文書を開く
  9. 開かれている文書の情報・値を取得
  10. Viewのリストを取得する
  11. Formの名前とAliasを取得する
  12. 目的フォームのフィールドのリストを表示する
  13. Viewから、所属文書のItemのリストを取得する
  14. Database→指定View→フォームで開いた新規文書へのデータ入力
  15. 開いている文書を新規文書にコピーして、コピー先をいじる
  16. ショートカットのリンク先サーバー移行の援用
  17. 既存文書から新規文書にデータをアレンジしつつ写し移行処理を行う
  18. 文書構造（item list)をワークシートに書き出す。文書の状態によりitem数が変化するのを把握
  19. OLEとCOMの混在使用にトライ － データベース・文書構造をワークシートに書き出す。
  20. Notesでメール送信：直接送信版（人様のコード）と、編集状態で保留にする版

Const EMBED_ATTACHMENT = 1454
Const EMBED_OBJECT = 1453
Const EMBED_OBJECTLINK = 1452

'OLE版でNotesのtypeを用いるための列挙体
Enum myNotesType
  ACTIONCD = 16      '保存済みアクション CD レコード (計算不可: 正規法)。
  ASSISTANTINFO = 17 '保存済みアシスタント情報 (計算不可: 正規法)。
  ATTACHMENT = 1084   '添付ファイル。
  AUTHORS = 1076      '作成者
  COLLATION = 2       'この値は Release 6 で新しく追加された。
  DATETIMES = 1024    '日時の値、または日時の値の範囲。
  EMBEDDEDOBJECT = 1090 '埋め込みオブジェクト。
  ERRORITEM = 256     'アイテムの種類へのアクセス中にエラーが発生したことを表す。
  Formula = 1536      'Notes 式。
  HTML = 21           'HTML ソーステキスト。
  Icon = 6            'アイコン。
  LSOBJECT = 20       'エージェント用の保存済み LotusScript オブジェクトコード。
  MIME_PART = 25      'MIME サポート。
  Names = 1074        '名前。
  NOTELINKS = 7       'データベース、ビュー、文書へのリンク。
  NOTEREFS = 4        '親文書への参照。
  NUMBERS = 768       '数値または数値リスト。
  OTHEROBJECT = 1085  'ほかのオブジェクト。
  QUERYCD = 15        '保存済み検索 CD レコード (計算不可: 正規法)。
  Readers = 1075      '読者。
  RICHTEXT = 1        'リッチテキスト。
  Signature = 8       '署名。
  Text = 1280         'テキストまたはテキストリスト。
  RFC822TEXT=1282     'RFC822 インターネットメールテキスト(って何？)
  UNAVAILABLE = 512   'アイテムの種類が無効であることを意味。
  UNKNOWN = 0         'アイテムの種類が分からないことを意味。
  USERDATA = 14       'ユーザーのデータ。
  UserId = 1792       'ユーザー ID の名前。
  VIEWMAPDATA = 18    '保存済み ViewMap データセット (計算不可: 正規法)。
  VIEWMAPLAYOUT = 19  '保存済み ViewMap レイアウト (計算不可: 正規法)。
  EMBED_ATTACHMENT = 1454
  EMBED_OBJECT = 1453
  EMBED_OBJECTLINK = 1452
End Enum

'******************************************************************
'notestypeと記述を紐付けるためのDictionary設定
Sub setDictionary(myDic As Object)
  myDic.Add CStr(myNotesType.ACTIONCD), "ACTIONCD,保存済みアクションCDレコード "
  myDic.Add CStr(myNotesType.ASSISTANTINFO), "ASSISTANTINFO,保存済みアシスタント情報 (計算不可: 正規法)"
  myDic.Add CStr(myNotesType.ATTACHMENT), "ATTACHMENT,添付ファイル"
  myDic.Add CStr(myNotesType.AUTHORS), "AUTHORS,作成者"
  myDic.Add CStr(myNotesType.COLLATION), "COLLATION"
  myDic.Add CStr(myNotesType.DATETIMES), "DATETIMES,日時の値、または日時の値の範囲"
  myDic.Add CStr(myNotesType.EMBEDDEDOBJECT), "EMBEDDEDOBJECT,埋め込みオブジェクト"
  myDic.Add CStr(myNotesType.ERRORITEM), "ERRORITEM,アイテムアクセスエラー"
  myDic.Add CStr(myNotesType.Formula), "Formula,Notes 式"
  myDic.Add CStr(myNotesType.HTML), "HTML,HTMLソーステキスト"
  myDic.Add CStr(myNotesType.Icon), "Icon,アイコン"
  myDic.Add CStr(myNotesType.LSOBJECT), "LSOBJECT,エージェント用保存済LotusScriptオブジェクトコード"
  myDic.Add CStr(myNotesType.MIME_PART), "MIME_PART,MIME サポート"
  myDic.Add CStr(myNotesType.Names), "Names,名前"
  myDic.Add CStr(myNotesType.NOTELINKS), "NOTELINKS,データベース、ビュー、文書へのリンク"
  myDic.Add CStr(myNotesType.NOTEREFS), "NOTEREFS,親文書への参照"
  myDic.Add CStr(myNotesType.NUMBERS), " NUMBERS,数値または数値リスト"
  myDic.Add CStr(myNotesType.OTHEROBJECT), "OTHEROBJECT,ほかのオブジェクト"
  myDic.Add CStr(myNotesType.QUERYCD), "QUERYCD,保存済み検索 CD レコード (計算不可: 正規法)"
  myDic.Add CStr(myNotesType.Readers), "Readers,読者"
  myDic.Add CStr(myNotesType.RICHTEXT), "RICHTEXT,リッチテキスト"
  myDic.Add CStr(myNotesType.Signature), "Signature,署名"
  myDic.Add CStr(myNotesType.Text), "Text,テキストまたはテキストリスト"
  myDic.Add CStr(myNotesType.RFC822TEXT), "RFC822インターネットメールテキスト"
  myDic.Add CStr(myNotesType.UNAVAILABLE), "UNAVAILABLE,アイテムの種類が無効"
  myDic.Add CStr(myNotesType.UNKNOWN), "UNKNOWN,アイテムの種類が不明"
  myDic.Add CStr(myNotesType.USERDATA), "USERDATA,ユーザーのデータ"
  myDic.Add CStr(myNotesType.UserId), "UserId,ユーザー ID の名前"
  myDic.Add CStr(myNotesType.VIEWMAPDATA), "VIEWMAPDATA,保存済み ViewMap データセット (計算不可: 正規法)"
  myDic.Add CStr(myNotesType.VIEWMAPLAYOUT), "VIEWMAPlayout,保存済み ViewMap レイアウト (計算不可: 正規法)"
  myDic.Add CStr(myNotesType.EMBED_ATTACHMENT), "EMBED_ATTACHMENT,埋込添付ファイル"
  myDic.Add CStr(myNotesType.EMBED_OBJECT), "EMBED_OBJECT,埋込オブジェクト"
  myDic.Add CStr(myNotesType.EMBED_OBJECTLINK), "EMBED_OBJECTLINK,埋込オブジェクトリンク"
End Sub
コンテンツリストに戻る 


'******************************************************************
'メールデータベースのViewを列挙
Sub myGetViews()
    Dim session As Object, DB As Object
    Dim server As String, mailFile As String, user As String, usersig As String
    Dim items As Variant, docs As Variant, views As Variant
    Dim view As Object, doc As Object, item As Object
    Dim i As Long
    
    Set session = CreateObject("Notes.NotesSession")
    user = session.UserName
    usersig = session.COMMONUSERNAME
    server = session.GETENVIRONMENTSTRING("MailServer", True)
    mailFile = session.GETENVIRONMENTSTRING("MailFile", True)
    Set DB = session.GETDATABASE(server, mailFile)
    If Not DB.IsOpen Then DB.OPENMAIL
    views = DB.views
    For i = LBound(views) To UBound(views)
      Debug.Print views(i).Name
    Next i
End Sub
'ステーショナリー(_S)
'(Default)
'(Discussion Threads)
'($Drafts)
'(To do's\By Category)
'(To do's\By Status)
'($All)
'($Calendar)
'($Meetings)
'($FolderRefInfo)
'($HeadlinesView)
'($Profiles)
'($POP3UIDL)
'($POP3)
'($SoftDeletions)
'($RepeatLookup)
'($Sent)
'($ToDo)
'($VIM100)
'($VIM23)
'($VIM256)
'($VIM42)
'($VIM98)
'($Inbox)
'($Trash)
'グループスケジュール
'ルール
'($Alarms)
'($FolderInfo)
コンテンツリストに戻る 



'******************************************************************
'フィールド名を取得する
Sub myGetFieldName()
    Dim session As Object, DB As Object
    Dim server As String, mailFile As String, user As String, usersig As String
    Dim items As Variant, docs As Variant, views As Variant
    Dim view As Object, doc As Object, item As Object
    Dim i As Long
    
    Set session = CreateObject("Notes.NotesSession")
    user = session.UserName
    usersig = session.COMMONUSERNAME
    server = session.GETENVIRONMENTSTRING("MailServer", True)
    mailFile = session.GETENVIRONMENTSTRING("MailFile", True)
    Set DB = session.GETDATABASE(server, mailFile)
    If Not DB.IsOpen Then DB.OPENMAIL
    Set view = DB.GETVIEW("($Inbox)")
    Set doc = view.GETFIRSTDOCUMENT
    items = doc.items
    For i = LBound(items) To UBound(items)
      Debug.Print items(i).Name, items(i).Type
    Next i
End Sub

'☆　下記リストとあるのがくせ者。Variant型の配列を戻す。
'Type
'1    'RICHTEXT (1) はリッチテキストです。
'768  'NUMBERS (768) は数値または数値リストです。
'1024 'DATETIMES (1024) は日時の値、または日時の値の範囲です。
'1074 'NAMES (1074) は名前です。
'1280 'TEXT (1280) はテキストまたはテキストリストです。
'1282 'RFC822Text (1282) は RFC822 インターネットメールテキスト って何？
'ここではみつからなかったが他に、
'ATTACHMENT (1084) は添付ファイルです。
'EMBEDDEDOBJECT (1090) は埋め込みオブジェクトです。

'Return_Path 1282
'Received 1282
'Received 1282
'Received_SPF 1282
'Received 1282
'$MessageID     1282
'From 1282
'SendTo 1282
'Subject 1282
'PostedDate 1282
'MIME_Version 1282
'ReplyTo 1282
'Errors_To 1282
'$Mailer        1282
'$SMTPNotFromNotes            1280
'$MIMETrack     1280
'$Hops          768
'DeliveredDate 1024
'MailPop3UIDL 1280
'$UpdatedBy     1074
'Body 1
コンテンツリストに戻る 


'******************************************************************
'メールを読み込み、各フィールドを取得する
'メールが開いてないと20個前後。開かれたメールは50個以上のフィールドを持つ。
Sub readMail()
    Dim session As Object, DB As Object
    Dim server As String, mailFile As String, user As String, usersig As String
    Dim items As Variant, docs As Variant, views As Variant
    Dim view As Object, doc As Object, item As Object, tempDoc As Object
    Dim i As Long
    Dim buf As Variant
    
    Set session = CreateObject("Notes.NotesSession")
    user = session.UserName
    usersig = session.COMMONUSERNAME
    server = session.GETENVIRONMENTSTRING("MailServer", True)
    mailFile = session.GETENVIRONMENTSTRING("MailFile", True)
    
    Set DB = session.GETDATABASE(server, mailFile)
    If Not DB.IsOpen Then DB.OPENMAIL
    
    'COM版では動くのだが、OLE版ではALLDOCUMENTSがエラーになる（メンバとしては表示されるのだが）
    'docs = DB.ALLDOCUMENTS
    '文書数を戻すプロパティも無さそう

    Set view = DB.GETVIEW("($Inbox)")
    Set doc = view.GETFIRSTDOCUMENT
    Do Until doc Is Nothing
        items = doc.items
        For i = 1 To UBound(items)
          Debug.Print Format(i, "0000") & " : " & items(i).Name,
          'items("hoge")の値は、例え一つしかなくても,Variant型の配列として取得される
          '注：直接　items(i).values(0) はエラーになる。
          buf = items(i).Values
          If items(i).Name = "Body" Then
'            Debug.Print Left(CStr(buf(0)), 255) 'Error 型違い
            Debug.Print Left(items(i).Text, 255)
          Else
            Debug.Print buf(0)
          End If
          DoEvents: DoEvents: DoEvents
        Next i
        '引数として先の文書を与える必要がある
      Set doc = view.GETNEXTSIBLING(doc)
      'Set doc = view.GETNEXTDOCUMENT(doc) 'これでも可
      Stop
    Loop
End Sub
コンテンツリストに戻る 


'******************************************************************
'添付ファイルを取得する
Sub getAttachment()
    Dim session As Object, DB As Object
    Dim server As String, mailFile As String, user As String, usersig As String
    Dim items As Variant, docs As Variant, views As Variant
    Dim view As Object, doc As Object, item As Object, RichTextBody As Object
    Dim i As Long
    Dim buf As Variant, attaches As Variant, attach As Object
    
    Set session = CreateObject("Notes.NotesSession")
    user = session.UserName
    usersig = session.COMMONUSERNAME
    server = session.GETENVIRONMENTSTRING("MailServer", True)
    mailFile = session.GETENVIRONMENTSTRING("MailFile", True)
    
    Set DB = session.GETDATABASE(server, mailFile)
    If Not DB.IsOpen Then DB.OPENMAIL
    
    'COM版では動くのだが、OLE版ではALLDOCUMENTSがエラーになる（メンバとしては表示されるのだが）
'    docs = DB.ALLDOCUMENTS
    '文書数を戻すプロパティも無さそう

    Set view = DB.GETVIEW("($Inbox)")
    Set doc = view.GETFIRSTDOCUMENT
    Do Until doc Is Nothing
      buf = doc.GETFIRSTITEM("Subject").Values
      'buf = doc.GETITEMVALUE("Subject") 'これでもOK
      Debug.Print buf(0)
      Set RichTextBody = doc.GETFIRSTITEM("Body")
      Debug.Print Left(RichTextBody.Text, 20)
      
      If doc.HASEMBEDDED Then
        attaches = Empty
        On Error Resume Next
        attaches = RichTextBody.EMBEDDEDOBJECTS
        On Error GoTo 0
        If IsArray(attaches) Then
          For i = LBound(attaches) To UBound(attaches)
            'HTMLメールの画像は添付ファイルとして認識されないが、電子署名用のsmime.p7sは添付ファイルと認識される
            If attaches(i).Type = EMBED_ATTACHMENT Then '1454
              Set attach = attaches(i)
              Debug.Print attach.Name
              attach.EXTRACTFILE "E:\" & attach.Name
              Set attach = Nothing
            End If
          Next i
        End If
      End If
      DoEvents: DoEvents: DoEvents
      Set doc = view.GETNEXTSIBLING(doc)
    Loop
End Sub
コンテンツリストに戻る 


'******************************************************************
'DBを検索する
Sub searchDBtest()
    Dim session As Object, DB As Object, doc As Object
    Dim server As String, mailFile As String, user As String, usersig As String
    Dim view As Object
    Dim notesDateTime As Object
    Dim FieldName As String
    Dim FieldContents As String
    Dim hitDocList As Object
    
    FieldName = "Subject"
    FieldContents = "楽天"
    Set session = CreateObject("Notes.NotesSession")
    user = session.UserName
    usersig = session.COMMONUSERNAME
    server = session.GETENVIRONMENTSTRING("MailServer", True)
    mailFile = session.GETENVIRONMENTSTRING("MailFile", True)
    
    Set DB = session.GetDatabase(server, mailFile)
    If Not DB.IsOpen Then DB.OPENMAIL
    
    Set view = DB.GETVIEW("($Inbox)")
    Set notesDateTime = session.createdatetime("2012/12/1")
'    Set hitDocList = DB.SEARCH("@Contains(Subject; '楽天')", Nothing, 0)
    Set hitDocList = DB.search("@Contains(" & FieldName & "; '" & FieldContents & "')", notesDateTime, 0)
    
    Set doc = hitDocList.getfirstdocument
    Debug.Print hitDocList.Count
    Do Until doc Is Nothing
      Debug.Print doc.getitemvalue(FieldName)(0)
      Set doc = hitDocList.getnextdocument(doc)
    Loop
    On Error Resume Next
    Set DB = Nothing
    Set session = Nothing
End Sub
コンテンツリストに戻る 


'******************************************************************
'検索してヒットした文書を含むデータベースをワークスペースに開き、次いで文書を開く
'Accessのデータベースとの連携を視野
'FrontEnd(UIのついたオブジェクト）と、BackEndの意味が分かってきたかも
Sub searchOpenUIdoc()
  Dim ws As Object
  Dim server As String, dbFile As String, viewName As String
  Dim session As Object, DB As Object, doc As Object
  Dim notesDateTime As Object
  Dim FieldName As String, FieldContents As String
  Dim hitDocList As Object, uidoc As Object
  
  FieldName = "Subject"
  FieldContents = "楽天"
  server = ""
  ' 実際にはメール以外のDBで使用したいため、汎用的な書き方にしている
  dbFile = "C:\Lotus\Notes\Data\mail\hoge.nsf"
  viewName = "($Inbox)"
  Set ws = CreateObject("Notes.NotesUIWorkspace")
  Set session = CreateObject("Notes.NotesSession")
  Set DB = session.GETDATABASE(server, dbFile)
  Set notesDateTime = session.CREATEDATETIME("2012/12/1")
  Set hitDocList = DB.Search("@Contains(" & FieldName & "; '" & FieldContents & "')", notesDateTime, 0)
  If hitDocList.Count > 0 Then
    Set doc = hitDocList.GETFIRSTDOCUMENT
    Call ws.OpenDatabase(server, dbFile, viewName)
    Set uidoc = ws.EDITDOCUMENT(True, doc, False)
  End If
  
  On Error Resume Next
  Set ws = Nothing
  Set session = Nothing
End Sub

'NoteｓDBを検索するよりは、文書のUniversalIDというのをAccessに取り込む時に取り込んでおいて
'Access側で検索して、みつけたUIDでアクセスする方が良いと思い当たって試してみた。
'Notesデータベースの名前と所在は、AccessのTableに保存しておけば環境変化に対する修正が容易になる
'UNID(Universal Note ID) すべての文書に固有の識別子であり、データベースのロケーションや日時の情報は含まれません｡ 
'すべてのレプリカ上の同一文書は同じ UNID を保持します｡ この識別子は文書を更新しても変化しません｡(IBMの技術文書より）
'他に、文書のバージョン情報を示すOID(Originator ID),DBのロケーション情報を含むGNID(Global Note ID)
'DB内固有の文書のバージョン情報を表すIID(Instance ID), 前者＋DBのロケーション情報を含むGIID(Global instance ID）
'というのがあるそうな。
コンテンツリストに戻る 


'******************************************************************
'メール文書のUniversal IDを取得する
Sub getUniversalID()
  Dim session As Object 'NotesSession
  Dim DB As Object 'NotesDatabase
  Dim view As Object 'NotesView
  Dim doc As Object 'NotesDocument
  Dim ws As Object 'NotesUIWorkspace
  Dim uiview As Object 'NotesUIView
  
  On Error GoTo errorHandle
  Set ws = CreateObject("Notes.NotesUIWorkspace")
  Set session = CreateObject("Notes.Notessession")
  Set DB = session.CURRENTDATABASE
  Set view = DB.GETVIEW("($Inbox)")
  Set uiview = ws.CURRENTVIEW
  If Not uiview Is Nothing Then
    If uiview.view.Name = "($Inbox)" Then
    'メールのビューが開いていないとエラーになる
      Set doc = view.GETFIRSTDOCUMENT
      Debug.Print doc.UNIVERSALID
    Else
      MsgBox "受信ボックスが開いていません"
    End If
  Else
    MsgBox "開かれたViewはありません"
  End If

errorHandle:
  If Err.Number <> 0 Then Debug.Print Err.Number & Err.Description & Err.Source
  On Error GoTo 0
  On Error Resume Next
  Set session = Nothing
  Set ws = Nothing
End Sub
コンテンツリストに戻る 


'******************************************************************
'Universal ID 指定でメール文書を開く
'Notes//...のショートカット生成による方法も試してみたがうまくいっていない
Sub openDocByUID()
    Dim session As Object, DB As Object, doc As Object
    Dim server As String, mailFile As String
    Dim ws As Object
    Dim docID As String
    Dim uidoc As Object
    
    On Error GoTo errorHandle
    Set session = CreateObject("Notes.NotesSession")
    Set ws = CreateObject("Notes.NotesUIWorkspace")
    Set DB = session.GETDATABASE(server, mailFile)
    If Not DB.IsOpen Then DB.OPENMAIL
    server = session.GETENVIRONMENTSTRING("MailServer", True)
    mailFile = session.GETENVIRONMENTSTRING("MailFile", True)
    
    docID = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
    Set doc = DB.GETDOCUMENTBYUNID(docID)
    'ビューが開かずいきなり文書が開く
    Set uidoc = ws.EDITDOCUMENT(True, doc, False)
    
errorHandle:
    If Err.Number <> 0 Then Debug.Print Err.Number & Err.Description & Err.Source
    On Error GoTo 0
    On Error Resume Next
    Set DB = Nothing
    Set session = Nothing
    Set ws = Nothing
End Sub
コンテンツリストに戻る 


'******************************************************************
'開かれている文書の情報・値を取得
'開いている文書の情報にAccess側からアクセスして、値をAccessDBに登録したい
'Notes側でやる方がスマートかもしれないが、そんな権限はないので

Sub getOpenDocInfo()
  Dim doc As Object 'NotesDocument
  Dim ws As Object 'NotesUIWorkspace
  Dim uidoc As Object
  
  On Error GoTo errorHandle
  Set ws = CreateObject("Notes.NotesUIWorkspace")
  Set uidoc = ws.CURRENTDOCUMENT
  Set doc = uidoc.DOCUMENT
  Debug.Print doc.UNIVERSALID                 'これをキーに追加／更新
  Debug.Print doc.PARENTDATABASE.Title        'これで目的の文書類かチェックできる
  Debug.Print doc.GETITEMVALUE("Subject")(0)  '値の取得
  
errorHandle:
  If Err.Number <> 0 Then Debug.Print Err.Number & Err.Description & Err.Source
  On Error GoTo 0
  On Error Resume Next
  Set ws = Nothing
End Sub
コンテンツリストに戻る 


'******************************************************************
'Viewのリストを取得する

Sub myGetViews()
    Dim session As Object, db As Object
    Dim server As String, notesDB As String
    Dim items As Variant, docs As Variant, views As Variant
    Dim view As Object, doc As Object, item As Object
    Dim i As Long
    
    Set session = CreateObject("Notes.NotesSession")
    server = "hoge/hoge/hoge"
    notesDB = "hoge.nsf"
    
    Set db = session.GetDatabase(server, notesDB)
    If Not db.IsOpen Then db.Open
    views = db.views
    For i = LBound(views) To UBound(views)
      Debug.Print views(i).Name
    Next i
End Sub
コンテンツリストに戻る 


'******************************************************************
'Formの名前とAliasを取得する
'
' 目的Formの確認の仕方
' 1.ビューで文書を選択する｡(今回は個別文書を閲覧用に開いたビュー=フォームとなる）
' 2.[ファイル]>[プロパティ]をクリック。
' 3.[プロパティ] ダイアログボックスで、プロパティの種類として[文書]が表示されていることを確認。
'  表示されていない場合は、矢印をクリックして選択する。
' 4.[フィールド]タブをクリックする。→フィールドのリストが表示される。
' 5.左側のパネルで[フォーム]を選択。 右側のパネルの下部にフォームの名前が引用符に囲まれて表示される。

Sub myGetFroms()
    Dim session As Object, db As Object
    Dim server As String, notesDB As String
    Dim forms As Variant, docs As Variant, views As Variant
    Dim form As Variant, doc As Object, item As Object
    Dim fields As Variant
    Dim i As Long, j As Long
    Dim aliases As Variant
    
    Set session = CreateObject("Notes.NotesSession")
    server = "hoge/hoge/hoge"
    notesDB = "hoge.nsf"
    
    Set db = session.GetDatabase(server, notesDB)
    If Not db.IsOpen Then db.Open
    forms = db.forms
    For i = LBound(forms) To UBound(forms)
    'Objectではなく、String型の配列なので注意 Setだとエラーになる
      aliases = forms(i).aliases
      Debug.Print forms(i).Name,
      If Not IsEmpty(aliases) Then Debug.Print aliases(0)
    Next i
End Sub
コンテンツリストに戻る 


'******************************************************************
'目的フォームのフィールドのリストを表示する-フィールドとitemの違いに留意
'でも目的のフォームを取得しても、あまり出来る事がない。大抵CurrentDocumentを取得して
'処理することになるため。
'CurrentFormを取得する術がみつからない。DocumentのＩｔｅｍにItems("Form")というのがあるので
'これで取得するのか？という事は、Accessと異なりDocumentと、Formは完全に1対1の対応なのか？
’NotesにはAccessでいうTableをデザインビューで作成するといったことはなく、Formの設計=Tableの設計
'という事らしいが、Notesの基本が分かっていないので、すっきりしない。

Sub myGetFields()
    Dim session As Object, db As Object
    Dim server As String, notesDB As String
    Dim forms As Variant, docs As Variant, views As Variant
    Dim form As Variant, doc As Object, item As Object
    Dim fields As Variant
    Dim i As Long, j As Long
    Dim aliases As Variant
    
    Set session = CreateObject("Notes.NotesSession")
    server = "hoge/hoge/hoge"
    notesDB = "hoge.nsf"
    
    Set db = session.GetDatabase(server, notesDB)
    If Not db.IsOpen Then db.Open
    forms = db.forms
    For i = LBound(forms) To UBound(forms)
    'ここではaliasではなくてNameで設定
    'alias指定がうまくいっていない
      If forms(i).Name = "hoge" Then
        Set form = forms(i)
      End If
    Next i
    fields = form.fields
    For j = LBound(fields) To UBound(fields)
      Debug.Print fields(j)
      Debug.Print
    Next j
End Sub
コンテンツリストに戻る 


'******************************************************************
'Viewから、所属文書のItemのリストを取得する、NotesTypeも表示する
Sub myGetFieldName()
    Dim session As Object, db As Object
    Dim server As String, notesDB As String, user As String, usersig As String
    Dim items As Variant, docs As Variant, views As Variant
    Dim view As Object, doc As Object, item As Object
    Dim i As Long
    Dim myDic As Object
    Dim buf As Variant
    
    Set session = CreateObject("Notes.NotesSession")
    Set myDic = CreateObject("Scripting.Dictionary")
    setDictionary myDic
    server = "hoge/hgoge/hoge"
    notesDB = "hoge.nsf"
    Set db = session.GetDatabase(server, notesDB)
    If Not db.IsOpen Then db.Open
    Set view = db.GetView("ビューの名称")
    Set doc = view.GetFirstDocument
    items = doc.items
    For i = LBound(items) To UBound(items)
      buf = Split(myDic(CStr(items(i).Type)), ",")
      Debug.Print items(i).Name, items(i).Type, buf(0), buf(1)
    Next i
    Set myDic = Nothing
End Sub
コンテンツリストに戻る 


'******************************************************************
'Database→指定View→フォームで開いた新規文書へのデータ入力
'Richtextへの書き込みをTextだけに限定した妥協バージョン(ファイル添付は脚注に貼り付けられてしまう）
Sub dataInputTest()
  Dim targetRange As Range
  Dim sh As Worksheet
  
  Dim session As Object, db As Object
  Dim server As String, notesDB As String
  Dim items As Variant, docs As Variant, views As Variant
  Dim view As Object, doc As Object
  Dim i As Long
  Dim ws As Object
  Dim viewName As String
  Dim uidoc As Object
  Dim uiview As Object
  
  Dim richItem As Object
  Dim attachName As String
  Dim attach As Object
  
  Set ws = CreateObject("Notes.NotesUIWorkspace")
  Set session = CreateObject("Notes.NotesSession")
   
  server = "hoge/hoge/hoge"
  notesDB = "hoge.nsf"
  
  Set db = session.GetDatabase(server, notesDB)
  If Not db.IsOpen Then db.Open
  viewName = "Viewの名称"
  Call ws.OpenDatabase(server, notesDB, viewName)
  Set doc = db.CreateDocument()
  'ここはAliasでないとダメらしい
  doc.form = "hoge"
  Set uiview = ws.CURRENTVIEW
  Set uidoc = ws.EDITDOCUMENT(True, doc, False)
  'エクセルワークシートの出力元データ範囲を取得
  Set sh = ThisWorkbook.Sheets("InputTest")
  
  '下記の様に配置したワークシートから読み込んで書き込み
  'フォーム上見えないフィールドは値を空にして、下方のコードで書込対象から外している
  'A列        B列   C列               D列
  'fieldName  Type  Type Description  TestData <- Label
  'Form       1280  Text              3
  '$Fonts     1     RICHTEXT          4
  'From       1280  Text              5
  'D列はフォームのフィールドとの対照確認のため数値とした
  
  'オプションボタンや、チェックボックスは、True/Falseでなく
  '対応する値 有/無 等を与える必要があるらしく、一品料理となる
  'また、見た目フォームに反映されないフィールドが相当数あり→隠しフィールド、演算フィールド等
  
  With sh
    Set targetRange = Range(.Range("A2"), .Range("A" & .Rows.Count).End(xlUp)).Resize(, 4)
  End With
 
  With targetRange
    For i = 1 To .Rows.Count
      Select Case .Cells(i, 2).Value
      Case myNotesType.Text
      'プレーンテキストの場合、バックエンド文書の更新が即座にFormに反映されるので、上の記述でもOK
'        Call uidoc.document.ReplaceItemValue(.Cells(i, 1).Value, CStr(.Cells(i, 4).Value))
        If .Cells(i, 4).Value <> "" Then
          uidoc.FIELDSETTEXT .Cells(i, 1).Value, CStr(.Cells(i, 4).Value)
        End If
      Case myNotesType.RICHTEXT
        'RichTextへのアクセスがうまくいかない
        '保存して再度開いても欄外のへんなところにファイル添付されている。書き込んだテキストは行方不明になる。
        If .Cells(i, 4).Value <> "" Then
          uidoc.FIELDSETTEXT .Cells(i, 1).Value, CStr(.Cells(i, 4).Value)
        End If
'		下記はRichTextItemに添付ファイルをつけるコードであるが、脚注の様なところに添付されてしまって、期待した動作をしない。        
'        If .Cells(i, 1).Value = "hoge" Then
'          uidoc.Save
'          Set richItem = uidoc.document.GetFirstItem("hoge")
'          attachName = GetDesktopPath & "\" & "testFile.pdf"
'          Set attach = richItem.EmbedObject(myNotesType.EMBED_ATTACHMENT, "", attachName)  '1454
'        End If
      Case Else
      
      End Select
    Next i
  End With
  'フロントエンド文書を保存する（競合上書き）
  uidoc.Save True, True
  If Not uiview Is Nothing Then uiview.Close
  Set uidoc = Nothing
  Set uiview = Nothing
  Set db = Nothing
  Set session = Nothing
  Set ws = Nothing
End Sub
コンテンツリストに戻る 


'******************************************************************
'開いている文書を新規文書にコピーして、コピー先をいじる
'RichTextItemへの記述が期待した様に動かないため、苦肉の策で試してみた。
'既存文書をいじると、所定のフィールドに添付ファイルが入る事が確認できた。

Sub copyUidoc2newDoc()
  Dim doc As Object 'NotesDocument
  Dim newDoc As Object
  Dim ws As Object 'NotesUIWorkspace
  Dim uidoc As Object
  Dim items As Variant, item As Object
  Dim i As Long
  Dim uidb As Object
  Dim richItem As Object
  Dim attaches As Variant
  Dim attach As Object
  Dim attachName As String
  
  On Error GoTo errorHandle
  Set ws = CreateObject("Notes.NotesUIWorkspace")
  Set uidoc = ws.CURRENTDOCUMENT
  '文書が開いていないとき抜ける
  If uidoc Is Nothing Then
    MsgBox "複写元の文書を開いてから実行してください。"
    Exit Sub
  End If
  
  Set doc = uidoc.document
  Set uidb = uidoc.document.ParentDatabase
  Set newDoc = uidb.CreateDocument
  doc.CopyAllItems newDoc, True
  newDoc.Save True, False
  uidoc.Close
  Set uidoc = Nothing
  Set uidoc = ws.EDITDOCUMENT(True, newDoc, False)
  
  '文字の置換は
  Set item = newDoc.GetFirstItem("name_1")
  item.Values(0) = "test"
  
  'リッチテキストフィールドの処理
  Set richItem = newDoc.GetFirstItem("faile")
  '既存添付ファイル削除
  If newDoc.HASEMBEDDED Then
    attaches = Empty
    On Error Resume Next
    attaches = richItem.EMBEDDEDOBJECTS
    On Error GoTo 0
    If IsArray(attaches) Then
      For i = LBound(attaches) To UBound(attaches)
        If attaches(i).Type = EMBED_ATTACHMENT Then '1454
          Set attach = attaches(i)
'          Debug.Print attach.Name
'          attach.ExtractFile "E:\" & attach.Name
          attach.Remove  '添付ファイルの除去
          Set attach = Nothing
        End If
      Next i
    End If
  End If
  'アイコンはなくて寂しいが新規ファイル添付に成功(スクリプトで貼り付けると「白紙」になるらしい）
  attachName = GetDesktopPath & "\" & "hoge.pdf"
  Set attach = richItem.EmbedObject(myNotesType.EMBED_ATTACHMENT, "", attachName)  '1454
  newDoc.Save True, False
  Set uidoc = ws.EDITDOCUMENT(True, newDoc, False)
    
errorHandle:
  If Err.Number <> 0 Then Debug.Print Err.Number & Err.description & Err.Source
  On Error GoTo 0
  On Error Resume Next
  Set ws = Nothing
End Sub
コンテンツリストに戻る 


'***************************************************************
'　ショートカットのリンク先サーバー移行の援用
' 開いているNotes文書の添付ファイルがショートカットであれば
' 元ファイルを取得して、対照表により新サーバーにコピーし
' 新サーバー上のファイルのショートカットを生成して
' デスクトップのLinkFilesフォルダーに収納する。
' ノーツにはLinkFilesフォルダーから切り貼りする

Const EMBED_ATTACHMENT = 1454
Const EMBED_OBJECT = 1453
Const EMBED_OBJECTLINK = 1452

Type fileInfo
  serverFolder As String
  subFolder As String
  fileName As String
End Type


Sub replaceAttachedShortcut()
  Dim doc As Object 'NotesDocument
  Dim ws As Object 'NotesUIWorkspace
  Dim uidoc As Object
  Dim items As Variant, item As Object
  Dim i As Long, j As Long
  Dim uidb As Object
  Dim richItem As Object
  Dim attaches As Variant
  Dim attach As Object
  Dim attachName As String
  Dim mileStone As Long
  Dim myTempPath As String 'Windowsのテンポラリパス
  Dim tempAttachPath As String
  Dim oldSubstanceFullPath As String '現在のショートカットファイルの参照先ファイル（実体）のフルパス
  Dim newSubstanceFullPath As String '移行後の　〃
  Dim lnkFileInfo As fileInfo 'ショートカットファイルの参照先のフルパスを分解した構造体
  Dim serverPathCell As Range '現サーバーをワークシートで検索して見つかったセル
  Dim newServerPath As String
  Dim subFolders As Variant '\でSplitしたフォルダーを収納
  Dim subFolder As String
  Dim msgboxAnswer As Long 'msgbox(vbYesNoの戻り値)
  Dim linkFileFolder As String '新規生成したショートカットを収納するフォルダー（デスクトップに生成)
  Dim FSO As Object
  'File System Object 特殊フォルダー取得用
  Const TemporaryFolder = 2  ' テンポラリフォルダ。環境変数TMPより取得
  Const targetDB As String = "hoge"
  
  On Error GoTo errorHandle
  Set FSO = CreateObject("Scripting.FileSystemObject")
  
  myTempPath = FSO.GetSpecialFolder(TemporaryFolder)
  Set ws = CreateObject("Notes.NotesUIWorkspace")
  Set uidoc = ws.CURRENTDOCUMENT
  '文書が開いていないとき抜ける
  If uidoc Is Nothing Then
    MsgBox "複写元の文書を開いてから実行してください。"
    'Objectの終了処理
    GoTo errorHandle
  End If
  
  '開いている文書のデータベースが所期のものかチェック
  Set doc = uidoc.document
  Set uidb = uidoc.document.ParentDatabase
  If Not uidb.Title = targetDB Then
    MsgBox targetDB & "　の文書が対象です" & vbCrLf & "処理を打ち切ります"
    GoTo errorHandle
  End If
  
  'DeskTopにLinkFilesフォルダーが無ければ作る、あれば中味を空にするか照会する
  linkFileFolder = GetDesktopPath & "\LinkFiles"
  If FSO.folderexists(linkFileFolder) Then
    If FSO.GetFolder(linkFileFolder).Files.Count > 1 Then
        Dim 結果 As Long
      msgboxAnswer = MsgBox("LinkFilesフォルダーを初期化しますか？", vbYesNo)
      If msgboxAnswer = vbNo Then
        MsgBox "処理を中断します。"
        GoTo errorHandle
      End If
      FSO.DeleteFolder linkFileFolder
      FSO.CreateFolder linkFileFolder
    End If
  Else
    FSO.CreateFolder linkFileFolder
  End If
   
  'リッチテキストフィールドの処理
  'フィールド名はデータベースにより異なる。
  Set richItem = doc.GetFirstItem("Body")
  
  If doc.HASEMBEDDED Then
    attaches = Empty
    On Error Resume Next
    '添付ファイル（複数）取得
    attaches = richItem.EMBEDDEDOBJECTS
    On Error GoTo 0
    If IsArray(attaches) Then
      For i = LBound(attaches) To UBound(attaches)
        If attaches(i).Type = EMBED_ATTACHMENT Then '1454
          Set attach = attaches(i)
          'ショートカットファイルの時だけ処理
          If LCase(FSO.GetExtensionName(attach.Name)) = "lnk" Then
            '名前決め打ちで保存する
            tempAttachPath = myTempPath & "\" & "tempAttach.lnk"
            '添付ファイルを抽出してテンポラリーファイルとして保存
            attach.ExtractFile tempAttachPath
            'ショートカットのリンク先の取得
             oldSubstanceFullPath = getShortcutPath(tempAttachPath)
            'リンク先のフルパスをサーバーのフォルダー名、サーバーのサブフォルダー名、ファイル名に分割して
            '構造体に収納
            lnkFileInfo = splitFilePath(oldSubstanceFullPath)
            'Excelシートに作成した新旧サーバーフォルダー対照表から検索して、新サーバーフォルダー取得
            Set serverPathCell = Sheets("comparativeTable").UsedRange.Find(What:=lnkFileInfo.serverFolder, LookIn:=xlValues, LookAt:=xlWhole)
            'serverPathが見つかった時
            If Not serverPathCell Is Nothing Then
              newServerPath = serverPathCell.Offset(0, 1).Value
              'Folerの存在チェック
              If Not FSO.folderexists(newServerPath & lnkFileInfo.subFolder) Then
                'パスをサブフォルダーに分解して、階層に沿って逐次フォルダー生成
                subFolders = Split(lnkFileInfo.subFolder, "\")
                subFolder = ""
                For j = 1 To UBound(subFolders)
                  subFolder = subFolder & "\" & subFolders(j)
                  Debug.Print newServerPath & subFolder
                  If Not FSO.folderexists(newServerPath & subFolder) Then
                    FSO.CreateFolder newServerPath & subFolder
                  End If
                Next j
              End If
              
              '==================================================================
              'ファイルのコピー
              newSubstanceFullPath = newServerPath & lnkFileInfo.subFolder & "\" & lnkFileInfo.fileName
              If Not FSO.FileExists(newSubstanceFullPath) Then FSO.copyfile oldSubstanceFullPath, newSubstanceFullPath
              
              '==================================================================
              'ショートカットの作成
              makeShortCut newSubstanceFullPath, attach.Name
              
              '==================================================================
              'ショートカットのattach
              '一旦閉じて開くと、一番下に灰色アイコンで、添付は成功している。
              'みっともないので、指定フォルダーに一括生成してそこからD&Dする事にした
'              Set attach = richItem.EmbedObject(EMBED_ATTACHMENT, "", newServerPath & lnkFileInfo.subFolder & "\" & lnkFileInfo.fileName)
'              doc.Save True, False
            End If
          End If

          Set attach = Nothing
        End If
      Next i
    End If
  End If
    
  MsgBox "処理終了しました。"
errorHandle:
  If Err.Number <> 0 Then Debug.Print Err.Number & Err.Description & Err.Source
  On Error GoTo 0
  On Error Resume Next
  Set ws = Nothing
  Set FSO = Nothing
End Sub

'パスの分割処理
Function splitFilePath(fileFullPath As String) As fileInfo
  Dim firstBackSlash As Long, secondBackSlash As Long, lastBackSlash As Long
   
  firstBackSlash = InStr(3, fileFullPath, "\")
  secondBackSlash = InStr(firstBackSlash + 1, fileFullPath, "\")
  splitFilePath.serverFolder = Left(fileFullPath, secondBackSlash - 1)
  lastBackSlash = InStrRev(fileFullPath, "\")
  splitFilePath.subFolder = Mid(fileFullPath, secondBackSlash, lastBackSlash - secondBackSlash)
  splitFilePath.fileName = Right(fileFullPath, Len(fileFullPath) - lastBackSlash)
End Function

'ショートカットをデスクトップの指定フォルダー（LinkFiles固定)に生成
Sub makeShortCut(linkFileFullPath As String, attachName As String)
    Dim WSH, LnkFile, LnkFileName As String
    Dim targetFolder As String
    
    Set WSH = CreateObject("WScript.Shell")
    targetFolder = WSH.SpecialFolders("Desktop") & "\LinkFiles\"
    LnkFileName = targetFolder & "\" & attachName
    Set LnkFile = WSH.CreateShortcut(LnkFileName)
    LnkFile.TargetPath = linkFileFullPath
    LnkFile.Save
    Set LnkFile = Nothing
    Set WSH = Nothing
End Sub

'ショートカットファイルの参照先を取得
Function getShortcutPath(lnkFilePath As String) As String
    Dim WSH, LnkFile, DeskTopPath As String, LnkFileName As String
    
    Set WSH = CreateObject("WScript.Shell")
    Set LnkFile = WSH.CreateShortcut(lnkFilePath)
    getShortcutPath = LnkFile.TargetPath
    Set LnkFile = Nothing
    Set WSH = Nothing
End Function

'デスクトップのパスを取得
Private Function GetDesktopPath() As String
  Dim wScriptHost As Object, strInitDir As String
  Set wScriptHost = CreateObject("Wscript.Shell")
  GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
  Set wScriptHost = Nothing
End Function
コンテンツリストに戻る 


'***************************************************************
'　既存文書の値を読込み新規文書に必要な情報をコピーして移行処理を行う
'　この際、版数を上げたり、セルを繰り上げたりしてアレンジする
'　ノーツ操作の邪魔にならない様にExcelを非表示にして、UserFormだけで操作する
'　従って、UserFormモジュールに記述

Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST As Long = -1
Private Const SWP_NOSIZE As Long = &H1&
Private Const SWP_NOMOVE As Long = &H2&

'読み込んだデータを保持する連想配列
Dim dic As Object
'文書データベースを保持
Dim notesDB As Object
Dim session as Object

'前版の登録データ読込
Private Sub inputButton_Click()
'workのシートのitem名のリストを連想配列に取り込んで、それを用いて処理を行う
'旧文書と新文書を同時に開いて直接データをコピペしても良いのだが、別の構想の名残です。
  Dim doc As Object 'NotesDocument
  Dim ws As Object 'NotesUIWorkspace
  Dim uidoc As Object
  
  Dim wbk As Workbook
  Dim sh As Worksheet
  Dim mycell As Range
  Dim targetRange As Range
  Dim myKeys As Variant
  Dim myKey As Variant
  
  On Error GoTo errorHandle
  'Worksheet:workは不可視化してある
  Set wbk = ThisWorkbook
  Set sh = wbk.Worksheets("work")
  With sh
    Set targetRange = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp))
  End With
  'item名のリストを作業シートから取込連想配列に設定
  Set dic = CreateObject("Scripting.Dictionary")
  For Each mycell In targetRange.Cells
    dic.Add mycell.Value, Empty
  Next mycell
  myKeys = dic.keys
  
  Set ws = CreateObject("Notes.NotesUIWorkspace")
  Set uidoc = ws.CURRENTDOCUMENT
  Set doc = uidoc.DOCUMENT
  Set session = CreateObject("Notes.NotesSession")
  
  '目的の文書類かチェック
  If doc.parentdatabase.Title <> "hogeB" Then
    MsgBox "意図したDBの文書ではありません"
    Exit Sub
  End If
' データ取込
  For Each myKey In myKeys
    dic(myKey) = uidoc.FieldGetText(myKey)
  Next myKey
  Me.TextBox1.Value = dic("name_1")
  uidoc.Close
errorHandle:
  If Err.Number <> 0 Then
    MsgBox "Error:" & Err.Number & Err.Description & Err.Source
    Application.Visible = True
  End If

  On Error GoTo 0
  On Error Resume Next
  Set ws = Nothing
End Sub

'読み込んであるデータをアレンジして書き出し
Private Sub outputButton_Click()
  Dim newDoc As Object 'NotesDocument
  Dim ws As Object 'NotesUIWorkspace
  Dim uidoc As Object
  Dim buf As Variant
  Dim myKeys As Variant
  Dim myKey As Variant
  Dim buf2 As String
  Dim revNo As Long
  Dim items as Object
  Dim i as long
  
  On Error GoTo errorHandle
  Set ws = CreateObject("Notes.NotesUIWorkspace")
  '新規文書を開いて編集状態にする
  Set newDoc = notesDB.createDocument
  Set uidoc = ws.EDITDOCUMENT(True, newDoc, False)
    
  '更新＋保存でフィールドを更新する。
  'ステータスによりフィールド数が異なるため
  uidoc.Refresh
  '作成者フィールドに対する処理
  'これを行わないと、作成者フィールドが設定されている文書を保存出来ない事態になる
  'http://www2.ocn.ne.jp/~notes/lotus/script18.htmhttp://www2.ocn.ne.jp/~notes/lotus/script18.htm
  items = uidoc.Document.items
  For i=LBound(items) to UBound(items)
  	if items(i).IsAuthors = True then items(i).AppendToTextList(session.UserName)
  next i
  
  uidoc.Save True, True
  
  '連想配列に収納してあるデータを新規文書に書き出す
  myKeys = dic.keys
  For Each myKey In myKeys
    Select Case True
      '版数を上げる
      Case (myKey Like "rev?")
        revNo = Val(Replace(myKey, "rev", ""))
        If revNo > 2 Then
          uidoc.FieldsetText "rev" & CStr(revNo - 1), dic(myKey)
        Else
          uidoc.FieldsetText myKey, dic(myKey)
        End If
      Case (myKey Like "hoge_?")
        '中略...
     
      Case Else
        uidoc.FieldsetText myKey, dic(myKey)
    End Select
  Next myKey
  
errorHandle:
  If Err.Number <> 0 Then
    MsgBox "Error:" & Err.Number & Err.Description & Err.Source
    Application.Visible = True
  End If

  On Error GoTo 0
  On Error Resume Next
  Set ws = Nothing
  Unload Me
End Sub

Private Sub UserForm_Initialize()
  Application.Visible = False
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  Application.Visible = True
'  Application.WindowState = xlMinimized '機能しない
End Sub

'UserFormを最前面表示設定
'Activateイベントに組み込む事でハンドル取得をGetForegroundWindowで簡便に行っている
Private Sub UserForm_Activate()
  Call SetWindowPos(GetForegroundWindow, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Sub
コンテンツリストに戻る 


'**********************************************************************
'データベース（文書構造）の解析用
'文書作成の各段階でフィールド数が動的に変化する
'各段階で実行してフィールドの状態を把握して、更新処理等に利用する

Sub getOpenDocInfo()
  Dim session As Object, DB As Object
  Dim doc As Object 'NotesDocument
  Dim ws As Object 'NotesUIWorkspace
  Dim uidoc As Object
  Dim uiview As Object
  Dim view As Object, item As Object
  Dim items As Variant, docs As Variant, views As Variant
  Dim buf As Variant
  Dim i As Long
  
  Dim sh As Worksheet
  Dim mycell As Range
  
  Const RICHTEXT = 1

  On Error GoTo errorHandle
  Set ws = CreateObject("Notes.NotesUIWorkspace")
  Set uidoc = ws.CURRENTDOCUMENT
  Set doc = uidoc.DOCUMENT
  
  Set sh = ThisWorkbook.Worksheets("temp")
  sh.Cells.ClearContents
  Set mycell = sh.Range("A1")
  
  '目的の文書類かチェック
  If doc.parentdatabase.Title <> "hogeDB" Then
    MsgBox "意図したDBの文書ではありません"
    Exit Sub
  End If
  Set DB = doc.parentdatabase

  items = doc.items
  '文書に人手で入力するにつれてitem数が動的に増えていく
  
  For i = 1 To UBound(items)
    'items("hoge")の値がリストの時、例え一つしかなくても,Variant型の配列として取得される
    '注：直接　items(i).values(0) はエラーになる。一旦Variant型変数に受ける必要あり。
    'IsArrayで配列かどうか見分けて分岐する必要あり。
    buf = items(i).Values
    mycell.Value = items(i).Name

      If IsArray(buf) Then
        mycell.Offset(0, 1).Value = buf(0)
        mycell.Offset(0, 2).Value = IsArray(buf)
      Else
        mycell.Offset(0, 1).Value = buf
        mycell.Offset(0, 2).Value = IsArray(buf)
        'TypeはRichTextの1しか表示されなかった。いずれにしてもIsArrayがFalseのものはRichTextである。
        mycell.Offset(0, 3).Value = items(i).Type
      End If
      Set mycell = mycell.Offset(1, 0)
    DoEvents: DoEvents: DoEvents
  Next i

errorHandle:
  If Err.Number <> 0 Then Debug.Print Err.Number & Err.Description & Err.Source
  On Error GoTo 0
  On Error Resume Next
  Set ws = Nothing
End Sub
コンテンツリストに戻る 


'**********************************************************************
'データベース（文書構造）の解析用　Part2
'異なるデータベース間での内容コピーがやりたくなって、そのためのツールをまず作成。
'久しぶりなのでCOMで楽をしようと思い、OLEで取得したオブジェクトの情報を用いて、
'COMのオブジェクトを特定して操作する事にトライしている。（同等のオブジェクトでもキャストも出来ないので）

'参照設定
'Lotus Domino Objects
'Lotus Notes Automation Classes

Type dbInfo
  title As String
  fileName As String
  path As String
  server As String
End Type

'Module Level Variation
Dim myDic As Object

'Analyze Notes's Database
'OLEとCOMを共存させて使ってみる
'OLEのオブジェクトと、COMのオブジェクトは実質同じ物でも型変換が出来ないので、
'タイトル・名前とか、UniversalIDとかを経由して特定する

Sub analyzeDb()
  'Notes関係
  Dim session As NotesSession
  Dim password As String
  Dim notesDB As NotesDatabase
  Dim serverName As String
  Dim notesDbName As String
  Dim notesDoc As NotesDocument
  Dim notesDocList As NotesDocumentCollection
  Dim currentDbInfo As dbInfo
  Dim blRet As Boolean
  Dim currentDocUid As String
  Dim items As Variant, views As Variant, forms As Variant, aliases As Variant
  Dim itemValues As Variant, itemString As String
  Dim item As NotesItem, view As NotesView, form As NotesForm, alias As String
  
  'Excel関係
  Dim wbk As Workbook
  Dim sh As Worksheet, newSheet As Worksheet
  Dim mycell As Range
  Dim shNo As Long, tempNo As Long
  Dim colLabelArray As Variant
  Dim myComment as string
  
  'その他
  Dim i As Long, j As Long
  
  '見出しセルの色
  Const myColor As Long = 16764006
  
  On Error GoTo errHandle
  
  '開いている文書からデータベースの情報を取得
  blRet = getCurrentDbInfo(currentDbInfo)
  If Not blRet Then
    'エラー番号は、0～512 の値はシステムエラー用に予約されているため、
    'ユーザー定義のエラーに使用できるのは、513～65535 の範囲の値。
    'サブプロシージャで発生したエラーを何処で発生したのか特定できる様にしたい。
    Err.Raise 1001, "getCurrentDbInfo", "fault:get current database information"
  End If
  
  With currentDbInfo
    notesDbName = .path
    serverName = .server
  End With
  
  'Type-TypeName表引き用連想配列作成
  Set myDic = CreateObject("Scripting.Dictionary")
  setDictionary myDic
  
  '情報出力用ワークシート追加
  Set wbk = ThisWorkbook
  Set newSheet = wbk.Worksheets.Add(before:=Sheets(1))
  For Each sh In wbk.Worksheets
    If sh.name Like "Analysis[0-9][0-9]" Then
      tempNo = CLng(Right(sh.name, 2))
      If tempNo > shNo Then shNo = tempNo
    End If
  Next sh
  
  If shNo = 0 Then
    newSheet.name = "Analysis01"
  Else
    newSheet.name = "Analysis" & Format(shNo + 1, "00")
  End If
  
  'データベース情報
  Set mycell = newSheet.Range("A1")
  colLabelArray = Array("Database Information", "Value")
  With mycell
    For i = 0 To UBound(colLabelArray)
      .Offset(, i).Value = colLabelArray(i)
      .Offset(, i).Interior.Color = myColor
    Next i
    .Offset(1, 0).Value = "Database Name": .Offset(1, 1).Value = currentDbInfo.title
    .Offset(2, 0).Value = "File Name": .Offset(2, 1).Value = currentDbInfo.fileName
    .Offset(3, 0).Value = "Database File Path": .Offset(3, 1).Value = currentDbInfo.path
    .Offset(4, 0).Value = "Server Name": .Offset(4, 1).Value = currentDbInfo.server
  End With
  
  '開いている文書のUniversalID取得、後で文書特定に使用する
  currentDocUid = getCurrentDocUid
  
  'COMでNotesのセッションを開く
  password = "" '環境に合わせる、パスワードが必要な場合は、設定しておかないと都度ダイアログで訊いてくる。
  Set session = CreateObject("Lotus.Notessession")
  session.Initialize password
  
  Set notesDB = session.GetDatabase(serverName, notesDbName)
  'ここではCurrentDocumentから取得しているので、notesDB.IsOpenは通常True
  If Not notesDB.IsOpen Then notesDB.Open
  
  Set notesDoc = notesDB.GetDocumentByUNID(currentDocUid)
  items = notesDoc.items
  Set item = items(0)
  Debug.Print item.name
  
  'Designerは入手したけれど、Notesのデータベースの一つも作らずに、VBAから覗いているだけですが、
  'Notesのデータベースの構造はAccessのそれとは相当異なる様に思えてきました
  'NotesのデータはAccessの様にTableに分かれて入っている訳でなく、横並びに入って居て、
  'Record中に対応するFormの情報を持たせている様です。（持っていない場合もありそう）
  'FormのFieldと、対応するDocumentのitemは一般には合致するが、していない場合もあり、数も一致しない。
  'VBAから操作する分にはFormのFieldに対応するitemだけで十分に思えます。
  
  'フォーム情報
  Set mycell = newSheet.Range("D1")
  colLabelArray = Array("Form Information", "Alias")
  With mycell
    For i = 0 To UBound(colLabelArray)
      .Offset(, i).Value = colLabelArray(i)
      .Offset(, i).Interior.Color = myColor
    Next i
  End With
  forms = notesDB.forms
  For i = LBound(forms) To UBound(forms)
    mycell.Offset(i + 1, 0).Value = forms(i).name
    aliases = forms(i).aliases
    If Not IsEmpty(aliases) Then
      mycell.Offset(i + 1, 1).Value = aliases(0)
    End If
    'FormのField情報のリストをセルのコメントに出力
     myComment = ""
    With mycell.Offset(i + 1, 0)
      .AddComment
      .Comment.Visible = False
      For j = 0 To UBound(form.Fields)
        If myComment = "" Then
          myComment = form.Fields(j)
        Else
          myComment = myComment & Chr(10) & form.Fields(j)
        End If
      Next j
      .Comment.Text Text:=myComment
    End With   
  Next i

  'view情報
  Set mycell = newSheet.Range("G1")
  colLabelArray = Array("View Information")
  With mycell
    For i = 0 To UBound(colLabelArray)
      .Offset(, i).Value = colLabelArray(i)
      .Offset(, i).Interior.Color = myColor
    Next i
  End With
  views = notesDB.views
  For i = LBound(views) To UBound(views)
    mycell.Offset(i + 1, 0).Value = views(i).name
  Next i
  
  'Document情報
  Set notesDoc = notesDB.GetDocumentByUNID(currentDocUid)
  Set mycell = newSheet.Range("I1")
  colLabelArray = Array("Item", "Type", "TypeName", "Values Length")
  With mycell
    For i = 0 To UBound(colLabelArray)
      .Offset(, i).Value = colLabelArray(i)
      .Offset(, i).Interior.Color = myColor
    Next i
  End With
  
  'その後、「同じDocument」であっても、item数が異なる事例にぶつかった。下記Ubond(items)が文書により異なる。
  '従って、下記の様な番号で指定する方法は確実では無い。
  'NotesのDocumentの場合、NotesDocument.GetFirstItem(itemName)で取得する必要がある。
  'MsXML等のGetFirstItemとは用法が異なるので注意。文書中に同じ名前のitemが存在する事が許され、
  'それを取得するにはGetNextItem(itemName)を用いるんだと。なんだかね。
  
  items = notesDoc.items
  For i = LBound(items) To UBound(items)
    With items(i)
      itemValues = .Values
      mycell.Offset(i + 1, 0).Value = .name
      mycell.Offset(i + 1, 1).Value = .Type
      mycell.Offset(i + 1, 2).Value = myDic(CStr(.Type))
      
      'この部分（配列か否か）は文書それぞれで異なる可能性もある。動的に変わる可能性もあるので留意の事。
      If IsArray(itemValues) Then
        mycell.Offset(i + 1, 3).Value = UBound(itemValues)
      Else
        mycell.Offset(i + 1, 3).Value = "Not Array"
      End If
    End With
  Next i
  
  newSheet.Columns("A:L").AutoFit
  
errHandle:
  If Err.Number <> 0 Then
    Debug.Print Err.Number & Err.Description & Err.Source
    
  End If
  On Error GoTo 0
  On Error Resume Next
  Set session = Nothing
  
End Sub

Function getCurrentDbInfo(myDbInfo As dbInfo) As Boolean
  Dim ws As Object
  Dim uidoc As Object, doc As Object
  Dim db As Object
  
  On Error GoTo errHandle
  Set ws = CreateObject("Notes.NotesUIWorkspace")
  Set uidoc = ws.CURRENTDOCUMENT
  If uidoc Is Nothing Then
    'msgbox "No Notes Document Open!"
    GoTo errHandle
  End If
  Set doc = uidoc.Document
  Set db = doc.ParentDatabase
  With myDbInfo
    .title = db.title
    .fileName = db.fileName
    .path = db.FilePath
    .server = db.server
  End With
  getCurrentDbInfo = True
  
errHandle:
  If Err.Number <> 0 Then
    Debug.Print Err.Number & Err.Description & Err.Source
    getCurrentDbInfo = False
  End If
  
  On Error GoTo 0
  On Error Resume Next
  Set doc = Nothing
  Set uidoc = Nothing
  Set ws = Nothing
End Function

Function getCurrentDocUid() As String
  Dim ws As Object
  Dim uidoc As Object, doc As Object
  
  On Error GoTo errHandle
  Set ws = CreateObject("Notes.NotesUIWorkspace")
  Set uidoc = ws.CURRENTDOCUMENT
  If uidoc Is Nothing Then
    'msgbox "No Notes Document Open!"
    GoTo errHandle
  End If
  Set doc = uidoc.Document

  getCurrentDocUid = doc.UniversalID
  
errHandle:
  If Err.Number <> 0 Then
    Debug.Print Err.Number & Err.Description & Err.Source
    getCurrentDocUid = ""
  End If
  
  On Error GoTo 0
  On Error Resume Next
  Set doc = Nothing
  Set uidoc = Nothing
  Set ws = Nothing
End Function

'notestypeと記述を紐付けるためのDictionary設定
Sub setDictionary(myDic As Object)
 '中身は上述
End Sub
コンテンツリストに戻る 


Const EMBED_ATTACHMENT As Integer = 1454

'*********************************************************************************
'完全自動で送るコード
'出典：http://homepage3.nifty.com/belie/vba/vba033.htm
'送信ボックスに履歴が残らない。
'*********************************************************************************


Public Sub SendNotesMail()
    Dim wkNSes As Object    ' lotus.NOTESSESSION
    Dim wkNDB As Object     ' lotus.NOTESDATABASE
    Dim wkNDoc As Object    ' lotus.NOTESDOCUMENT
    Dim wkNRtItem As Object ' lotus.NOTESRICHTEXTITEM
    Dim wkNAtt As Object    ' lotus.NOTESEMBEDDEDOBJECT
    Dim AttFName As String  ' 添付ファイル名(フルパス)

    ' Notesのセッションを起動する
    Set wkNSes = CreateObject("Notes.NotesSession")
    ' NotesDatabaseオブジェクトを作成し、そのデータベースを開く
    Set wkNDB = wkNSes.GETDATABASE("", "")
    ' NotesDBをユーザーのメールDBに割り当てた後に開く
    wkNDB.OpenMail

    ' NotesDBに文書を作成し、新規文書をオブジェクト変数にセットする
    Set wkNDoc = wkNDB.CREATEDOCUMENT()
    ' 件名をセットする
    wkNDoc.Subject = "テスト(タイトル)"
    ' 宛先をセットする
    wkNDoc.SendTo = Array("abc@def.ghi.com")
    'wkNDoc.CopyTo = Array("xxx@xxx")
    'wkNDoc.blindCopyTo = Array("xxx@xxx")

    ' 文書にリッチテキストアイテムを作成する
    Set wkNRtItem = wkNDoc.CreateRichTextItem("BODY")
    ' 本文をセットする
    With wkNRtItem
        .APPENDTEXT "本文（１行目）"
        .ADDNEWLINE 1
        .APPENDTEXT "本文（２行目）"
        .ADDNEWLINE 2
        ' 添付ファイル名をセットする
        AttFName = getDesktopPath & "\Book1.xlsx"
        ' ファイルを添付する
        Set wkNAtt = .EmbedObject(EMBED_ATTACHMENT, "", AttFName)
        .ADDTAB 1
        .ADDNEWLINE 1
    End With

    ' メールを送信する
    wkNDoc.Send False

    ' オブジェクト変数を解放する
    Set wkNAtt = Nothing
    Set wkNRtItem = Nothing
    Set wkNDoc = Nothing
    Set wkNDB = Nothing
    Set wkNSes = Nothing

    MsgBox "メール発信", vbOKOnly + vbInformation
End Sub

'*********************************************************************************
'いきなり送りつけずに、編集状態にする様に改造
'一旦確認してから送ると、送信ボックスに残るメリットあり。
'*********************************************************************************

Public Sub makeNotesMail()
    Dim wkNSes As Object    ' lotus.NOTESSESSION
    Dim wkNDB As Object     ' lotus.NOTESDATABASE
    Dim wkNDoc As Object    ' lotus.NOTESDOCUMENT
    Dim wkNRtItem As Object ' lotus.NOTESRICHTEXTITEM
    Dim wkNAtt As Object    ' lotus.NOTESEMBEDDEDOBJECT
    Dim AttFName As String  ' 添付ファイル名(フルパス)
    '追加
    Dim ws As Object 'NotesUIWorkspace
    Dim uidoc As Object
    
    ' Notesのセッションを起動する
    Set wkNSes = CreateObject("Notes.NotesSession")
    '追加
    Set ws = CreateObject("Notes.NotesUIWorkspace")
    
    ' NotesDatabaseオブジェクトを作成し、そのデータベースを開く
    Set wkNDB = wkNSes.GETDATABASE("", "")
    ' NotesDBをユーザーのメールDBに割り当てた後に開く
    wkNDB.OpenMail

    ' NotesDBに文書を作成し、新規文書をオブジェクト変数にセットする
    Set wkNDoc = wkNDB.CREATEDOCUMENT()
    ' 件名をセットする
    wkNDoc.Subject = "テスト(タイトル)"
    ' 宛先をセットする
    wkNDoc.SendTo = Array("abc@def.ghi.com")
    'wkNDoc.CopyTo = Array("xxx@xxx")
    'wkNDoc.blindCopyTo = Array("xxx@xxx")

    ' 文書にリッチテキストアイテムを作成する
    Set wkNRtItem = wkNDoc.CreateRichTextItem("BODY")
    ' 本文をセットする
    ' VBAでやる場合は、普通に文字列bufとかに、vbCrLfを介して文字を入れてやって
    ' wkNRtItem.APPENDTEXT buf で一丁上がり
    
    With wkNRtItem
        .APPENDTEXT "本文（１行目）"
        .ADDNEWLINE 1
        .APPENDTEXT "本文（２行目）"
        .ADDNEWLINE 2
        ' 添付ファイル名をセットする
        AttFName = getDesktopPath & "\Book1.xlsx"
        ' ファイルを添付する
        Set wkNAtt = .EmbedObject(EMBED_ATTACHMENT, "", AttFName)
        .ADDTAB 1
        .ADDNEWLINE 1
    End With
    ' メールを保存する。これをやらないとRichItemの編集が表示されない
    wkNDoc.Save False, False
    ' メールを編集状態にする
    Set uidoc = ws.EDITDOCUMENT(True, wkNDoc, False)

    ' オブジェクト変数を解放する
    Set wkNAtt = Nothing
    Set wkNRtItem = Nothing
    Set wkNDoc = Nothing
    
    Set uidoc = Nothing
    
    Set wkNDB = Nothing
    Set wkNSes = Nothing
    
    Set ws = Nothing

End Sub


'デスクトップのパスを取得
Private Function getDesktopPath() As String
    Dim Path As String, WSH As Variant
    Set WSH = CreateObject("Wscript.Shell")
    getDesktopPath = WSH.SpecialFolders("Desktop") & "\"
    Set WSH = Nothing
End Function