Google Drive - Web Share Link

[DanielWise]

I currently use excel 2016 on both Mac and PC... and I only need to be able to know the web share Link of a specific file whose folder is known where it is located within a Google Drive account.

From what I have consulted on the web, some google API can be used but I cannot understand how to do it. Might you help me?

 

[John_w]

This can be done with the Google Drive API and quite a lot of code. You first have to create a project for the Google account in the Google Cloud Console, enable the Google Drive API and copy the credentials (client_id and client_secret) into the code below.

This code is written for a file in a top-level folder in Google Drive. I don't know what changes would be needed, if any, for a subfolder.

Option Explicit


#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If


Public Type GoogleRegistrationType
    client_id As String
    client_secret As String
    redirect_uri As String
End Type

Public Type GoogleOAuthType
    code_verifier As String
    authorisation_code As String
    token_type As String
    access_token As String
    refresh_token As String
    expires_in As String
    expires_at As Date
End Type


Public Sub Get_WebLink_From_Google_Drive()

    Dim GoogleDataSheet As Worksheet
    Dim GoogleReg As GoogleRegistrationType
    Dim GoogleOAuth As GoogleOAuthType
    Dim fileId As String
    Dim webViewLink As String
    
    'Settings copied from the project's APIs & Services -> Credentials screen in Google Cloud Console
    
    GoogleReg.client_id = "YOUR CLIENT_ID STRING"  'CHANGE THIS
    GoogleReg.client_secret = "YOUR CLIENT_SECRET STRING"  'CHANGE THIS
    GoogleReg.redirect_uri = "urn:ietf:wg:oauth:2.0:oob"
        
    'The Google OAuth authorisation code and tokens are read from or written to Sheet1
    
    Set GoogleDataSheet = ThisWorkbook.Worksheets("Sheet1")
    
    Load_OAuth_Data GoogleOAuth, GoogleDataSheet
    
    If GoogleOAuth.authorisation_code = "" Then
        GoogleOAuth.code_verifier = RandomString(43)
        GoogleOAuth.authorisation_code = IE_Request_Auth_Code(GoogleReg, GoogleOAuth.code_verifier)
    End If
    
    If GoogleOAuth.authorisation_code <> "" Then
    
        If GoogleOAuth.access_token = "" Then
            'Request access token and refresh token
            Request_Access_Token GoogleOAuth, GoogleReg
        ElseIf Has_Token_Expired(GoogleOAuth) Then
            'Access token has expired, so request a new one
            Refresh_Access_Token GoogleOAuth, GoogleReg
        End If
            
        Save_OAuth_Data GoogleOAuth, GoogleDataSheet
        
        fileId = Find_File_In_Folder("Your folder name", "Your file name.ext", GoogleOAuth)  'CHANGE THIS
            
        If fileId <> "" Then
            webViewLink = Get_WebViewLink(fileId, GoogleOAuth)
            MsgBox "webViewLink = " & webViewLink
        End If
        
    End If
    
End Sub


Private Function Find_File_In_Folder(folderName As String, findFileName As String, OAuth As GoogleOAuthType) As String

    'Find the specified file in the specified folder and return its fileId
    'https://developers.google.com/drive/v3/reference/files/list
    
    Dim URL As String
    Dim folderId As String
    
    Find_File_In_Folder = ""
    
    'Find the folder and get its id
    
    URL = "https://www.googleapis.com/drive/v3/files?q=" & Encode("mimeType='application/vnd.google-apps.folder' and name='" & folderName & "'")
    
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .setRequestHeader "Authorization", OAuth.token_type & " " & Encode(OAuth.access_token)
        .setRequestHeader "Accept", "application/json"
        .Send
        Debug.Print .responseText
        If .Status = 200 Then
            'Extract folder id from JSON response and find the file in this folder
            folderId = GetJSONvalue(.responseText, "id")
            URL = "https://www.googleapis.com/drive/v3/files?q=" & Encode("name='" & findFileName & "' and '" & folderId & "' in parents")
            .Open "GET", URL, False
            .setRequestHeader "Authorization", OAuth.token_type & " " & Encode(OAuth.access_token)
            .setRequestHeader "Accept", "application/json"
            .Send
            Debug.Print .responseText
            If .Status = 200 Then
                'Extract file id from JSON response
                Find_File_In_Folder = GetJSONvalue(.responseText, "id")
            Else
                MsgBox "Find_File_In_Folder error " & .Status & vbCr & .statusText & vbCrLf & .responseText
            End If
        Else
            MsgBox "Find_File_In_Folder error " & .Status & vbCr & .statusText & vbCrLf & .responseText
        End If
    End With
          
