kiến thức [Excel VBA] (Linh tinh) Xác thực OAuth2 để triển khai các dịch vụ của Google trên Excel

NguyenDang95

Senior Member
Chào mọi người. Tối thứ bảy cuối tuần, rảnh rỗi không có việc gì làm nên đành lên đây viết bài chia sẻ với anh em. Trong lúc không biết nên viết về chủ đề gì, tự dưng mình nhớ lại yêu cầu của một thím trên này hỏi mình về việc viết macro VBA tương tác với Google Drive. Thật ra trước đây mình có viết một bài về chủ đề này: https://voz.vn/t/office-vba-chia-se...-macro-vba-tuong-tac-voi-google-drive.639260/, tuy nhiên giải pháp này chủ yếu viết bằng ngôn ngữ C# dựa vào thư viện .NET được Google viết sẵn, việc này đòi hỏi nhiều bước cài đặt COM DLL nhiêu khê. Vậy chúng ta có thể viết chương trình tự động tương tác với Google Drive nói chung và các dịch vụ của Google nói riêng bằng giải pháp thuần VBA không? Với nội dung dưới đây, câu trả lời có lẽ là "có".

Nhìn chung, việc viết macro VBA xác thực OAuth2 thì khá rắc rối. Trên internet cũng đã có nhiều giải pháp như của tác giả timhall: https://github.com/VBA-tools/VBA-Web/blob/master/authenticators/OAuth2Authenticator.cls. Tựu trung, việc xác thực gồm các bước như sau:
  • Căn cứ theo tài liệu từ phía Google, tiến hành viết một class module để xử lý chung và tái sử dụng code nhiều lần
  • Mở trình duyệt web (hầu hết các ví dụ trên internet đều sử dụng Internet Explorer), hiển thị trang để người dùng đăng nhập và tiến hành cấp quyền cho macro tiếp tục chạy
  • Lưu trữ access token, refresh token vào một chỗ nào đó để tiện dùng về sau và đảm bảo tính bảo mật
  • Dùng access token được cấp trong quyền hạn được giao bởi người dùng để tương tác với các dịch vụ của Google
Căn cứ vào trình tự nêu trên, trong bài viết này đề xuất một giải pháp khác.

Đầu tiên, với trường hợp nhiều máy tính có thể đang chạy Windows 11 không còn được cài đặt Internet Explorer, chúng ta sẽ tạo một UserForm với một WebBrowser (thực chất là Internet Explorer), UserForm này chỉ có nhiệm vụ hoạt động như một trình duyệt web để người dùng có thể đăng nhập và cấp quyền truy cập cho macro vào tài nguyên của tài khoản người dùng.

1668864613081.png


1668866553608.png


Phần việc chính:

Class Module: GoogleOAuth2 đảm nhận việc xác thực OAuth2, lấy, lưu trữ access token cũng như lấy access token mới thông qua refresh token cứ sau mỗi 60 phút.

Code:
Option Explicit

Private m_ApplicationName As String
Private m_ClientId As String
Private m_ClientSecret As String
Private m_Scope As Variant

Public Property Get ApplicationName() As String
    ApplicationName = m_ApplicationName
End Property

Public Property Let ApplicationName(Value As String)
    m_ApplicationName = Value
End Property

Public Property Get ClientID() As String
    ClientID = m_ClientId
End Property

Public Property Let ClientID(Value As String)
    m_ClientId = Value
End Property

Public Property Get ClientSecret() As String
    ClientSecret = m_ClientSecret
End Property

Public Property Let ClientSecret(Value As String)
    m_ClientSecret = Value
End Property

Public Property Get Scope() As Variant
    Scope = m_Scope
End Property

Public Property Let Scope(Value As Variant)
    m_Scope = Value
End Property

Public Function AuthorizeOAuth2() As String
    Dim objWinHttp As WinHttp.WinHttpRequest
    Dim strRequestBody As String
    Dim strURL As String
    Dim objBrowser As UserForm1
    Dim objReg As RegistryUtility
    Dim strAuthorizationCode As String
    Dim objFSO As Scripting.FileSystemObject
    Dim objFolder As Scripting.Folder
    Dim objFile As Scripting.TextStream
    Dim strFolder As String
    Dim strFile As String
    Dim strAccessToken As String
    Dim objJson As Scripting.Dictionary
    Dim dteExpTime As Date
    Dim strRefreshToken As String
    strFolder = Environ$("APPDATA") & "\" & ApplicationName
    strFile = strFolder & "\google-oauth2.token-response"
    Set objReg = New RegistryUtility
    Set objFSO = New Scripting.FileSystemObject
    If objFSO.FolderExists(strFolder) Then
        Set objFolder = objFSO.GetFolder(strFolder)
        If objFSO.FileExists(strFile) Then
            dteExpTime = CDate(objReg.ReadRegKey("HKEY_CURRENT_USER\Software\GoogleOAuth2VBA\AccessTokenExpirationTime"))
            If VBA.DateDiff("s", Now, dteExpTime) <= 0 Then
                Set objFile = objFSO.OpenTextFile(strFile, ForReading, False)
                Set objJson = JsonConverter.ParseJson(objFile.ReadAll)
                objFile.Close
                strRefreshToken = objJson.Item("refresh_token")
                AuthorizeOAuth2 = RefreshAccessToken(strRefreshToken)
            Else
                Set objFile = objFSO.OpenTextFile(strFile, ForReading, False)
                Set objJson = JsonConverter.ParseJson(objFile.ReadAll)
                objFile.Close
                AuthorizeOAuth2 = objJson.Item("access_token")
            End If
        Else: AuthorizeOAuth2 = GetAccessToken
        End If
    Else
        Set objFolder = objFSO.CreateFolder(strFolder)
        AuthorizeOAuth2 = GetAccessToken
    End If
    Set objWinHttp = Nothing
    Set objReg = Nothing
    Set objFSO = Nothing
    Set objFolder = Nothing
    Set objFile = Nothing
    Set objJson = Nothing
