[Resolvido]Upload de arquivos para o OneDrive utilizando MsAccess

Prezados, alguém tem um modelo de código para  para fazer upload de arquivos para o OneDrive for Business  utilizando o SharePoint no access ?

Olá Edson, seja Bem-Vindo ao fórum.

Encontrei o código abaixo numa pesqueisa da net, veja se ajuda:

Código:

Public Sub CopyToSharePoint()
'origem: https://social.msdn.microsoft.com/Forums/office/en-US/1b26aca0-4579-4cc3-bdaa-ea945452db01/upload-files-to-sharepoint-site-via-vba
On Error GoTo err_Copy

Dim xmlhttp
Dim sharepointUrl
Dim sharepointFileName
Dim tsIn
Dim sBody
Dim LlFileLength As Long
Dim Lvarbin() As Byte
Dim LobjXML As Object
Dim LstrFileName As String
Dim LvarBinData As Variant
Dim PstrFullfileName As String
Dim PstrTargetURL As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fldr As Folder
Dim f As File
Dim pw As String
Dim UserName As String
Dim RetVal
Dim I As Integer
Dim totFiles As Integer
Dim Start As Date, Finish As Date

UserName = InputBox(Username?")
pw = InputBox("Password?")

sharepointUrl = "[http path to server]/[server folder to write to]"

Set LobjXML = CreateObject("Microsoft.XMLHTTP")

Set fldr = fso.GetFolder(CurrentProject.Path & "\[folder with files to upload]\")
totFiles = fldr.Files.Count

For Each f In fldr.Files

  sharepointFileName = sharepointUrl & f.Name

'****************************   Upload text files  **************************************************

  If Not sharepointFileName Like "*.gif" And Not sharepointFileName Like "*.xls" And Not sharepointFileName Like "*.mpp" Then

    Set tsIn = f.OpenAsTextStream
    sBody = tsIn.ReadAll
    tsIn.Close
 
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP.4.0")
    xmlhttp.Open "PUT", sharepointFileName, False, UserName, Password
    xmlhttp.Send sBody
  
  Else

'****************************   Upload binary files  **************************************************
 
    PstrFullfileName = CurrentProject.Path & "\[folder with files to upload]\" & f.Name
    LlFileLength = FileLen(PstrFullfileName) - 1

    ' Read the file into a byte array.
    ReDim Lvarbin(LlFileLength)
    Open PstrFullfileName For Binary As #1
    Get #1, , Lvarbin
    Close #1

    ' Convert to variant to PUT.
    LvarBinData = Lvarbin
    PstrTargetURL = sharepointUrl & f.Name


    ' Put the data to the server, false means synchronous.
    LobjXML.Open "PUT", PstrTargetURL, False, Username, Password

   ' Send the file in.
    LobjXML.Send LvarBinData

  End If
 
  I = I + 1
  RetVal = SysCmd(acSysCmdSetStatus, "File " & I & " of " & totFiles & " copied...")
 
Next f

  RetVal = SysCmd(acSysCmdClearStatus)
  Set LobjXML = Nothing
  Set fso = Nothing


err_Copy:
If Err <> 0 Then
  MsgBox Err & " " & Err.Description
End If

End Sub

Caso pretenda explorar mais alternativas, veja este:
officeaccelerators.wordpress.com/2013/11/09/vba-code-to-uploaddownload-files-tofrom-sharepoint-library/

Abraço

AhTeixeira, obrigado pela ajuda!

A minha necessidade era para enviar um único arquivo. Consegui adaptar e funcionou:

Código:

Public Sub UploadOneDriveArquvoUnico()
On Error GoTo err_Copy

Dim sharepointFileName
Dim LlFileLength As Long
Dim Lvarbin() As Byte
Dim LstrFileName As String
Dim LvarBinData As Variant
Dim PstrFullfileName As String
Dim PstrTargetURL As String
Dim fldr As Folder
Dim Pw As String
Dim UserName As String
Dim myURL As String
Dim WinHttpReq As Object
Dim OdPasta As String
Dim OdNomeArquivo As String
Dim ArquivoOrigem As String


UserName = "ContaDoOneDrive.onmicrosoft.com"
Pw = "Informar a senha de acesso"

'-------------------------------------------------------------------------------------------------------------------
'1=Link de acesso gerado pelo OneDrive(Cria a conexão que permite o acesso para baixar ou enviar o arquivo)
myURL = "https:// ContaDoOneDrive -my.sharepoint.com/:f:/g/personal/arquivos_ ContaDoOneDrive _onmicrosoft_com/EhBOZInPXFVAt1cHzznePM7cB85pQgGot_DR_kRP2JenRRg?e=nYJHcc"
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, UserName, Pw
WinHttpReq.Send
'----------------------------------------------------------------------------------------------------------------------

OdPasta = "/Documents/NomeDaPastaDeArmazenamento/"
ArquivoOrigem = “EnderecoDeOrigemDoArquivo”'Local e nome do arquivo

'SELECIONA O NOME DO ARQUIVO
Dim intPos As Integer
Dim IntVezes As Integer
Dim DescrArqOrig
                   
Dim IndicItem
IndicItem = "\"
intPos = InStrRev(ArquivoOrigem, IndicItem, -1, CaseSensitivo)
DescrArqOrig = Right(ArquivoOrigem, Len(ArquivoOrigem) - intPos)
'--------------------------------------------------------------------------------

 OdNomeArquivo = DescrArqOrig

   PstrFullfileName = ArquivoOrigem
   LlFileLength = FileLen(PstrFullfileName) - 1

       'Read the file into a byte array.
       ReDim Lvarbin(LlFileLength)
       Open PstrFullfileName For Binary As #1
       Get #1, , Lvarbin
       Close #1
       'Convert to variant to PUT.
       LvarBinData = Lvarbin
 
   myURL = "https:// ContaDoOneDrive -my.sharepoint.com/personal/arquivos_ ContaDoOneDrive _onmicrosoft_com" & OdPasta & OdNomeArquivo
   WinHttpReq.Open "PUT", myURL, False, UserName, Pw
   WinHttpReq.Send LvarBinData
 
   Set WinHttpReq = Nothing
 

MsgBox "Arquivo enviado."
err_Copy:
If Err <> 0 Then
 MsgBox Err & " " & Err.Description
End If

End Sub

Olá Edson,

Fico feliz por ter ajudado!
Obrigado por partilhar a sua solução, o fórum agradece.

Abraço