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.
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