End Function

Private Function GetAccessToken() As String
    Dim objBrowser As UserForm1
    Dim objWinHttp As WinHttp.WinHttpRequest
    Dim strURL As String
    Dim strRequestBody As String
    Dim strAuthorizationCode As String
    Dim strFile As String
    Dim strFolder As String
    Dim strAccessToken As String
    Dim objReg As RegistryUtility
    Dim objJson As Scripting.Dictionary
    Dim objFSO As Scripting.FileSystemObject
    Dim objFile As Scripting.TextStream
    Set objFSO = New Scripting.FileSystemObject
    Set objReg = New RegistryUtility
    Set objBrowser = New UserForm1
    strFolder = Environ$("APPDATA") & "\" & ApplicationName
    strFile = strFolder & "\google-oauth2.token-response"
    strURL = "https://accounts.google.com/o/oauth2/v2/auth?scope=" & URLEncode(Join(Scope, " ")) & "&access_type=offline&include_granted_scopes=true&response_type=code&state=state_parameter_passthrough_value&redirect_uri=https://localhost&client_id=" & ClientID
    objBrowser.WebBrowser1.Navigate strURL
    objBrowser.Show vbModal
    If objReg.RegKeyExists("HKEY_CURRENT_USER\Software\GoogleOAuth2VBA\AuthorizationCode") Then
        strAuthorizationCode = CStr(objReg.ReadRegKey("HKEY_CURRENT_USER\Software\GoogleOAuth2VBA\AuthorizationCode"))
    End If
    If strAuthorizationCode <> vbNullString Then
        strRequestBody = "code=" & strAuthorizationCode & "&" & _
                        "client_id=" & ClientID & "&" & _
                        "client_secret=" & ClientSecret & "&" & _
                        "redirect_uri=https://localhost&" & _
                        "grant_type=authorization_code"
        Set objWinHttp = New WinHttp.WinHttpRequest
        With objWinHttp
            .Open "POST", "https://oauth2.googleapis.com/token", False
            .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .SetRequestHeader "Accept", "application/json'"
            .Send strRequestBody
            If .Status = 200 Then
                Set objJson = JsonConverter.ParseJson(.ResponseText)
                strAccessToken = objJson.Item("access_token")
                If strAccessToken <> vbNullString Then
                    GetAccessToken = strAccessToken
                    Set objFile = objFSO.CreateTextFile(strFile)
                    objFile.Write .ResponseText
                    objFile.Close
                    objReg.RegKeyWrite "HKEY_CURRENT_USER\Software\GoogleOAuth2VBA\AccessTokenExpirationTime", CStr(DateAdd("s", CDbl(objJson.Item("expires_in")), Now)), REG_SZ
                Else: Err.Raise vbObjectError + 2, , "Invalid authorization code"
                End If
            End If
        End With
    Else
        Err.Raise vbObjectError + 1, , "Failed to obtain the authorization code."
    End If
    Set objWinHttp = Nothing
    Set objJson = Nothing
    Set objReg = Nothing
    Set objFSO = Nothing
    Set objFile = Nothing
End Function

Private Function RefreshAccessToken(RefreshToken As String) As String
    Dim objWinHttp As WinHttp.WinHttpRequest
    Dim objJson As Scripting.Dictionary
    Dim strRequestBody As String
    Dim strFolder As String
    Dim strFile As String
    Dim objReg As RegistryUtility
    strRequestBody = "client_id=" & ClientID & "&" & _
                    "client_secret=" & ClientSecret & "&" & _
                    "refresh_token=" & RefreshToken & "&" & _
                    "grant_type=refresh_token"
    Set objWinHttp = New WinHttp.WinHttpRequest
    With objWinHttp
        .Open "POST", "https://oauth2.googleapis.com/token"
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .SetRequestHeader "Accept", "application/json'"
        .Send strRequestBody
        If .Status = 200 Then
            Set objJson = JsonConverter.ParseJson(.ResponseText)
            strFolder = Environ$("APPDATA") & "\" & ApplicationName
            strFile = strFolder & "\google-oauth2.token-response"
            Call SaveNewAccessToken(strFile, objJson.Item("access_token"))
            RefreshAccessToken = objJson.Item("access_token")
            Set objReg = New RegistryUtility
            objReg.RegKeyWrite "HKEY_CURRENT_USER\Software\GoogleOAuth2VBA\AccessTokenExpirationTime", CStr(DateAdd("s", CDbl(objJson.Item("expires_in")), Now)), REG_SZ
        End If
    End With
    Set objWinHttp = Nothing
    Set objJson = Nothing
    Set objReg = Nothing
