Question

我正在运行MS Access 2010.使用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字段。事实上，.Value字段的Attachment是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

Here is what I ended up doing.

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

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

2 个答案: