vba - 使用 VBA 上传到 Google 驱动器？

Question

我有一个 MS Access 数据库，现在需要我将文档“附加”到它。我的目的是将文档存储在 Google Drive 上，并在数据库上有一个链接供用户检索文档。

由于有许多用户分布在不同的城市，因此要求他们同步 Google Drive 文件夹是不切实际的。所有用户都需要上传到数据库/GD 的能力，所以我的目的是为数据库创建一个单独的 Google 帐户 - 具有自己的登录详细信息。

示例：用户单击按钮上传文件另存为对话框出现，用户选择文件数据库登录到其 Google Drive 并上传选定的文件

不过这有很多问题，主要是 Google Drive 不支持 VBA。如果用户登录到他们自己的 Gmail 帐户，那可能是另一个问题。

我在另一个站点上遇到了 vb.net 的这段代码。

Imports System
Imports System.Diagnostics
Imports DotNetOpenAuth.OAuth2
Imports Google.Apis.Authentication.OAuth2
Imports Google.Apis.Authentication.OAuth2.DotNetOpenAuth
Imports Google.Apis.Drive.v2
Imports Google.Apis.Drive.v2.Data
Imports Google.Apis.Util
Imports Google.Apis.Services

Namespace GoogleDriveSamples

Class DriveCommandLineSample

    Shared Sub Main(ByVal args As String)

        Dim CLIENT_ID As [String] = "YOUR_CLIENT_ID"
        Dim CLIENT_SECRET As [String] = "YOUR_CLIENT_SECRET"

        '' Register the authenticator and create the service
        Dim provider = New    NativeApplicationClient(GoogleAuthenticationServer.Description, CLIENT_ID, CLIENT_SECRET)
        Dim auth = New OAuth2Authenticator(Of NativeApplicationClient)(provider, GetAuthorization)
        Dim service = New DriveService(New BaseClientService.Initializer() With { _
 .Authenticator = auth _
})

        Dim body As New File()
        body.Title = "My document"
        body.Description = "A test document"
        body.MimeType = "text/plain"

        Dim byteArray As Byte() = System.IO.File.ReadAllBytes("document.txt")
        Dim stream As New System.IO.MemoryStream(byteArray)

        Dim request As FilesResource.InsertMediaUpload = service.Files.Insert(body, stream, "text/plain")
        request.Upload()

        Dim file As File = request.ResponseBody
        Console.WriteLine("File id: " + file.Id)
        Console.WriteLine("Press Enter to end this process.")
        Console.ReadLine()
    End Sub



    Private Shared Function GetAuthorization(ByVal arg As NativeApplicationClient) As IAuthorizationState

        ' Get the auth URL:
        Dim state As IAuthorizationState = New AuthorizationState( New () {DriveService.Scopes.Drive.GetStringValue()})

        state.Callback = New Uri(NativeApplicationClient.OutOfBandCallbackUrl)
        Dim authUri As Uri = arg.RequestUserAuthorization(state)

        ' Request authorization from the user (by opening a browser window):
        Process.Start(authUri.ToString())
        Console.Write("  Authorization Code: ")
        Dim authCode As String = Console.ReadLine()
        Console.WriteLine()

        ' Retrieve the access token by using the authorization code:
        Return arg.ProcessUserAuthorization(authCode, state)

    End Function

End Class


End Namespace

建议可以利用IE库登录Google Drive，通过上面的API调用上传。我不知道该怎么做。在其他地方提到“COM 包装器”可能是合适的。除了 VBA（自学）之外，我没有任何编码经验，所以我很难理解下一步应该是什么。

如果有人做过类似的事情或可以提供任何建议，我将不胜感激。

score 4 · Accepted Answer

这个线程现在可能已经死了，但是如果您正在使用数据库中的表单并且用户需要将文件附加到以具有唯一标识号的表单中显示的特定记录，那么这绝对是可能的，但您必须这样做在用 .NET 编写的外部应用程序中，我可以为您提供必要的代码来帮助您入门，vb.net 与 VBA 非常相似。

您需要做的是创建一个 Windows 窗体项目并添加对 Microsoft 访问核心 dll 的引用，并从 nugget 下载 google drive api 的 nugget 包。

Imports Google
Imports Google.Apis.Services
Imports Google.Apis.Drive.v2
Imports Google.Apis.Auth.OAuth2
Imports Google.Apis.Drive.v2.Data
Imports System.Threading