End Function

Private Sub SaveNewAccessToken(AccessTokenFile As String, NewAccessToken As String)
    Dim objFSO As Scripting.FileSystemObject
    Dim objFile As Scripting.TextStream
    Dim strText As String, strOldText As String, strNewText As String
    strNewText = Chr(34) & "access_token" & Chr(34) & ": " & Chr(34) & NewAccessToken & Chr(34) & ","
    Set objFSO = New Scripting.FileSystemObject
    Set objFile = objFSO.OpenTextFile(AccessTokenFile)
    objFile.SkipLine
    strOldText = objFile.ReadLine
    objFile.Close
    Set objFile = objFSO.OpenTextFile(AccessTokenFile)
    strText = objFile.ReadAll
    objFile.Close
    strText = VBA.Replace(strText, strOldText, strNewText, , , vbTextCompare)
    Set objFile = objFSO.OpenTextFile(AccessTokenFile, ForWriting)
    objFile.Write strText
    objFile.Close
    Set objFSO = Nothing
    Set objFile = Nothing
End Sub

Public Function URLDecode(ByVal strIn As String) As String
    On Error Resume Next
    Dim sl&, tl&, key$, kl&
    sl = 1:    tl = 1: key = "%": kl = Len(key)
    sl = InStr(sl, strIn, key, 1)
    Do While sl > 0
        If (tl = 1 And sl <> 1) Or tl < sl Then
            URLDecode = URLDecode & Mid(strIn, tl, sl - tl)
        End If
        Dim hh$, hi$, hl$, a$
        Select Case UCase(Mid(strIn, sl + kl, 1))
            Case "U"    'Unicode URLEncode
                a = Mid(strIn, sl + kl + 1, 4)
                URLDecode = URLDecode & ChrW("&H" & a)
                sl = sl + 6
            Case "E"    'UTF-8 URLEncode
                hh = Mid(strIn, sl + kl, 2)
                a = Int("&H" & hh)    'ascii?
                If Abs(a) < 128 Then
                    sl = sl + 3
                    URLDecode = URLDecode & Chr(a)
                Else
                    hi = Mid(strIn, sl + 3 + kl, 2)
                    hl = Mid(strIn, sl + 6 + kl, 2)
                    a = ("&H" & hh And &HF) * 2 ^ 12 Or ("&H" & hi And &H3F) * 2 ^ 6 Or ("&H" & hl And &H3F)
                    If a < 0 Then a = a + 65536
                    URLDecode = URLDecode & ChrW(a)
                    sl = sl + 9
                End If
            Case Else    'Asc URLEncode
                hh = Mid(strIn, sl + kl, 2)    '??
                a = Int("&H" & hh)    'ascii?

                If Abs(a) < 128 Then
                    sl = sl + 3
                Else
                    hi = Mid(strIn, sl + 3 + kl, 2)    '??
                    'a = Int("&H" & hh & hi) '?ascii?
                    a = (Int("&H" & hh) - 194) * 64 + Int("&H" & hi)
                    sl = sl + 6
                End If
                URLDecode = URLDecode & ChrW(a)
        End Select
        tl = sl
        sl = InStr(sl, strIn, key, 1)
    Loop
    URLDecode = URLDecode & Mid(strIn, tl)
End Function

Public Function URLEncode(ByRef txt As String) As String
    Dim buffer As String, i As Long, c As Long, n As Long
    buffer = String$(Len(txt) * 12, "%")
 
    For i = 1 To Len(txt)
        c = AscW(Mid$(txt, i, 1)) And 65535
 
        Select Case c
            Case 48 To 57, 65 To 90, 97 To 122, 45, 46, 95  ' Unescaped 0-9A-Za-z-._ '
                n = n + 1
                Mid$(buffer, n) = ChrW(c)
            Case Is <= 127            ' Escaped UTF-8 1 bytes U+0000 to U+007F '
                n = n + 3
                Mid$(buffer, n - 1) = Right$(Hex$(256 + c), 2)
            Case Is <= 2047           ' Escaped UTF-8 2 bytes U+0080 to U+07FF '
                n = n + 6
                Mid$(buffer, n - 4) = Hex$(192 + (c \ 64))
                Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
            Case 55296 To 57343       ' Escaped UTF-8 4 bytes U+010000 to U+10FFFF '
                i = i + 1
                c = 65536 + (c Mod 1024) * 1024 + (AscW(Mid$(txt, i, 1)) And 1023)
                n = n + 12
                Mid$(buffer, n - 10) = Hex$(240 + (c \ 262144))
                Mid$(buffer, n - 7) = Hex$(128 + ((c \ 4096) Mod 64))
                Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
                Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
            Case Else                 ' Escaped UTF-8 3 bytes U+0800 to U+FFFF '
                n = n + 9
                Mid$(buffer, n - 7) = Hex$(224 + (c \ 4096))
                Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
                Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
        End Select
    Next
    URLEncode = Left$(buffer, n)