End Function


Private Function Get_WebViewLink(fileId As String, OAuth As GoogleOAuthType) As String

    'Get the webViewLink for the specified fileId
    'https://developers.google.com/drive/api/guides/fields-parameter
    
    Dim URL As String
    
    URL = "https://www.googleapis.com/drive/v3/files/" & fileId & "?fields=webViewLink"
    
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .setRequestHeader "Authorization", OAuth.token_type & " " & Encode(OAuth.access_token)
        .setRequestHeader "Accept", "application/json"
        .Send
        Debug.Print .responseText
        If .Status = 200 Then
            'Extract field value from JSON response
            Get_WebViewLink = GetJSONvalue(.responseText, "webViewLink")
        Else
            MsgBox "Get_WebViewLink error " & .Status & vbCr & .statusText & vbCrLf & .responseText
        End If
    End With
    
End Function


Private Function IE_Request_Auth_Code(GoogleReg As GoogleRegistrationType, code_verifier As String) As String

    Dim params As String
    Dim p As Long
       
    'Open IE on project's OAuth consent screen and ask user to allow access to the Google Account's Drive files and return the authorisation code
    'The https://www.googleapis.com/auth/drive.readonly scope allows user to see and download Google Drive files.
    
    IE_Request_Auth_Code = ""
    
    params = "?client_id=" & Encode(GoogleReg.client_id) & _
             "&redirect_uri=" & Encode(GoogleReg.redirect_uri) & _
             "&response_type=code" & _
             "&scope=" & Encode("https://www.googleapis.com/auth/drive.readonly") & _
             "&code_challenge=" & code_verifier & _
             "&code_challenge_method=plain" & _
             "&state=VBA_" & Format(Now, "YYYY-MM-DD_HHMMSS")

    With CreateObject("InternetExplorer.Application")
        .Visible = True
        .navigate "https://accounts.google.com/o/oauth2/v2/auth" & params
        While .Busy Or .readyState <> 4: DoEvents: Sleep 250: Wend
        Do
            DoEvents
            Sleep 500
        Loop Until InStr(1, .LocationURL, "&approvalCode", vbTextCompare) > 0 Or _
                   InStr(1, .LocationURL, "access_denied", vbTextCompare) > 0
        If InStr(1, .LocationURL, "&approvalCode", vbTextCompare) > 0 Then
            'Extract approvalCode from URL
            IE_Request_Auth_Code = Split(.LocationURL, "&approvalCode=")(1)
            p = InStr(IE_Request_Auth_Code, "&")
            If p > 0 Then IE_Request_Auth_Code = Left(IE_Request_Auth_Code, p - 1)
            Debug.Print "approvalCode = " & IE_Request_Auth_Code
        End If
        .Quit
    End With
    
End Function


Private Sub Request_Access_Token(ByRef OAuth As GoogleOAuthType, GoogleData As GoogleRegistrationType)

    'Request an access_token and a refresh_token using the authorisation_code previously obtained
    
    'https://developers.google.com/identity/protocols/oauth2/native-app#exchange-authorization-code

    Dim URL As String
    Dim postData As String

    OAuth.access_token = ""
    
    URL = "https://oauth2.googleapis.com/token"
    
    postData = "client_id=" & GoogleData.client_id & _
               "&client_secret=" & GoogleData.client_secret & _
               "&code=" & OAuth.authorisation_code & _
               "&code_verifier=" & OAuth.code_verifier & _
               "&grant_type=authorization_code" & _
               "&redirect_uri=" & GoogleData.redirect_uri

    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", URL, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .Send (postData)      'brackets are required for late binding of XMLhttp object
        Debug.Print .responseText
        If .Status = 200 Then
            'Extract field values from JSON response
            OAuth.token_type = GetJSONvalue(.responseText, "token_type")
            OAuth.access_token = GetJSONvalue(.responseText, "access_token")
            OAuth.refresh_token = GetJSONvalue(.responseText, "refresh_token")
            OAuth.expires_in = GetJSONvalue(.responseText, "expires_in")
            OAuth.expires_at = DateAdd("s", OAuth.expires_in, Now)
        Else
            MsgBox "Request_Access_Token error " & .Status & vbCr & .statusText & vbCrLf & .responseText
        End If
    End With
        
End Sub