Public Class GoogleDriveAuth

    Public Shared Function GetAuthentication() As DriveService

Dim ClientIDString As String = "Your Client ID"
Dim ClientSecretString As String = "Your Client Secret"
Dim ApplicationNameString As String = "Your Application Name"


        Dim secrets = New ClientSecrets()
        secrets.ClientId = ClientIDString
        secrets.ClientSecret = ClientSecretString

        Dim scope = New List(Of String)
        scope.Add(DriveService.Scope.Drive)

        Dim credential = GoogleWebAuthorizationBroker.AuthorizeAsync(secrets, scope, "user", CancellationToken.None).Result()

        Dim initializer = New BaseClientService.Initializer
        initializer.HttpClientInitializer = credential
        initializer.ApplicationName = ApplicationNameString

        Dim Service = New DriveService(initializer)

        Return Service

    End Function

End Class

此代码将授权您的驱动器服务，然后您在导入下创建一个公共共享服务作为 DriveService 可以从任何子或函数中使用，然后在您的表单加载事件中调用此函数，例如

服务 = GoogleDriveAuth.GetAuthentication

将对您的项目的引用添加到 Microsoft Access 12.0 对象库或您拥有的任何版本

然后这段代码将查看您想要从中获取记录值的表单并将文件上传到您选择的文件夹

Private Sub UploadAttachments()

        Dim NumberExtracted As String

        Dim oAccess As Microsoft.Office.Interop.Access.Application = Nothing
        Dim connectedToAccess As Boolean = False

        Dim SelectedFolderIdent As String = "Your Upload Folder ID"
        Dim CreatedFolderIdent As String

        Dim tryToConnect As Boolean = True

        Dim oForm As Microsoft.Office.Interop.Access.Form
        Dim oCtls As Microsoft.Office.Interop.Access.Controls
        Dim oCtl As Microsoft.Office.Interop.Access.Control
        Dim sForm As String 'name of form to show

        sForm = "Your Form Name"

        Try

            While tryToConnect

                Try
                    ' See if can connect to a running Access instance

                    oAccess = CType(Marshal.GetActiveObject("Access.Application"), Microsoft.Office.Interop.Access.Application)
                    connectedToAccess = True

                Catch ex As Exception

                    Try
                        ' If couldn't connect to running instance of Access try to start a running Access instance And get an updated version of the database

                        oAccess = CType(CreateObject("Access.Application"), Microsoft.Office.Interop.Access.Application)
                        oAccess.Visible = True
                        oAccess.OpenCurrentDatabase("Your Database Path", False)
                        connectedToAccess = True

                    Catch ex2 As Exception

                        Dim res As DialogResult = MessageBox.Show("COULD NOT CONNECT TO OR START THE DATABASE" & vbNewLine & ex2.Message, "Warning", MessageBoxButtons.AbortRetryIgnore, MessageBoxIcon.Warning)

                        If res = System.Windows.Forms.DialogResult.Abort Then
                            Exit Sub
                        End If

                        If res = System.Windows.Forms.DialogResult.Ignore Then
                            tryToConnect = False
                        End If

                    End Try

                End Try

                ' We have connected successfully; stop trying
                tryToConnect = False

            End While

            ' Start a new instance of Access for Automation:
            ' Make sure Access is visible:
            If Not oAccess.Visible Then oAccess.Visible = True

            '  For Each oForm In oAccess.Forms
            '  oAccess.DoCmd.Close(ObjectType:=Microsoft.Office.Interop.Access.AcObjectType.acForm, ObjectName:=oForm.Name, Save:=Microsoft.Office.Interop.Access.AcCloseSave.acSaveNo)
            '  Next
            '  If Not oForm Is Nothing Then
            '  System.Runtime.InteropServices.Marshal.ReleaseComObject(oForm)
            '  End If
            '   oForm = Nothing

            ' Select the form name in the database window and give focus
            ' to the database window:
            '  oAccess.DoCmd.SelectObject(ObjectType:=Microsoft.Office.Interop.Access.AcObjectType.acForm, ObjectName:=sForm, InDatabaseWindow:=True)

            ' Show the form:
            '   oAccess.DoCmd.OpenForm(FormName:=sForm, View:=Microsoft.Office.Interop.Access.AcFormView.acNormal)

            ' Use Controls collection to edit the form:
            oForm = oAccess.Forms(sForm)
            oCtls = oForm.Controls

            oCtl = oCtls.Item("The Name Of The Control Where The Id Number Is On The Form")
            oCtl.Enabled = True
            ' oCtl.SetFocus()
            NumberExtracted = oCtl.Value
            System.Runtime.InteropServices.Marshal.ReleaseComObject(oCtl)
            oCtl = Nothing

            '  Hide the Database Window:
            '  oAccess.DoCmd.SelectObject(ObjectType:=Microsoft.Office.Interop.Access.AcObjectType.acForm, ObjectName:=sForm, InDatabaseWindow:=True)
            '  oAccess.RunCommand(Command:=Microsoft.Office.Interop.Access.AcCommand.acCmdWindowHide)

            '  Set focus back to the form:
            '  oForm.SetFocus()

            '  Release Controls and Form objects:
            System.Runtime.InteropServices.Marshal.ReleaseComObject(oCtls)
            oCtls = Nothing

            System.Runtime.InteropServices.Marshal.ReleaseComObject(oForm)
            oForm = Nothing

            '  Release Application object and allow Access to be closed by user:
            If Not oAccess.UserControl Then oAccess.UserControl = True
            System.Runtime.InteropServices.Marshal.ReleaseComObject(oAccess)
            oAccess = Nothing


            If NumberExtracted = Nothing Then
                MsgBox("The Number Could Not Be Obtained From The Form" & vbNewLine & vbNewLine & "Please Ensure You Have The Form Open Before Trying To Upload")
                Exit Sub
            End If


            If CheckForDuplicateFolder(SelectedFolderIdent, NumberExtracted + " - ATC") = True Then

                CreatedFolderIdent = GetCreatedFolderID(NumberExtracted + " - ATC", SelectedFolderIdent)
                DriveFilePickerUploader(CreatedFolderIdent)

            Else

                CreateNewDriveFolder(NumberExtracted + " - ATC", SelectedFolderIdent)
                CreatedFolderIdent = GetCreatedFolderID(NumberExtracted + " - ATC", SelectedFolderIdent)
                DriveFilePickerUploader(CreatedFolderIdent)

            End If

        Catch EX As Exception
            MsgBox("The Number Could Not Be Obtained From The Form" & vbNewLine & vbNewLine & "Please Ensure You Have The Form Open Before Trying To Upload" & vbNewLine & vbNewLine & EX.Message)
            Exit Sub
        Finally

            If Not oCtls Is Nothing Then
                System.Runtime.InteropServices.Marshal.ReleaseComObject(oCtls)
                oCtls = Nothing
            End If

            If Not oForm Is Nothing Then
                System.Runtime.InteropServices.Marshal.ReleaseComObject(oForm)
                oForm = Nothing
            End If

            If Not oAccess Is Nothing Then
                System.Runtime.InteropServices.Marshal.ReleaseComObject(oAccess)
                oAccess = Nothing
            End If

        End Try

        End

    End Sub

检查目标上传文件夹中的重复文件夹

Public Function CheckForDuplicateFolder(ByVal FolderID As String, ByVal NewFolderNameToCheck As String) As Boolean

    Dim ResultToReturn As Boolean = False

    Try
        Dim request = Service.Files.List()

        Dim requeststring As String = ("'" & FolderID & "' in parents And mimeType='application/vnd.google-apps.folder' And trashed=false")

        request.Q = requeststring

        Dim FileList = request.Execute()

        For Each File In FileList.Items

            If File.Title = NewFolderNameToCheck Then
                ResultToReturn = True
            End If

        Next

    Catch EX As Exception
        MsgBox("THERE HAS BEEN AN ERROR" & EX.Message)
    End Try

    Return ResultToReturn

End Function

创建新的驱动器文件夹

Public Sub CreateNewDriveFolder(ByVal DirectoryName As String, ByVal ParentFolder As String)

    Try

        Dim body1 = New Google.Apis.Drive.v2.Data.File
        body1.Title = DirectoryName
        body1.Description = "Created By Automation"
        body1.MimeType = "application/vnd.google-apps.folder"

        body1.Parents = New List(Of ParentReference)() From {New ParentReference() With {.Id = ParentFolder}}

        Dim file1 As Google.Apis.Drive.v2.Data.File = Service.Files.Insert(body1).Execute()

    Catch EX As Exception
        MsgBox("THERE HAS BEEN AN ERROR" & EX.Message)
    End Try

