Access VBA附件已锁定

问题描述

我正在使用带有链接的共享点表的访问数据库。 用户可以通过GUI中的附件控件（ms访问表单）将文件附加到共享点列表项。 也有VBA代码将文件附加到共享点列表附件。

我遇到错误3218“无法更新；无法更新。记录锁定”。

我假设附件控件的“访问”对话框正在锁定共享点列表。如果用户曾经打开对话框，则vba代码将在执行后抛出命名异常，因为vba函数无法编辑记录集。

经过数小时的故障排除后，我发现，如果通过“取消”按钮而非“确定”按钮取消了附件字段的对话框，则附件字段将“解锁”共享点表。

TL; DR似乎不可能通过用户输入和vba代码同时将文件附加到附件字段。

是否可以通过编程方式“解锁”共享记录集？ 感谢您的提前帮助！

这是我很久以前在www中发现的便捷的vba函数。这有点hacky。这些评论最初是德语的，我只是与Google进行了翻译，以更好地理解。

Function StoreBLOB2007 (strFilename As String,strTable As String,strFieldAttach As String,_
                       Optional boolEdit As Boolean,Optional strIDField As String,_
                       Optional varID As Variant,Optional strAttachment As String) As Boolean
    Dim fld2 As DAO.Field2
    Dim rstDAO As DAO.Recordset2
    Dim rstACCDB As DAO.Recordset2

    On Error GoTo ErrHandler
    
    Set rstDAO = CurrentDb.OpenRecordset ("SELECT * FROM [" & strTable & "]",dbOpenDynaset)
    If boolEdit Then
        If IsNull (varID) Then Err.Raise vbObjectError + 1,"No record ID specified!"
        rstDAO.FindFirst "CStr ([" & strIDField & "]) = '" & CStr (varID) & "'"
        If rstDAO.NoMatch Then Err.Raise vbObjectError + 2,"Data record with ID" & varID & "not found!"
        rstDAO.Edit
    Else
        rstDAO.AddNew
    End If
    
    Set rstACCDB = rstDAO (strFieldAttach) .Value
    If boolEdit Then
        If rstACCDB.EOF Then 'Case 1: There are no attachments yet; > new plant
            rstACCDB.AddNew
        Else
            Do While Not rstACCDB.EOF
                Debug.Print rstACCDB! FileName
                rstACCDB.MoveNext
            Loop
            rstACCDB.FindFirst "[FileName] = '" & strAttachment & "'"
            'Case2: There is no attachment with the name in sAttachment:> new attachment
            'Case 3: system found; then edit
            If rstACCDB.NoMatch Then rstACCDB.AddNew Else rstACCDB.Edit
        End If
    Else
        rstACCDB.AddNew
    End If
    
    Set fld2 = rstACCDB.Fields! FileData
    On Error Resume Next
    fld2.LoadFromFile (strFilename)
If Err.Number = -2146697202 Then 'Illegal file extension! Special treatment ...
        On Error GoTo ErrHandler
        Name strFilename As strFilename & ".dat" 'First append the file with the permitted extension ".dat"
        fld2.LoadFromFile (strFilename & ".dat") 'Load file
        Name strFilename & ".dat" As strFilename 'Undo renaming
        rstACCDB.Fields! FileName = Mid (strFilename,InStrRev (strFilename,"\") + 1) 'Set the system name
        rstACCDB.Update
    Else
        On Error GoTo ErrHandler
        rstACCDB.Update
    End If
    rstDAO.Update
    StoreBLOB2007 = True 'Return True = Everything ok.

Finally:
    On Error Resume Next
    rstACCDB.Close
    rstDAO.Close
    Set rstACCDB = Nothing
    Set rstDAO = Nothing
    Set fld2 = Nothing
    Exit function

ErrHandler:
    MsgBox Err.Description,vbCritical
    Resume Finally
End Function

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）