vba - VBA を使用して Google ドライブにアップロードしますか?

Question

私は現在、ドキュメントを「添付」する必要がある MS Access データベースを持っています。私の意図は、ドキュメントを Google ドライブに保存し、ユーザーがドキュメントを取得できるようにデータベースにリンクを張ることです。

多くのユーザーがさまざまな都市に分散しているため、Google ドライブフォルダーの同期をユーザーに要求するのは現実的ではありません。すべてのユーザーがデータベース/GD にアップロードできる必要があるため、データベース用に別の Google アカウントを作成し、独自のログイン情報を使用する必要があります。

例: ユーザーがボタンをクリックしてファイルをアップロードする [名前を付けて保存] ダイアログボックスが表示され、ユーザーがファイルを選択するデータベースが 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 ドライブにログインし、上記から API 呼び出しを行ってアップロードすることが提案されました。これを行う方法がわかりません。他のどこかで、「COM ラッパー」が適している可能性があると言及されていました。私は VBA (独学) 以外のコーディングの経験がないため、次のステップがどうあるべきかを理解するのに苦労しています。

似たようなことをしたことがある方、アドバイスいただける方がいらっしゃいましたら、よろしくお願いします。

score 4 · Accepted Answer

このスレッドは現在死んでいる可能性がありますが、データベース内のフォームを操作していて、ユーザーが一意の識別番号を持つフォームに表示される特定のレコードにファイルを添付する必要がある場合、これは間違いなく可能ですが、実行する必要があります.NET で記述された外部アプリケーションでは、開始するために必要なコードを提供できます。vb.net は VBA に非常に似ています。

Windows フォームプロジェクトを作成し、Microsoft アクセスコア dll への参照を追加し、ナゲットから Google ドライブ 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 Object Library または使用しているバージョンに追加します

次に、このコードは、レコード番号の値を取得したいフォームを調べ、選択したフォルダーにファイルをアップロードします

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

この返信は遅くなるかもしれませんが、アプローチの 1 つを共有したいだけです! 私は VBA でこれを成功させました。デモリンクは http://www.sfdp.net/thuthuataccess/demo/democAuth.rar?attredirects=0&d=1 にあります。 GoogleDrive in Access.. Wininet + WinHTTP だけで十分 Dang Dinh ngoc Vietnam

vba - VBA を使用して Google ドライブにアップロードしますか?

2 に答える 2

Related

Reference