Google Drive - Web Share Link

DanielWise

New Member
Joined
Aug 28, 2023
Messages
3
Office Version
  1. 2016
Platform
  1. Windows
  2. MacOS
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?
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
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.

VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,224,823
Messages
6,181,182
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top