使用VBA上傳到Google驅動器？

Question

我有一個MS Access數據庫，現在要求我'附加'文件。我的意圖是將文檔存儲在Google雲端硬盤中，並在數據庫上有鏈接供用戶檢索文檔。

由於有很多用戶通過不同的城市蔓延，這是不切合實際的要求他們已同步谷歌雲端硬盤文件夾。所有的用戶都需要能夠上傳到數據庫/ GD，所以我的意圖是爲數據庫建立一個單獨的Google帳戶 - 擁有自己的登錄信息。

例如： 用戶點擊按鈕來上傳文件 另存爲對話框出現，用戶使用此選擇文件 數據庫登錄到其谷歌驅動器和上傳選擇的文件

很多問題雖然，最主要的是Google雲端硬盤不支持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以外，我沒有任何經驗（自學），所以我很難理解下一步應該做什麼。

如果有人做過類似的東西，或能提供任何意見，我將不勝感激聽到你的聲音。

Answer 1

此線程現在可能是死的，但如果你和你的數據庫的形式工作，用戶需要在文件附加到一個獨特的識別號碼顯示在表單中的特定記錄那麼這絕對是可能的，但你會必須在用.NET編寫的外部應用程序中執行此操作。我可以爲您提供啓動所需的代碼，而vb.net與VBA非常相似。

什麼，你需要做的就是創建一個Windows窗體項目，並添加引用到Microsoft Access核心DLL，並從金塊下載金塊包穀歌驅動API。

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％確信這是可以實現的，因爲我已經爲我的經理做過這些事情。

Answer 2

此回覆可能會很晚，但只是想分享一種方法！ 我與VBA成功地做到這一點，並演示環節是在這裏 http://www.sfdp.net/thuthuataccess/demo/democAuth.rar?attredirects=0&d=1 有了這個，你可以上傳，下載或與您的Google雲端硬盤的訪問.. 剛的Wininet + WinHTTP的足夠 黨亭刪除文件玉 越南