Private Sub Refresh_Access_Token(ByRef OAuth As GoogleOAuthType, GoogleData As GoogleRegistrationType)

    'Request a new access_token
    
    'https://developers.google.com/identity/protocols/oauth2/native-app#offline

    Dim URL As String
    Dim postData As String
    
    URL = "https://accounts.google.com/o/oauth2/token"

    postData = "refresh_token=" & OAuth.refresh_token & _
               "&client_id=" & GoogleData.client_id & _
               "&client_secret=" & GoogleData.client_secret & _
               "&grant_type=refresh_token"
            
    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", URL, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .Send (postData)      'brackets are required for late binding of XMLhttp object
        If .Status = 200 Then
            'Extract field values from JSON response
            OAuth.token_type = GetJSONvalue(.responseText, "token_type")
            OAuth.access_token = GetJSONvalue(.responseText, "access_token")
            OAuth.expires_in = GetJSONvalue(.responseText, "expires_in")
            OAuth.expires_at = DateAdd("s", OAuth.expires_in, Now)
        Else
            MsgBox "Refresh_Access_Token error " & .Status & vbCr & .statusText
        End If
    End With

End Sub


Private Function Has_Token_Expired(OAuth As GoogleOAuthType) As Boolean

    'Return True if current time is after or within 60 seconds of token_expires_at time
    
    If OAuth.expires_at = 0 Then
        Has_Token_Expired = True
    ElseIf OAuth.expires_at < Now Then
        Has_Token_Expired = True
    ElseIf DateAdd("s", -60, Now) >= OAuth.expires_at Then
        Has_Token_Expired = True
    Else
        Has_Token_Expired = False
    End If
    
End Function


Private Sub Save_OAuth_Data(OAuth As GoogleOAuthType, ws As Worksheet)

    'Save OAuth data in cells in the specified worksheet
    
    With ws
        .Range("A1:B1").Value = Array("code_verifier", OAuth.code_verifier)
        .Range("A2:B2").Value = Array("authorisation_code", OAuth.authorisation_code)
        .Range("A3:B3").Value = Array("token_type", OAuth.token_type)
        .Range("A4:B4").Value = Array("access_token", OAuth.access_token)
        .Range("A5:B5").Value = Array("refresh_token", OAuth.refresh_token)
        .Range("A6:B6").Value = Array("expires_in", OAuth.expires_in)
        If OAuth.expires_in <> "" Then
            .Range("A7:B7").Value = Array("expires_at", DateAdd("s", CDbl(OAuth.expires_in), Now))
        End If
        .Columns("A").AutoFit
    End With

End Sub


Private Sub Load_OAuth_Data(ByRef OAuth As GoogleOAuthType, ws As Worksheet)

    'Retrieve OAuth data from cells in the specified worksheet

    With ws
        OAuth.code_verifier = .Range("B1").Value
        OAuth.authorisation_code = .Range("B2").Value
        OAuth.token_type = .Range("B3").Value
        OAuth.access_token = .Range("B4").Value
        OAuth.refresh_token = .Range("B5").Value
        OAuth.expires_in = .Range("B6").Value
        If .Range("B7").Value = "" Then
            OAuth.expires_at = 0
        Else
            OAuth.expires_at = .Range("B7").Value
        End If
    End With
    
End Sub


Private Function Encode(ByVal param As String) As String
    Encode = Application.WorksheetFunction.EncodeURL(param)
End Function


Private Function RandomString(num As Long) As String

    Dim chars As String
    Dim i As Long
    
    Randomize
    chars = "abcdefghijklmnopqrstuvwxyz"
    chars = UCase(chars) & "0123456789"
    
    For i = 1 To num
        RandomString = RandomString & Mid$(chars, Int(Rnd() * Len(chars) + 1), 1)
    Next

End Function


Private Function GetJSONvalue(JSONstring As String, paramName As String) As String

    'Extract a parameter value from a JSON string

    Dim p1 As Long, p2 As Long
    
    p1 = InStr(JSONstring, Chr(34) & paramName & Chr(34) & ": ")
    If p1 > 0 Then
        p1 = p1 + Len(Chr(34) & paramName & Chr(34) & ": ")
        p2 = InStr(p1, JSONstring, ",")
        If p2 = 0 Then p2 = InStr(p1, JSONstring, vbLf)
        GetJSONvalue = Mid(JSONstring, p1, p2 - p1)
        GetJSONvalue = Replace(GetJSONvalue, Chr(34), "")
        Debug.Print paramName & " = " & GetJSONvalue
    End If
    
End Function