End Function

Class Module: RegistryUtility dùng để viết giá trị Authorization Code (do chỉ dùng một lần nên không cần phải bảo mật) với thời gian dự kiến access token sẽ hết hạn vào khóa registry tại HKEY_CURRENT_USER\Software\GoogleOAuth2VBA:

Code:
Option Explicit

Private objWShell As IWshRuntimeLibrary.WshShell
Public Enum KeyType
    REG_SZ = 0
    REG_DWORD = 1
    REG_EXPAND_SZ = 2
    REG_BINARY = 3
End Enum

Private Sub Class_Initialize()
    Set objWShell = New IWshRuntimeLibrary.WshShell
End Sub

Private Sub Class_Terminate()
    Set objWShell = Nothing
End Sub

Public Function ReadRegKey(key As String) As Variant
    ReadRegKey = objWShell.RegRead(key)
End Function

Public Sub DeleteRegKey(key As String)
    objWShell.RegDelete key
End Sub

Public Sub RegKeyWrite(key As String, Value As Variant, KeyType As KeyType)
    Dim strKeyType As String
    Select Case KeyType
        Case REG_SZ: strKeyType = "REG_SZ"
        Case REG_DWORD: strKeyType = "REG_DWORD"
        Case REG_EXPAND_SZ: strKeyType = "REG_EXPAND_SZ"
        Case REG_BINARY: strKeyType = "REG_BINARY"
    End Select
    objWShell.RegWrite key, Value, strKeyType
End Sub

Public Function RegKeyExists(key As String) As Boolean
    On Error Resume Next
    Dim varKeyValue As Variant
    varKeyValue = objWShell.RegRead(key)
    If Err.Number <> 0 Then
        Err.Clear
        RegKeyExists = False
    Else: RegKeyExists = True
    End If
End Function

Ví dụ: Lấy danh sách các thư mục có trong thư mục gốc trên Google Drive của người dùng:

1668867319246.png


Code:
Option Explicit

Private Sub ListFoldersInDriveRootFolder()
    Dim objGoogleOAuth2 As GoogleOAuth2
    Dim strAccessToken As String
    Dim objWinHttp As WinHttp.WinHttpRequest
    Dim objFSO As Scripting.FileSystemObject
    Dim objFile As Scripting.TextStream
    Dim objJson As Scripting.Dictionary
    Set objGoogleOAuth2 = New GoogleOAuth2
    Set objFSO = New Scripting.FileSystemObject
    ' Tep JSON chua client_id va client_secret
    Set objFile = objFSO.OpenTextFile("E:\Data\client_secret_919574922950-bbr59m90nbmfv118uv6unon7k33j6p0b.apps.googleusercontent.com.json", ForReading)
    Set objJson = JsonConverter.ParseJson(objFile.ReadAll)
    objFile.Close
    With objGoogleOAuth2
        .ApplicationName = "TestGoogleDrive"
        .ClientID = objJson.Item("installed")("client_id")
        .ClientSecret = objJson.Item("installed")("client_secret")
        .Scope = Array("https://www.googleapis.com/auth/drive.file", "https://www.googleapis.com/auth/drive")
        strAccessToken = .AuthorizeOAuth2
    End With
    Set objWinHttp = New WinHttp.WinHttpRequest
    With objWinHttp
        .Open "GET", "https://www.googleapis.com/drive/v3/files?q=" & objGoogleOAuth2.URLEncode("'root' in parents and mimeType = 'application/vnd.google-apps.folder' and trashed = false")
        .SetRequestHeader "Authorization", "Bearer " & strAccessToken
        .SetRequestHeader "Accept", "application/json'"
        .Send
        If .Status = 200 Then
            Debug.Print .ResponseText
        Else: MsgBox "An error occurred"
        End If
    End With
    Set objGoogleOAuth2 = Nothing
    Set objWinHttp = Nothing
    Set objFSO = Nothing
    Set objFile = Nothing
    Set objJson = Nothing
End Sub

Kết quả:

1668867467531.png


Tham khảo:
OAuth 2.0 for Mobile & Desktop Apps
Search for files and folders
 

Attachments

  • GoogleOAuth2VBA.zip
    93.2 KB · Views: 51
Sau khi đã viết xong các bước chuẩn bị trên, chúng ta bắt tay vào thực hiện một ví dụ.
Tạo một tệp Excel với một số chức năng như sau:
  • Quản lý tập tin, thư mục trong một thư mục nhất định trên Google Drive với những chức năng cơ bản như tải lên, tải xuống tập tin, đổi tên, xóa vĩnh viễn tập tin/thư mục.
  • Tạo email, tải tệp đính kèm lên thư mục trong Google Drive và lấy shareable link đưa vào email mới tạo.
  • Tiến trình tải lên/tải xuống tập tin được ghi nhận ở thanh Status Bar của Excel (góc trái dưới cùng)
1670125198760.png


Video mô phỏng:
 

Attachments

  • GoogleDriveVBASample.zip
    218.7 KB · Views: 52
