NotesメールDBを添付ファイルを含めAccessDBに取り込み

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function GetCurrentProcess Lib "kernel32" () As Long
Declare Function SetPriorityClass Lib "kernel32" (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long

'優先順位クラスフラグ
Const HIGH_PRIORITY_CLASS = &H80&
Const IDLE_PRIORITY_CLASS = &H40&
Const NORMAL_PRIORITY_CLASS = &H20&
Const REALTIME_PRIORITY_CLASS = &H100&
'Notes EMBEDDEDOBJECTの種類
Const EMBED_ATTACHMENT = 1454
Const EMBED_OBJECT = 1453
Const EMBED_OBJECTLINK = 1452


Sub getMailMain()
    Dim session As Object, DB As Object
    Dim server As String, mailFile As String, user As String, usersig As String
    Dim view As Object
    'Access
    Dim AccDB As DAO.Database
    Dim rs As DAO.Recordset
    Dim myDate As Date 'strUpdateで重複チェック
    Dim strWhere As String 'Dcountのcriteria
    Dim currentMailDB As Boolean '現在のメールボックスか
    
    '処理実行の優先度を下げる(表で別の仕事をするため）
    Call SetPriorityClass(GetCurrentProcess, IDLE_PRIORITY_CLASS)
    currentMailDB = False
    sendFlag = True
    
    Set session = CreateObject("Notes.NotesSession")
    If currentMailDB Then
      '現役のメールボックスの場合
      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
    Else
      'アーカイブの場合
      mailFile = "D:\mail\hoge.nsf"
      server = ""
      Set DB = session.GetDatabase(server, mailFile)
      If Not DB.IsOpen Then DB.Open
    End If
    'NotesにViewが更新されず、削除したメールが見かけ上残るバグあり
    'Shift-F9で更新後に実行する事(RebuildをOLEで行う方法が分からない）
    Set view = DB.GETVIEW("($Sent)")
    view.Refresh
    getMailSub view
    Set view = DB.GETVIEW("($Inbox)")
    view.Refresh
    getMailSub view

    Set session = Nothing
    '処理実行の優先度を元に戻す
    Call SetPriorityClass(GetCurrentProcess, NORMAL_PRIORITY_CLASS)
    '最前面に表示させるためWSHを使用
    CreateObject("WScript.Shell").PopUp "処理終了しました", , , vbSystemModal
End Sub

Sub getMailSub(view As Object, Optional subjectCriteria As String)
    Dim AcDB As DAO.Database
    Dim items As Variant, docs As Variant
    Dim doc As Object, item As Object, RichTextBody As Object
    Dim i As Long, j As Long
    Dim buf As Variant, attaches As Variant, attach As Object
    'Access
    Dim rs As DAO.Recordset
    Dim myDate As Date 'strUpdateで重複チェック
    Dim strWhere As String 'Dcountのcriteria
    Dim subjectHitFlag As Boolean 'Subjectが検索対象文字列を含むか否かのフラグ
    Dim mySubject As String
    Dim FSO As Object
    
    Const destDrive As String = "D:\"
       
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set AcDB = CurrentDb()
    Set rs = AcDB.OpenRecordset("T_mail")
    Set doc = view.GETFIRSTDOCUMENT
    Do Until doc Is Nothing
      subjectHitFlag = False
      'Subjectにより判断する
      buf = doc.getfirstitem("Subject").Values
      mySubject = buf(0)
      If subjectCriteria = vbNullString Then
        subjectHitFlag = True
      Else
        If InStr(mySubject, subjectCriteria) > 0 Then subjectHitFlag = True
      End If
      
      buf = doc.getfirstitem("PostedDate").Values
      myDate = buf(0)
      strWhere = "[strPosted] = " & "'" & CStr(myDate) & "'"
      '主キーが登録済みでなければAddNew。Updateは今後の課題
      If DCount("[strPosted]", "T_mail", strWhere) = 0 And subjectHitFlag Then
        rs.AddNew
        rs!strPosted = CStr(myDate)
        rs!PostedDate = myDate
        rs!Subject = mySubject
        'SendToがなく、BCCのみのメールが存在する
        If Not doc.getfirstitem("SendTo") Is Nothing Then
          buf = doc.getfirstitem("SendTo").Values
          rs!SendTo = buf(0)
        End If
        buf = doc.getfirstitem("From").Values
        rs!From = buf(0)
        
        If view.Name = "($Sent)" Then
          rs!sendFlag = True
        Else
          rs!sendFlag = False
        End If
        
        Set RichTextBody = doc.getfirstitem("Body")
        'Bodyが無いメールがあるのでその対策を追加
        If Not RichTextBody Is Nothing Then
          rs!Body = RichTextBody.Text
          If doc.HASEMBEDDED Then
            attaches = Empty
            If IsArray(RichTextBody.EMBEDDEDOBJECTS) Then attaches = RichTextBody.EMBEDDEDOBJECTS
            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 destDrive & attach.Name
                  'Access2007からの添付ファイル型および複数の値を持つフィールドは、そのフィールドの中に
                  'レコードセットを保持している感じである。
                  With rs.Fields("attach").Value
                    .AddNew
                     On Error Resume Next
                     '.lnkファイルは 3058 インデックスまたは主キーには、NULL 値を使用できませんというエラーになる
                     'その他少数のファイルで、同様のエラーで添付できないものがあるが原因不明。
                    .Fields("FileData").LoadFromFile destDrive & attach.Name
                    .Update
                     If Err.Number <> 0 Then
                      Debug.Print "Attach Err", attach.Name, Err.Number, Err.Description
                       .CancelUpdate
                     End If
                     On Error GoTo 0
                  End With
                  '海外からの文字化けファイル名のファイルをKillで消せない事がある様だ
                  'FSO に期待して書き換えてみた　効果は不明
'                  On Error Resume Next
'                  Kill "D:\" & attach.Name
'                  On Error GoTo 0
                  On Error Resume Next
                  FSO.DeleteFile destDrive & attach.Name
                  If Err.Number <> 0 Then Debug.Print "Delete Err", attach.Name, Err.Number, Err.Description
                  On Error GoTo 0
                  Set attach = Nothing
                End If
              Next i
            End If 'isArray
          End If 'HASEMBEDDED
        End If 'RichTextBody
        DoEvents: DoEvents: DoEvents
        rs.Update
      End If 'Dcount
      
      Set doc = view.GETNEXTSIBLING(doc)
      Sleep 10
    Loop
    
    On Error Resume Next
    Set rs = Nothing
    Set FSO = Nothing
    Set AcDB = Nothing
End Sub