ms-access自动添加附件

问题描述 投票:0回答:0

好吧,所以我被困在这里...

我有带有字段“打印”和附件的 tblParts。 打印字段填充有指向 .pdf 打印件的超链接。

我正在尝试创建一个宏来使用路径来创建附件。

这是我到目前为止想出的...

以下数据类型 enter image description here 一切正常,直到:

   Set Attach = rs("Field1")
   If Not IsNull(Attach.Value) Then
      Attach.LoadFromFile attachmentPath      'this line is giving an error Invalid field data type.
   Else
      Attach.Value = base64Data
   End If

其余代码如下... 谢谢你的帮助。

Option Compare Database
Option Explicit

Public Sub UpdateAttachments()
Dim rs As DAO.Recordset
Dim attachmentPath As String
Dim attachmentData() As Byte
Dim hyperlinkPath As String
Dim filePath As String
Dim Attach As DAO.Field2

Set rs = CurrentDb.OpenRecordset("tblParts")

'Loop through each record in the table
Do Until rs.EOF
    'Get the hyperlink path from the "Print" column
    hyperlinkPath = rs("Print")
   
    'Extract the file path from the hyperlink
    filePath = hyperlinkPath
    filePath = Mid(filePath, 10)
    filePath = Replace(filePath, "%20", " ")
    filePath = Replace(filePath, "#", "")
    attachmentPath = filePath
   
   'Read the binary data from the file
   Open attachmentPath For Binary As #1
   ReDim attachmentData(LOF(1))
   Get #1, , attachmentData
   Close #1
   
   'Encode the binary data in Base64 format
   Dim base64Data As String
   base64Data = EncodeBase64(attachmentData)
   
    'Update the "Field1" attachment with the Base64-encoded data
    rs.Edit
    Set Attach = rs("Field1")
    If Not IsNull(Attach.Value) Then
        Attach.LoadFromFile attachmentPath
    Else
        Attach.Value = base64Data
    End If
    rs.Update
   
    'Move to the next record
    rs.MoveNext
Loop

rs.Close
Set rs = Nothing
End Sub

Private Function EncodeBase64(data() As Byte) As String
    Dim objXML As MSXML2.DOMDocument60
    Dim objNode As MSXML2.IXMLDOMElement
   
    Set objXML = New MSXML2.DOMDocument60
    Set objNode = objXML.createElement("b64")
   
    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = data
   
    EncodeBase64 = objNode.Text
   
    Set objNode = Nothing
    Set objXML = Nothing
End Function
vba ms-access ms-access-2016
© www.soinside.com 2019 - 2024. All rights reserved.