Last edited:
Chào mọi người. Tối thứ bảy cuối tuần, rảnh rỗi không có việc gì làm nên đành lên đây viết bài chia sẻ với anh em. Trong lúc không biết nên viết về chủ đề gì, tự dưng mình nhớ lại yêu cầu của một thím trên này hỏi mình về việc viết macro VBA tương tác với Google Drive. Thật ra trước đây mình có viết một bài về chủ đề này: https://voz.vn/t/office-vba-chia-se...-macro-vba-tuong-tac-voi-google-drive.639260/, tuy nhiên giải pháp này chủ yếu viết bằng ngôn ngữ C# dựa vào thư viện .NET được Google viết sẵn, việc này đòi hỏi nhiều bước cài đặt COM DLL nhiêu khê. Vậy chúng ta có thể viết chương trình tự động tương tác với Google Drive nói chung và các dịch vụ của Google nói riêng bằng giải pháp thuần VBA không? Với nội dung dưới đây, câu trả lời có lẽ là "có".

Nhìn chung, việc viết macro VBA xác thực OAuth2 thì khá rắc rối. Trên internet cũng đã có nhiều giải pháp như của tác giả timhall: https://github.com/VBA-tools/VBA-Web/blob/master/authenticators/OAuth2Authenticator.cls. Tựu trung, việc xác thực gồm các bước như sau:
  • Căn cứ theo tài liệu từ phía Google, tiến hành viết một class module để xử lý chung và tái sử dụng code nhiều lần
  • Mở trình duyệt web (hầu hết các ví dụ trên internet đều sử dụng Internet Explorer), hiển thị trang để người dùng đăng nhập và tiến hành cấp quyền cho macro tiếp tục chạy
  • Lưu trữ access token, refresh token vào một chỗ nào đó để tiện dùng về sau và đảm bảo tính bảo mật
  • Dùng access token được cấp trong quyền hạn được giao bởi người dùng để tương tác với các dịch vụ của Google
Căn cứ vào trình tự nêu trên, trong bài viết này đề xuất một giải pháp khác.

Đầu tiên, với trường hợp nhiều máy tính có thể đang chạy Windows 11 không còn được cài đặt Internet Explorer, chúng ta sẽ tạo một UserForm với một WebBrowser (thực chất là Internet Explorer), UserForm này chỉ có nhiệm vụ hoạt động như một trình duyệt web để người dùng có thể đăng nhập và cấp quyền truy cập cho macro vào tài nguyên của tài khoản người dùng.

View attachment 1510234

View attachment 1510290

Phần việc chính:

Class Module: GoogleOAuth2 đảm nhận việc xác thực OAuth2, lấy, lưu trữ access token cũng như lấy access token mới thông qua refresh token cứ sau mỗi 60 phút.

Code:
Option Explicit

Private m_ApplicationName As String
Private m_ClientId As String
Private m_ClientSecret As String
Private m_Scope As Variant

Public Property Get ApplicationName() As String
    ApplicationName = m_ApplicationName
End Property

Public Property Let ApplicationName(Value As String)
    m_ApplicationName = Value
End Property

Public Property Get ClientID() As String
    ClientID = m_ClientId
End Property

Public Property Let ClientID(Value As String)
    m_ClientId = Value
End Property

Public Property Get ClientSecret() As String
    ClientSecret = m_ClientSecret
End Property

Public Property Let ClientSecret(Value As String)
    m_ClientSecret = Value
End Property

Public Property Get Scope() As Variant
    Scope = m_Scope
End Property

Public Property Let Scope(Value As Variant)
    m_Scope = Value
End Property

Public Function AuthorizeOAuth2() As String
    Dim objWinHttp As WinHttp.WinHttpRequest
    Dim strRequestBody As String
    Dim strURL As String
    Dim objBrowser As UserForm1
    Dim objReg As RegistryUtility
    Dim strAuthorizationCode As String
    Dim objFSO As Scripting.FileSystemObject
    Dim objFolder As Scripting.Folder
    Dim objFile As Scripting.TextStream
    Dim strFolder As String
    Dim strFile As String
    Dim strAccessToken As String
    Dim objJson As Scripting.Dictionary
    Dim dteExpTime As Date
    Dim strRefreshToken As String
    strFolder = Environ$("APPDATA") & "\" & ApplicationName
    strFile = strFolder & "\google-oauth2.token-response"
    Set objReg = New RegistryUtility
    Set objFSO = New Scripting.FileSystemObject
    If objFSO.FolderExists(strFolder) Then
        Set objFolder = objFSO.GetFolder(strFolder)
        If objFSO.FileExists(strFile) Then
            dteExpTime = CDate(objReg.ReadRegKey("HKEY_CURRENT_USER\Software\GoogleOAuth2VBA\AccessTokenExpirationTime"))
            If VBA.DateDiff("s", Now, dteExpTime) <= 0 Then
                Set objFile = objFSO.OpenTextFile(strFile, ForReading, False)
                Set objJson = JsonConverter.ParseJson(objFile.ReadAll)
                objFile.Close
                strRefreshToken = objJson.Item("refresh_token")
                AuthorizeOAuth2 = RefreshAccessToken(strRefreshToken)
            Else
                Set objFile = objFSO.OpenTextFile(strFile, ForReading, False)
                Set objJson = JsonConverter.ParseJson(objFile.ReadAll)
                objFile.Close
                AuthorizeOAuth2 = objJson.Item("access_token")
            End If
        Else: AuthorizeOAuth2 = GetAccessToken
        End If
    Else
        Set objFolder = objFSO.CreateFolder(strFolder)
        AuthorizeOAuth2 = GetAccessToken
    End If
    Set objWinHttp = Nothing
    Set objReg = Nothing
    Set objFSO = Nothing
    Set objFolder = Nothing
    Set objFile = Nothing
    Set objJson = Nothing
