none
Why is my SharePoint List locking? RRS feed

  • Question

  • HI Folks -

    I have the following Function that updates a SharePoint List.  For some reason, when an update is determined and needs to update the SharePoint list, it claims it's locked:

    "Cannot update. Database or object is read-only."  My function is below - can you see anything wrong with this? The lline where it locks is 115.

    Function Update_RD_PFR_3LEVEL_List()
    On Error Resume Next
        
        Dim dbs As DAO.Database
        Dim sRS As DAO.Recordset
        Dim tRS As DAO.Recordset
        Dim tRSMV As DAO.Recordset
        Dim fld As DAO.Field2
        
        Dim sTable As String
        Dim tTable As String
        Dim strTempTable As String
           
        Dim tgtStr, srcStr As String
        Dim vStr() As String
        Dim tFlds, sFlds, vCriteria As String
        Dim tFld() As String
        Dim sFld() As String
        
        Dim i, z As Integer
        Dim strMask As String
        
        Set ws = DBEngine.Workspaces(0)
        Set dbs = ws.Databases(0)
        
        On Error GoTo Proc_Err
        
        'Start a transaction to ensure all updates are run or rolled back
        ws.BeginTrans: strTFlag = 1
        
        strFunctName = "Update_RD_PFR_3LEVEL_List"
        strMask = "PFP*"
        sTable = "MDM_Project_Portfolio_Reference": strTempTable = "LT" & sTable
        tTable = "RD_PFR_3LEVEL_List"
        strFlag = ""
           
        tFlds = "[Name],[Parent_Node],[Alias],[Alliance_Partner],[Direct_Flag],[IP_Owner],[Modality],[Modality_Detail],[Pass_Through],[Portfolio_Status],[PTS_Region],[Pool_Target]," & _
                "[ASC_CMC_MODEL_T],[ASC_DEV_MODEL_T],[ASC_PRD_MODEL_T],[PrePostCS],[TA],[ProjectType],[ASC_GAO_MODEL_I],[Research_Code]," & _
                "[PRD_DDU],[Time_Tracking],[MOA],[Alternate_Name],[Fin_Alloc_Target],[Finance_TA_Grouping],[Target_Long_Name],[Target_Short_Name]," & _
                "[Mechanism],[Business_Owner],[IR-Disclosure],[Lead_Backup_Indicator],[Lead_Backup_Asset_Compound],[Indication]" & _
                ",[Parent_Alias],[Grandparent_Node],[Grandparent_Alias]"
        sFlds = "[Name],[Parent Node],[Alias],[Partner_Alias_Link],[Direct Flag],[IP Owner],[Modality],[Modality_Detail],[Pass Through],[Portfolio Status],[PTS Region],[Pool - Target Property]," & _
                "[ASC_CMC_MODEL_T],[ASC_DEV_MODEL_T],[ASC_PRD_MODEL_T],[PrePostCS],[PF_TherapeuticArea],[ProjectType],[ASC_GAO_MODEL_I],[PF_Research_Code]," & _
                "[PRD_DDU],[Time_Tracking],[MOA],[Alternate_Name],[Fin_Alloc_Target],[Finance_TA_Grouping],[Target Long Name],[Target_Short_Name]," & _
                "[Mechanism],[Business_Owner],[IR - Disclosure],[Lead_Backup_Indicator],[Lead_Backup_Asset_Compound],[Indication]" & _
                ",[Parent_Alias],[Grand Parent],[GrandParent_Alias]"

        strTList = "": strSList = ""
        strTQryR = Replace(tFlds, strTList, ""): strSQryR = Replace(sFlds, strSList, "")
     
        strFldsQry = sTable & Replace(sFlds, ",", ", " & "[" & sTable & "].")
        strFldsQry = Replace(strFldsQry, sTable & "[Name]", "[" & sTable & "]" & "." & "[" & "Name" & "]")
        
        tFld = Split(tFlds, ",")
        sFld = Split(sFlds, ",")
        
        strStep = "Step 1 : Purge [" & tTable & "] of records that have moved to Development rollup"
        strSQL = "" & _
                "DELETE FROM [" & tTable & "]" & _
                "WHERE NOT EXISTS (SELECT 1" & _
                                   " FROM [" & sTable & "]" & _
                                   " WHERE [" & sTable & "].[Name] = [" & tTable & "].[Name]" & _
                                     " AND [" & sTable & "].[Parent Node] = [" & tTable & "].[Parent_Node]" & _
                                   ")"
        dbs.Execute strSQL, dbFailOnError
        strSQL = ""
               
        strStep = "Step 2 : Add New Data Elements"
        strSQL = "" & _
                "INSERT INTO [" & tTable & "] (" & _
                    tFlds & _
                " )" & _
                " SELECT" & _
                    strFldsQry & _
                " FROM [" & sTable & "]" & _
                "LEFT JOIN [" & tTable & "] ON [" & tTable & "].[Name] = [" & sTable & "].[Name]" & _
                " WHERE [" & sTable & "].[Name] LIKE '*" & strMask & "*'" & _
                    " AND [" & sTable & "].[Parent Node] LIKE 'PFR-*'" & _
                    " AND [" & tTable & "].[Name] IS NULL;"
        dbs.Execute strSQL, dbFailOnError
        strStep = ""
              
        'Clear Variables
        strStep = "": srcStr = "": tgtStr = ""

        'Open a table-type Recordset
        Set sRS = dbs.OpenRecordset("Select * from [" & sTable & "] where [Name] like """ & strMask & """", dbOpenDynaset)
        Set tRS = dbs.OpenRecordset("qry_Last_Modified_Activity_PFR")
            
        Do Until tRS.EOF
        
            srcStr = "": tgtStr = ""
            
                vCriteria = "Name = '" & tRS.Fields("Name").Value & "'"
                sRS.MoveFirst
                sRS.FindFirst vCriteria

                'Do Standard field mapping property updates
                For i = 0 To UBound(tFld)
                
                    'Set fld to check .IsComplex property
                    Set fld = tRS(tFld(i))
                    
                    strStep = "Update Data Element Attributes" & vbNewLine & vbNewLine & _
                              "Data Element - " & Nz(tRS.Fields("Name").Value, "") & vbNewLine & _
                              "Source Field - " & Nz(sFld(i), "") & vbNewLine & _
                              "Source Value - " & Nz(sRS.Fields(sFld(i)).Value, "") & vbNewLine & _
                              "Target Field - " & Nz(tFld(i), "") & vbNewLine & _
                              "Target Value - " & Nz(tRS.Fields(tFld(i)).Value, "")

                    'Ignore MVF Attributes
                    If Not fld.IsComplex Then
                        If Nz(tRS.Fields(tFld(i)).Value, "foo") <> Nz(sRS.Fields(sFld(i)).Value, "foo") Then
                            tRS.Edit
                            tRS.Fields(tFld(i)).Value = sRS.Fields(sFld(i)).Value
                            tRS.Update
                        End If
                    Else
                        'Process MVF Attributes
                        tRS.Edit
                        Set tRSMV = tRS(tFld(i)).Value
                        
                        tgtStr = ""
                        Erase vStr
                         
                        'Concatenate the multiple values in a single string
                        Do Until tRSMV.EOF
                            tRSMV.MoveFirst
                                Do Until tRSMV.EOF
                                    tgtStr = tgtStr + tRSMV!Value.Value + ","
                                    tRSMV.MoveNext
                                Loop
                        Loop
                        If Not tgtStr = "" Then
                            tgtStr = Mid(tgtStr, 1, Len(tgtStr) - 1)
                            tRSMV.MoveFirst
                        End If
        
                        'Compare the concatenated strings
                        If Nz(sRS.Fields(sFld(i)).Value, "") <> tgtStr Then
                            Do Until tRSMV.EOF
                                tRSMV.MoveFirst
                                    Do Until tRSMV.EOF
                                        tRSMV.Delete
                                        tRSMV.MoveNext
                                    Loop
                            Loop
                            
                            If Nz(sRS.Fields(sFld(i)).Value, "") <> "" Then
                                vStr = Split(sRS.Fields(sFld(i)).Value, ",")
        
                                For z = 0 To UBound(vStr)
                                   tRSMV.AddNew
                                   tRSMV.Fields(0).Value = vStr(z)
                                   tRSMV.Update
                                Next
                            End If
                        End If
                        tRS.Update
                     End If
                Next
            tRS.MoveNext
        Loop
        
        'commit all changes
        ws.CommitTrans: strTFlag = 0
        
        Set sRS = Nothing
        Set tRS = Nothing
        Set tRSMV = Nothing

    Proc_Exit:

        Set ws = Nothing
        Set dbs = Nothing
        Exit Function

    Proc_Err:

        If Len(strStep) > 0 Then
            EmailStep = strStep & vbNewLine & vbNewLine
        Else
            EmailStep = ""
        End If
        
        strSubject = "WARNING : Function '" & strFunctName & "' Failed"
        strBody = strSubject & vbNewLine & vbNewLine & _
                  EmailStep & _
                  "Profile : " & CurrentUser() & vbNewLine & vbNewLine & _
                  "VB Module : " & Application.VBE.ActiveCodePane.CodeModule.name & vbNewLine & vbNewLine & _
                  "VB Error : " & Err.Description
        strTo = "name"
        Call MDM_Routines.Email_Utility(strSubject, strBody, strTo, "", "")
        
        If strTFlag = 1 Then ws.Rollback
        
        Resume Proc_Exit
        
    End Function


    Tuesday, April 28, 2020 4:38 PM