Intermittent failure of VBA query of SharePoint to get filenames in doc library

[mike.magill]

Hi. This a problem that has been bugging me for some time. I have a spreadsheet that a number of people use in different organisations (i.e. with different Office 365 accounts). Part of the code, which I have extracted and shown below and attached View attachment SharePoint File List Import v1.xlsm works fine most of the time but fails intermittently.

I think it has to do either with permissions to the SharePoint site, periodic enforced changes to user passwords, or that I will run the routine sometimes (and I have a different main Office 365 account) and then another user tries to run it again. I'm sorry if that doesn't make much sense.

I'm not particularly confident with the coding of queries and hope someone on here can help me make this routine more reliable.

Many thanks,

Mike

Option Explicit

Sub RefreshFileList()
    
    Application.ScreenUpdating = False
    
    Call DeleteQueries
    Call SharePointQuery
    
    MsgBox "Done"


    Application.ScreenUpdating = True
    
End Sub


Private Sub DeleteQueries()


    With ThisWorkbook
        'Delete any previously created connection and query in the workbook.
        On Error Resume Next
            .Connections.Item("Connection").Delete
            ActiveWorkbook.Queries.Item("SharePoint File Query").Delete
        On Error GoTo 0
    End With
        
    'Delete the four columns that would hold the File_List table
    'if it existed.
    Sheet1.Range("F:I").EntireColumn.Delete


End Sub


Private Sub SharePointQuery()


    Dim QueryName As String     'Holds the name of the query
    Dim FilePath As String      'Holds the Parsed SharePoint file path
    Dim FilePathPart1 As String 'Holds the first part of the file path
    Dim FilePathPart2 As String 'Holds the second part of the file path
    Dim NoOfSlashes As Integer  'Holds the number of slashes in the file path
    
    'Truncate the file location and assign to the two
    'FilePath variables.
    FilePath = ParseSharePointURL(Sheet1.Range("File_Location").Value)
    NoOfSlashes = Len(FilePath) - Len(Replace(FilePath, "/", ""))
    FilePathPart1 = Left(FilePath, Application.WorksheetFunction.Find(Chr(135), Application.WorksheetFunction.Substitute(FilePath, "/", Chr(135), NoOfSlashes - 1)))
    FilePathPart2 = Replace(Mid(FilePath, Len(FilePathPart1) + 1, Len(FilePath) - Len(FilePathPart1) - 1), "%20", " ")


    'Define the name of the query.
    QueryName = "SharePoint File Query"
    
    'Creat a new query that looks on SharePoint for files that have
    'the .xlsx extension and creates a table with the file name and
    'date modified.
    ActiveWorkbook.Queries.Add Name:= _
        QueryName, Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = SharePoint.Contents(""" & FilePathPart1 & """, [ApiVersion = 15])," & Chr(13) & "" & Chr(10) & "    #""" & FilePathPart2 & """ = Source{[Name=""" & FilePathPart2 & """]}[Content]," & Chr(13) & "" & Chr(10) & "    #""Filtered Rows"" = Table.SelectRows(#""" & FilePathPart2 & """, each ([Extension] = "".xlsx""))," & Chr(13) & "" & Chr(10) & "    #""Removed Other Columns"" = Table.SelectColumns(#""Filtered Rows"",{""Name""})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Removed Other Columns"""
    
    Sheet1.Activate
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & QueryName _
        , Destination:=Range("$F$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array( _
        "SELECT * FROM [" & QueryName & "]")
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SaveData = True
        .ListObject.DisplayName = "File_List"
        On Error Resume Next
        .Refresh BackgroundQuery:=False
    End With


End Sub


Function ParseSharePointURL(SharePointURL As String)
'Reduces the length of the URL if it has /Forms/
'towards the end.


    If InStr(UCase(SharePointURL), "/FORMS/") <> 0 Then
        ParseSharePointURL = Left(SharePointURL, InStr(UCase(SharePointURL), "/FORMS/"))
    Else
        ParseSharePointURL = SharePointURL
    End If
    
End Function