VBA to upload files to Sharepoint and set meta tags (if required) (1 Viewer)

Status
Not open for further replies.

Dystonia

Access 2002, 2010, 2016
Local time
Today, 09:17
Joined
Nov 11, 2017
Messages
17
Hi
 
I recently had to come up with some code to upload a ZIP file to a sharepoint site and set (existing) document meta tags.
 
I thought it would be reasonably straightforward use Microsoft Access 2010 to take a ZIP file produced by a Microsoft operating system and upload it to Microsoft Sharepoint 2013 and set a few document properties - how wrong could I be !
 
As this was/is somewhat beyond my usual database knowledge base, I had to do a lot of Googling and play with snippets of code from a plethora of websites before I finally got something that enabled upload of TXT files as well as binary files such as ZIPs,PDFs, XLSXs etc.

The internet is full of posts about code for one Sharepoint site not working at another so there are no guarantees with the function below but it may be a base to build on and help others avoid the blind alleys and brick walls I encountered.
   
As meta tags can only be set using an ADO recordset, make sure your VBA references include :
 
Microsoft ActiveX Data objects 6.1 Library (or higher)
 
The rem statements detail what parameters need to be passed into the function.

Code:
Function UploadFileToSharePoint(ByVal Sourcefile As String, ByVal SharepointURL As String, ByVal DocumentsURL As String, _
ByVal UserName As String, ByVal Password As String, Optional ByVal DocumentsGUID As String, Optional ByRef MetaTags)
Rem*******************************************
Rem Parameters passed into this function
Rem
Rem SourceFileName : Full details of file to upload eg "C:\Documents\Fri 20 Oct 2017 Daily Plan.ZIP"
Rem
Rem Ensure you add trailing slashes to your URLs
Rem
Rem SharepointURL : Note this omits the actual documents folder element eg
rem "[URL]https://companyname.sharepoint.com/logistics/[/URL]"
Rem
Rem DocumentsURL :  Actual Documents repository element eg "Shared Documents/"
Rem
Rem UserName : In Email format eg [EMAIL="firstname.lastname@company.com"]firstname.lastname@company.com[/EMAIL]
Rem
Rem Password : this is case sensitive so beware
Rem
Rem IF you want to set any EXISTING meta tags you will need the following
Rem
Rem DocumentsGUID : The GUID of DocumentsURL eg
Rem "{47DBD8C4-BCB4-40D9-8259-487E0504D058}"
Rem Google will tell you how to find this out if you don't know
Rem
Rem If there are no EXISTING meta tags to set, the above is not needed
Rem
Rem Optional two dimensional Variant array to set any EXISTING meta tags.
Rem Element 1 = Meta tag name : Element 2 = Mata tag value eg.
Rem Matatag(0,1) = "Document Expiry": Metatag(0,2) = 20/10/2017
Rem Metatag(1,1) = "Confidential"    : Metatag(1,2) = False
Rem
Rem if there are no meta tags to set the above is not needed
Rem*******************************************
    
    On Error GoTo oops 'oops something went wrong
    
Rem*******************************************
Rem Create FSO Object and get source file
Rem*******************************************

    Dim FSO, FSOFile As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set FSOFile = FSO.GetFile(Sourcefile)

Rem*******************************************
Rem Send Text File To Share Point
Rem*******************************************

    Dim XML As Object

Rem*******************************************
Rem Send Text/CSV File To Share Point
Rem*******************************************

    If UCase(FSOFile.Name) Like "*.TXT" Or UCase(FSOFile.Name) Like "*.CSV" Then
        Dim TextStreamIn As Variant
        Dim Body As Variant
        
        Set TextStreamIn = FSOFile.OpenAsTextStream
        
        Body = TextStreamIn.ReadAll
        TextStreamIn.Close
        
        Set XML = CreateObject("MSXML2.XMLHTTP.4.0")
        
        With XML
            .Open "PUT", SharepointURL & DocumentsURL & FSOFile.Name, False, UserName, Password
            .send Body
        End With
        
        If IsMissing(MetaTags) Then
            GoTo HouseKeep
        Else
            GoTo SetMetaTags
        End If
     
   End If
    
Rem*******************************************
Rem Binary File Get File Length
Rem*******************************************
   
    Dim FileLength As Long
    
    FileLength = FileLen(Sourcefile) - 1
   
