使用VBA將Outlook附件保存在MS Access中

Question

我正在運行MS Access2010。使用VBA我試圖將附件從MS Exchange 2013中拉出並將其插入到Access表“ TBL_APPT_ATTACHMENT”中。

表“ TBL_APPT_ATTACHMENT”如下所示：Attachment_title備注Attachment_filename備注Attachment_blob OLE對象

一切似乎都能正常工作，只是我無法弄清楚如何將實際文件保存到ATTACHMENT_BLOB列中。 這是我正在調用的VBA函數（請參見下面的問號）。

Private Function createRecord(fItem As Outlook.AppointmentItem)

  Set rsAtt = CurrentDb.OpenRecordset("TBL_APPT_ATTACHMENT")
  rsAtt.OpenRecordset

  For Each Attachment In fItem.Attachments
    Call MsgBox("FileName: " & Attachment.FileName, vbOKOnly, "Error")
    Call MsgBox("DisplayName: " & Attachment.DisplayName, vbOKOnly, "Error")
    Call MsgBox("Index: " & Attachment.Index, vbOKOnly, "Error")

    rsAtt.AddNew
    rsAtt!APPT_ITEM_ID = aID
    rsAtt!APPT_FIELD_id = rsOl!ID
    rsAtt!ATTACHMENT_TITLE = Attachment.DisplayName
    rsAtt!ATTACHMENT_FILENAME = Attachment.FileName
    rsAttID = rsAtt!ID
    rsAtt.Update

    'Save file to harddrive.
    filePath = "c:\temp\" + Attachment.FileName
    Attachment.SaveAsFile (filePath)

    Set rsParent = CurrentDb.OpenRecordset("SELECT ID, ATTACHMENT_BLOB FROM TBL_APPT_ATTACHMENT WHERE ID = " & rsAttID)
    rsParent.OpenRecordset
    Do While Not rsParent.EOF
      rsParent.Edit

      'Load file into Database.

'???  This next statement gives me a "Type Mismatch" error.  Why?????
      Set rsChild = rsParent.Fields("ATTACHMENT_BLOB").Value

      rsChild.AddNew
      rsChild.Fields("FileData").LoadFromFile (filePath)
      rsChild.Update
      rsParent.Update
      rsParent.MoveNext
    Loop
  Next
End Function

謝謝！！

Answer 1

請記住，附件實際上是一個文件（無論它是否是OLE對象）。 雖然可以將對象從Outlook復制粘貼到Access中，但我的建議是將附件另存為文件：

dim filepath as String
dim filename as String
filepath = "C:\appropriatefolder\"
filename = Attachment.FileName
Attachment.SaveAsFile filepath & filename

現在您可以將附件保存在Access中，但是我嚴重不建議使用附件字段類型。 使用起來可能非常棘手。 因此，針對同一問題的解決方案是創建一個類型為Hyperlink的字段。 然后，您在宏中的語句將簡單地為：

rsAtt!ATTACHMENT_LINK = filename & "#" & filepath & filename

超鏈接定義很重要，並使用以下格式：

displayString # fullPathToFile [ # optionalPositionInsideFile ]

編輯：在訪問中使用附件字段類型

如果您將Access表中的Attachment字段類型視為單個記錄中的嵌入式recordset ，則可以理解。 因此，每次添加新記錄（或讀取現有記錄）時，都必須對“ Attachment字段進行一些不同的處理。 實際上， Attachment字段的.Value是recordset本身。

Option Compare Database
Option Explicit

Sub test()
    AddAttachment "C:\Temp\DepTree.txt"
End Sub

Sub AddAttachment(filename As String)
    Dim tblAppointments As DAO.Recordset
    Dim attachmentField As DAO.Recordset
    Dim tblField As Field

    Set tblAppointments = CurrentDb.OpenRecordset("TBL_APPT_ATTACHMENT", dbOpenDynaset)

    tblAppointments.AddNew
    tblAppointments![APPT_ITEM_ID] = "new item id"
    tblAppointments![APPT_FIELD_ID] = "new field id"
    tblAppointments![ATTACHMENT_TITLE] = "new attachment"
    tblAppointments![ATTACHMENT_FILENAME] = filename

    '--- the attachment field itself is a recordset, because you can add multiple
    '    attachments to this single record. so connect to the recordset using the
    '    .Value of the parent record field, then use it like a recordset
    Set attachmentField = tblAppointments![ATTACHMENT_BLOB].Value
    attachmentField.AddNew
    attachmentField.Fields("FileData").LoadFromFile filename
    attachmentField.Update

    tblAppointments.Update

    tblAppointments.Close
    Set tblAppointments = Nothing
End Sub

Answer 2

這就是我最終要做的。

Private Function createRecord(fItem As Outlook.AppointmentItem)

  Set rsAtt = CurrentDb.OpenRecordset("TBL_APPT_ATTACHMENT")
  rsAtt.OpenRecordset

  For Each Attachment In fItem.Attachments

    'Save file to harddrive.
    filePath = "c:\temp\" + Attachment.FileName
    Attachment.SaveAsFile (filePath)

    rsAtt.AddNew
    rsAtt!APPT_ITEM_ID = aID
    rsAtt!APPT_FIELD_id = rsOl!ID
    rsAtt!ATTACHMENT_TITLE = Attachment.DisplayName
    rsAtt!ATTACHMENT_FILENAME = Attachment.FileName

    Call FileToBlob(filePath, rsAtt!ATTACHMENT_BLOB)

    rsAttID = rsAtt!ID
    rsAtt.Update

  Next
End Function

Public Function FileToBlob(strFile As String, ByRef Field As Object)
    On Error GoTo FileToBlobError

    If Len(Dir(strFile)) > 0 Then
        Dim nFileNum As Integer
        Dim byteData() As Byte

        nFileNum = FreeFile()
        Open strFile For Binary Access Read As nFileNum
        If LOF(nFileNum) > 0 Then
            ReDim byteData(1 To LOF(nFileNum))
            Get #nFileNum, , byteData
            Field = byteData
        End If
    Else
        MsgBox "Error: File not found", vbCritical, _
               "Error reading file in FileToBlob"
    End If

  FileToBlobExit:
    If nFileNum > 0 Then Close nFileNum
    Exit Function

  FileToBlobError:
    MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, _
           "Error reading file in FileToBlob"
    Resume FileToBlobExit

End Function