End Function

Private Function GetAccessToken() As String
    Dim objBrowser As UserForm1
    Dim objWinHttp As WinHttp.WinHttpRequest
    Dim strURL As String
    Dim strRequestBody As String
    Dim strAuthorizationCode As String
    Dim strFile As String
    Dim strFolder As String
    Dim strAccessToken As String
    Dim objReg As RegistryUtility
    Dim objJson As Scripting.Dictionary
    Dim objFSO As Scripting.FileSystemObject
    Dim objFile As Scripting.TextStream
    Set objFSO = New Scripting.FileSystemObject
    Set objReg = New RegistryUtility
    Set objBrowser = New UserForm1
    strFolder = Environ$("APPDATA") & "\" & ApplicationName
    strFile = strFolder & "\google-oauth2.token-response"
    strURL = "https://accounts.google.com/o/oauth2/v2/auth?scope=" & URLEncode(Join(Scope, " ")) & "&access_type=offline&include_granted_scopes=true&response_type=code&state=state_parameter_passthrough_value&redirect_uri=https://localhost&client_id=" & ClientID
    objBrowser.WebBrowser1.Navigate strURL
    objBrowser.Show vbModal
    If objReg.RegKeyExists("HKEY_CURRENT_USER\Software\GoogleOAuth2VBA\AuthorizationCode") Then
        strAuthorizationCode = CStr(objReg.ReadRegKey("HKEY_CURRENT_USER\Software\GoogleOAuth2VBA\AuthorizationCode"))
    End If
    If strAuthorizationCode <> vbNullString Then
        strRequestBody = "code=" & strAuthorizationCode & "&" & _
                        "client_id=" & ClientID & "&" & _
                        "client_secret=" & ClientSecret & "&" & _
                        "redirect_uri=https://localhost&" & _
                        "grant_type=authorization_code"
        Set objWinHttp = New WinHttp.WinHttpRequest
        With objWinHttp
            .Open "POST", "https://oauth2.googleapis.com/token", False
            .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .SetRequestHeader "Accept", "application/json'"
            .Send strRequestBody
            If .Status = 200 Then
                Set objJson = JsonConverter.ParseJson(.ResponseText)
                strAccessToken = objJson.Item("access_token")
                If strAccessToken <> vbNullString Then
                    GetAccessToken = strAccessToken
                    Set objFile = objFSO.CreateTextFile(strFile)
                    objFile.Write .ResponseText
                    objFile.Close
                    objReg.RegKeyWrite "HKEY_CURRENT_USER\Software\GoogleOAuth2VBA\AccessTokenExpirationTime", CStr(DateAdd("s", CDbl(objJson.Item("expires_in")), Now)), REG_SZ
                Else: Err.Raise vbObjectError + 2, , "Invalid authorization code"
                End If
            End If
        End With
    Else
        Err.Raise vbObjectError + 1, , "Failed to obtain the authorization code."
    End If
    Set objWinHttp = Nothing
    Set objJson = Nothing
    Set objReg = Nothing
    Set objFSO = Nothing
    Set objFile = Nothing
End Function

Private Function RefreshAccessToken(RefreshToken As String) As String
    Dim objWinHttp As WinHttp.WinHttpRequest
    Dim objJson As Scripting.Dictionary
    Dim strRequestBody As String
    Dim strFolder As String
    Dim strFile As String
    Dim objReg As RegistryUtility
    strRequestBody = "client_id=" & ClientID & "&" & _
                    "client_secret=" & ClientSecret & "&" & _
                    "refresh_token=" & RefreshToken & "&" & _
                    "grant_type=refresh_token"
    Set objWinHttp = New WinHttp.WinHttpRequest
    With objWinHttp
        .Open "POST", "https://oauth2.googleapis.com/token"
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .SetRequestHeader "Accept", "application/json'"
        .Send strRequestBody
        If .Status = 200 Then
            Set objJson = JsonConverter.ParseJson(.ResponseText)
            strFolder = Environ$("APPDATA") & "\" & ApplicationName
            strFile = strFolder & "\google-oauth2.token-response"
            Call SaveNewAccessToken(strFile, objJson.Item("access_token"))
            RefreshAccessToken = objJson.Item("access_token")
            Set objReg = New RegistryUtility
            objReg.RegKeyWrite "HKEY_CURRENT_USER\Software\GoogleOAuth2VBA\AccessTokenExpirationTime", CStr(DateAdd("s", CDbl(objJson.Item("expires_in")), Now)), REG_SZ
        End If
    End With
    Set objWinHttp = Nothing
    Set objJson = Nothing
    Set objReg = Nothing