Rem*******************************************
Rem Read Binary File Into Byte Array
Rem*******************************************
   
    Dim BArray() As Byte
   
    ReDim BArray(FileLength)
    
    Close
    
    Open Sourcefile For Binary As #1
    Get #1, , BArray
    Close #1
  
Rem*******************************************
Rem Convert BArray into Variant
Rem*******************************************
 
    Dim BinData As Variant
    
    BinData = BArray
    
Rem*******************************************
Rem Open XML Object
Rem*******************************************
       
    Set XML = CreateObject("Microsoft.XMLHTTP")
    
    With XML
       .Open "PUT", SharepointURL & DocumentsURL & FSOFile.Name, False, UserName, Password
       .send BinData
    End With
    
Rem*******************************************
Rem If meta tags not required tidy up and exit
Rem*******************************************
    
    If IsMissing(MetaTags) Then
        GoTo HouseKeep
    End If
        
SetMetaTags:
Rem*******************************************
Rem Compile Connection String
Rem*******************************************
    
    Dim CS As String 'ADO connection String
    
    CS = "Provider=Microsoft.ACE.OLEDB.12.0;"
    CS = CS & "WSS;"
    CS = CS & "IMEX=0;"
    CS = CS & "RetrieveIds=Yes;"
    CS = CS & "DATABASE=" & SharepointURL & ";"
    CS = CS & "LIST=" & DocumentsGUID & ";"
    
Rem*******************************************
Rem Establish Connection
Rem*******************************************
     
    Dim CN As ADODB.Connection
    
    Set CN = New ADODB.Connection
    
    With CN
        .ConnectionString = CS
        .Open
    End With

Rem*******************************************
Rem Prepare Recordset
Rem*******************************************
    
    Dim rs1 As ADODB.Recordset
    
    Set rs1 = New ADODB.Recordset
    
Rem*******************************************
Rem Open Sharepoint Document List as Recordset
Rem*******************************************
    
    Dim s1 As String
    
    s1 = "SELECT * FROM [Documents Repository Name] WHERE [Name] Like '" & FSOFile.Name & "#%';" '% is the equivament of asterisk 
 
    rs1.Open s1, CN, adOpenKeyset, adLockOptimistic
     
Rem*******************************************
Rem Wait for Sharepoint to catch up with Access
Rem*******************************************
    
    Do While rs1.RecordCount < 1
        rs1.Requery
    Loop
    
    rs1.MoveFirst
    
Rem*******************************************
Rem Loop Through Meta Tags
Rem element 1 = Meta Tag name
Rem element 2 = Mata tag value
Rem*******************************************
    
    Dim b As Byte
    
    For b = LBound(MetaTags) To UBound(MetaTags)
    
        rs1.Fields(MetaTags(b, 1)) = MetaTags(b, 2)
        
    Next b
        
    rs1.Update
    rs1.Close
    
    Set CN = Nothing
    Set rs1 = Nothing
    
HouseKeep:
Rem*******************************************
Rem HouseKeep
Rem*******************************************
    
    Set FSO = Nothing
    Set FSOFile = Nothing
    Set XML = Nothing

    UploadFileToSharePoint = "SUCCESS"

    Exit Function

oops:
Rem*******************************************
Rem oops Something when wrong
Rem*******************************************

    MsgBox Error$

    UploadFileToSharePoint = "ERROR"
       
End Function
 

irspec

New member
Local time
Today, 11:17
Joined
May 31, 2018
Messages
1
Dystonia, your code work perfect! Thank you very much.
I just have one issue with file names encoding. Non-English symbols are displayed incorrectly at sharepoint since VBA is using ASCII, but SharePoint is UTF-8. I've tried plenty of ASCII->UTF-8 converters to convert FSOFile.Name string into UTF-8, but nothing help. Either I still get ASCII, or no file to be uploaded at sharepoint (in this case debugging shows question marks "???????" instead non-English symbols of filename). I've also added
Code:
.setRequestHeader "Content-type", "application/xml;charset=utf-8"
before
Code:
.send BinData
, but it has no effect.
Could there be any solution?
 
Status
Not open for further replies.

Users who are viewing this thread

Top Bottom