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:
Đầ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.
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.
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:
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:
Kết quả:
Tham khảo:
OAuth 2.0 for Mobile & Desktop Apps
Search for files and folders
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
Đầ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.
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:
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ả:
Tham khảo:
OAuth 2.0 for Mobile & Desktop Apps
Search for files and folders