End Function

Private Sub SaveNewAccessToken(AccessTokenFile As String, NewAccessToken As String)
    Dim objFSO As Scripting.FileSystemObject
    Dim objFile As Scripting.TextStream
    Dim strText As String, strOldText As String, strNewText As String
    strNewText = Chr(34) & "access_token" & Chr(34) & ": " & Chr(34) & NewAccessToken & Chr(34) & ","
    Set objFSO = New Scripting.FileSystemObject
    Set objFile = objFSO.OpenTextFile(AccessTokenFile)
    objFile.SkipLine
    strOldText = objFile.ReadLine
    objFile.Close
    Set objFile = objFSO.OpenTextFile(AccessTokenFile)
    strText = objFile.ReadAll
    objFile.Close
    strText = VBA.Replace(strText, strOldText, strNewText, , , vbTextCompare)
    Set objFile = objFSO.OpenTextFile(AccessTokenFile, ForWriting)
    objFile.Write strText
    objFile.Close
    Set objFSO = Nothing
    Set objFile = Nothing
End Sub

Public Function URLDecode(ByVal strIn As String) As String
    On Error Resume Next
    Dim sl&, tl&, key$, kl&
    sl = 1:    tl = 1: key = "%": kl = Len(key)
    sl = InStr(sl, strIn, key, 1)
    Do While sl > 0
        If (tl = 1 And sl <> 1) Or tl < sl Then
            URLDecode = URLDecode & Mid(strIn, tl, sl - tl)
        End If
        Dim hh$, hi$, hl$, a$
        Select Case UCase(Mid(strIn, sl + kl, 1))
            Case "U"    'Unicode URLEncode
                a = Mid(strIn, sl + kl + 1, 4)
                URLDecode = URLDecode & ChrW("&H" & a)
                sl = sl + 6
            Case "E"    'UTF-8 URLEncode
                hh = Mid(strIn, sl + kl, 2)
                a = Int("&H" & hh)    'ascii?
                If Abs(a) < 128 Then
                    sl = sl + 3
                    URLDecode = URLDecode & Chr(a)
                Else
                    hi = Mid(strIn, sl + 3 + kl, 2)
                    hl = Mid(strIn, sl + 6 + kl, 2)
                    a = ("&H" & hh And &HF) * 2 ^ 12 Or ("&H" & hi And &H3F) * 2 ^ 6 Or ("&H" & hl And &H3F)
                    If a < 0 Then a = a + 65536
                    URLDecode = URLDecode & ChrW(a)
                    sl = sl + 9
                End If
            Case Else    'Asc URLEncode
                hh = Mid(strIn, sl + kl, 2)    '??
                a = Int("&H" & hh)    'ascii?

                If Abs(a) < 128 Then
                    sl = sl + 3
                Else
                    hi = Mid(strIn, sl + 3 + kl, 2)    '??
                    'a = Int("&H" & hh & hi) '?ascii?
                    a = (Int("&H" & hh) - 194) * 64 + Int("&H" & hi)
                    sl = sl + 6
                End If
                URLDecode = URLDecode & ChrW(a)
        End Select
        tl = sl
        sl = InStr(sl, strIn, key, 1)
    Loop
    URLDecode = URLDecode & Mid(strIn, tl)
End Function

Public Function URLEncode(ByRef txt As String) As String
    Dim buffer As String, i As Long, c As Long, n As Long
    buffer = String$(Len(txt) * 12, "%")
 
    For i = 1 To Len(txt)
        c = AscW(Mid$(txt, i, 1)) And 65535
 
        Select Case c
            Case 48 To 57, 65 To 90, 97 To 122, 45, 46, 95  ' Unescaped 0-9A-Za-z-._ '
                n = n + 1
                Mid$(buffer, n) = ChrW(c)
            Case Is <= 127            ' Escaped UTF-8 1 bytes U+0000 to U+007F '
                n = n + 3
                Mid$(buffer, n - 1) = Right$(Hex$(256 + c), 2)
            Case Is <= 2047           ' Escaped UTF-8 2 bytes U+0080 to U+07FF '
                n = n + 6
                Mid$(buffer, n - 4) = Hex$(192 + (c \ 64))
                Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
            Case 55296 To 57343       ' Escaped UTF-8 4 bytes U+010000 to U+10FFFF '
                i = i + 1
                c = 65536 + (c Mod 1024) * 1024 + (AscW(Mid$(txt, i, 1)) And 1023)
                n = n + 12
                Mid$(buffer, n - 10) = Hex$(240 + (c \ 262144))
                Mid$(buffer, n - 7) = Hex$(128 + ((c \ 4096) Mod 64))
                Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
                Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
            Case Else                 ' Escaped UTF-8 3 bytes U+0800 to U+FFFF '
                n = n + 9
                Mid$(buffer, n - 7) = Hex$(224 + (c \ 4096))
                Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
                Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
        End Select
    Next
    URLEncode = Left$(buffer, n)
End Function

Class Module: RegistryUtility dùng để viết giá trị Authorization Code (do chỉ dùng một lần nên không cần phải bảo mật) với thời gian dự kiến access token sẽ hết hạn vào khóa registry tại HKEY_CURRENT_USER\Software\GoogleOAuth2VBA:

Code:
Option Explicit

Private objWShell As IWshRuntimeLibrary.WshShell
Public Enum KeyType
    REG_SZ = 0
    REG_DWORD = 1
    REG_EXPAND_SZ = 2
    REG_BINARY = 3
End Enum

Private Sub Class_Initialize()
    Set objWShell = New IWshRuntimeLibrary.WshShell
End Sub

Private Sub Class_Terminate()
    Set objWShell = Nothing
End Sub

Public Function ReadRegKey(key As String) As Variant
    ReadRegKey = objWShell.RegRead(key)
End Function

Public Sub DeleteRegKey(key As String)
    objWShell.RegDelete key
End Sub

Public Sub RegKeyWrite(key As String, Value As Variant, KeyType As KeyType)
    Dim strKeyType As String
    Select Case KeyType
        Case REG_SZ: strKeyType = "REG_SZ"
        Case REG_DWORD: strKeyType = "REG_DWORD"
        Case REG_EXPAND_SZ: strKeyType = "REG_EXPAND_SZ"
        Case REG_BINARY: strKeyType = "REG_BINARY"
    End Select
    objWShell.RegWrite key, Value, strKeyType
End Sub

Public Function RegKeyExists(key As String) As Boolean
    On Error Resume Next
    Dim varKeyValue As Variant
    varKeyValue = objWShell.RegRead(key)
    If Err.Number <> 0 Then
        Err.Clear
        RegKeyExists = False
    Else: RegKeyExists = True
    End If
End Function

Ví dụ: Lấy danh sách các thư mục có trong thư mục gốc trên Google Drive của người dùng:

View attachment 1510326

Code:
Option Explicit

Private Sub ListFoldersInDriveRootFolder()
    Dim objGoogleOAuth2 As GoogleOAuth2
    Dim strAccessToken As String
    Dim objWinHttp As WinHttp.WinHttpRequest
    Dim objFSO As Scripting.FileSystemObject
    Dim objFile As Scripting.TextStream
    Dim objJson As Scripting.Dictionary
    Set objGoogleOAuth2 = New GoogleOAuth2
    Set objFSO = New Scripting.FileSystemObject
    ' Tep JSON chua client_id va client_secret
    Set objFile = objFSO.OpenTextFile("E:\Data\client_secret_919574922950-bbr59m90nbmfv118uv6unon7k33j6p0b.apps.googleusercontent.com.json", ForReading)
    Set objJson = JsonConverter.ParseJson(objFile.ReadAll)
    objFile.Close
    With objGoogleOAuth2
        .ApplicationName = "TestGoogleDrive"
        .ClientID = objJson.Item("installed")("client_id")
        .ClientSecret = objJson.Item("installed")("client_secret")
        .Scope = Array("https://www.googleapis.com/auth/drive.file", "https://www.googleapis.com/auth/drive")
        strAccessToken = .AuthorizeOAuth2
    End With
    Set objWinHttp = New WinHttp.WinHttpRequest
    With objWinHttp
        .Open "GET", "https://www.googleapis.com/drive/v3/files?q=" & objGoogleOAuth2.URLEncode("'root' in parents and mimeType = 'application/vnd.google-apps.folder' and trashed = false")
        .SetRequestHeader "Authorization", "Bearer " & strAccessToken
        .SetRequestHeader "Accept", "application/json'"
        .Send
        If .Status = 200 Then
            Debug.Print .ResponseText
        Else: MsgBox "An error occurred"
        End If
    End With
    Set objGoogleOAuth2 = Nothing
    Set objWinHttp = Nothing
    Set objFSO = Nothing
    Set objFile = Nothing
    Set objJson = Nothing
End Sub

Kết quả:

View attachment 1510333

Tham khảo:
OAuth 2.0 for Mobile & Desktop Apps
Search for files and folders
Cập nhật thêm: Mình đã viết đầy đủ và hoàn chỉnh thư viện .xlam cho Google Drive API dùng cho Excel VBA, mọi người có thể tải xuống đính kèm theo bài viết này để sử dụng, dựa vào tài liệu do Google cung cấp tại đây: Google Drive API Reference
Nếu có lỗi gì, xin vui lòng để lại bình luận tại đây.
 

Attachments

  • GoogleDriveAPI.zip
    578.8 KB · Views: 45
Cập nhật thêm: Mình đã viết đầy đủ và hoàn chỉnh thư viện .xlam cho Google Drive API dùng cho Excel VBA, mọi người có thể tải xuống đính kèm theo bài viết này để sử dụng, dựa vào tài liệu do Google cung cấp tại đây: Google Drive API Reference
Nếu có lỗi gì, xin vui lòng để lại bình luận tại đây.
Một ví dụ nho nhỏ khi sử dụng thư viện trên:
Viết một UserForm thực hiện một số chức năng như tải xuống, tải lên tập tin, tạo danh sách tập tin theo cấu trúc hình cây (TreeView).

1678281133714.png
 

Attachments

  • GoogleDriveAPI.zip
    632.9 KB · Views: 45
Back
Top