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