End Sub

获取创建的文件夹 ID

    Public Function GetCreatedFolderID(ByVal FolderName As String, ByVal FolderID As String) As String

        Dim ParentFolder As String

        Try

            Dim request = Service.Files.List()

            Dim requeststring As String = ("'" & FolderID & "' in parents And mimeType='application/vnd.google-apps.folder' And title='" & FolderName & "' And trashed=false")

            request.Q = requeststring

            Dim Parent = request.Execute()

            ParentFolder = (Parent.Items(0).Id)

        Catch EX As Exception
            MsgBox("THERE HAS BEEN AN ERROR" & EX.Message)
        End Try

        Return ParentFolder

End Function

驱动文件选择器上传器将从文件对话框中选择的文件上传到新创建的文件夹

    Public Sub DriveFilePickerUploader(ByVal ParentFolderID As String)

        Try

            ProgressBar1.Value = 0

            Dim MimeTypeToUse As String

            Dim dr As DialogResult = Me.OpenFileDialog1.ShowDialog()

            If (dr = System.Windows.Forms.DialogResult.OK) Then
                Dim file As String

            Else : Exit Sub

            End If

            Dim i As Integer = 0

            For Each file In OpenFileDialog1.FileNames

                MimeTypeToUse = GetMimeType(file)

                Dim filetitle As String = (OpenFileDialog1.SafeFileNames(i))

                Dim body2 = New Google.Apis.Drive.v2.Data.File

                body2.Title = filetitle
                body2.Description = "J-T Auto File Uploader"
                body2.MimeType = MimeTypeToUse

                body2.Parents = New List(Of ParentReference)() From {New ParentReference() With {.Id = ParentFolderID}}

                Dim byteArray = System.IO.File.ReadAllBytes(file)
                Dim stream = New System.IO.MemoryStream(byteArray)

                Dim request2 = Service.Files.Insert(body2, stream, MimeTypeToUse)
                request2.Upload()

            Next

    Catch EX As Exception
        MsgBox("THERE HAS BEEN AN ERROR" & EX.Message)
    End Try

End Sub

获取上传文件的 Mime 类型

Public Shared Function GetMimeType(ByVal file As String) As String
        Dim mime As String = Nothing
        Dim MaxContent As Integer = CInt(New FileInfo(file).Length)
        If MaxContent > 4096 Then
            MaxContent = 4096
        End If

        Dim fs As New FileStream(file, FileMode.Open)

        Dim buf(MaxContent) As Byte
        fs.Read(buf, 0, MaxContent)
        fs.Close()
        Dim result As Integer = FindMimeFromData(IntPtr.Zero, file, buf, MaxContent, Nothing, 0, mime, 0)

        Return mime
    End Function


    <DllImport("urlmon.dll", CharSet:=CharSet.Auto)> _
    Private Shared Function FindMimeFromData( _
            ByVal pBC As IntPtr, _
             <MarshalAs(UnmanagedType.LPWStr)> _
             ByVal pwzUrl As String, _
             <MarshalAs(UnmanagedType.LPArray, ArraySubType:=UnmanagedType.I1, SizeParamIndex:=3)> ByVal _
             pBuffer As Byte(), _
             ByVal cbSize As Integer, _
             <MarshalAs(UnmanagedType.LPWStr)> _
             ByVal pwzMimeProposed As String, _
             ByVal dwMimeFlags As Integer, _
             <MarshalAs(UnmanagedType.LPWStr)> _
            ByRef ppwzMimeOut As String, _
             ByVal dwReserved As Integer) As Integer
    End Function

希望这可以帮助您开始，我 100% 相信这是可以实现的，因为我已经为我的经理做了这件事。

score 1 · Accepted Answer

这个回复可能会迟到，但只是想分享一种方法！我已经用 VBA 成功完成了这个，演示链接在这里 http://www.sfdp.net/thuthuataccess/demo/democAuth.rar?attredirects=0&d=1 有了这个，你可以上传、下载或删除一个文件GoogleDrive in Access.. 只要 Wininet + WinHTTP 就够了 Dang Dinh ngoc 越南

vba - 使用 VBA 上传到 Google 驱动器？

2 回答 2

Related

Reference