jason/VBA-SharePoint-List-Functions
jason/VBA-SharePoint-List-Functions
1
0
Fork 0
Code

Many changes

Browse Source 
- Accepts multiple fields as a dictionary object
- Creates a new list item if there isn't an existing one
- Updates an existing list item if the ID is passed in
This commit is contained in:
Jason Williams 2016-06-07 13:34:30 -06:00
parent 0eb27a0bcd
commit 24c19b5acb
1 changed files with 21 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
SPListLibrary.bas
View File

@ -1,18 +1,25 @@
Attribute VB_Name = "SPListLibrary"
Public Function Add_Item(ListName As String, SharepointUrl As String, ValueVar As String, FieldNameVar As String) As Integer
Public Function SPListItem(SharepointUrl As String, ListName As String, ListData As Dictionary, Optional itemid As Integer = 0) As Integer
Dim objXMLHTTP As MSXML2.XMLHTTP
Dim strListNameOrGuid As String
Dim strBatchXml As String
Dim strSoapBody As String
Dim xmlhttpResponse As New MSXML2.DOMDocument
Dim attr As Object
Dim key As Variant
strBatchXml = ""
For Each key In ListData
strBatchXml = strBatchXml & "<Field Name='" & key & "'>" & ListData(key) & "</Field>"
Next key
If itemid = 0 Then
strBatchXml = "<Batch OnError='Continue'><Method ID='1' Cmd='New'>" & strBatchXml & "</Method></Batch>"
Else
strBatchXml = "<Batch OnError='Continue'><Method ID='1' Cmd='Update'><Field Name='ID'>" & itemid & "</Field>" & strBatchXml & "</Method></Batch>"
End If
Set objXMLHTTP = New MSXML2.XMLHTTP
strListNameOrGuid = ListName
strBatchXml = "<Batch OnError='Continue'><Method ID='3' Cmd='New'><Field Name='ID'>New</Field><Field Name=" + FieldNameVar + ">" + ValueVar + "</Field></Method></Batch>"
objXMLHTTP.Open "POST", SharepointUrl + "_vti_bin/Lists.asmx", False
objXMLHTTP.setRequestHeader "Content-Type", "text/xml; charset=""UTF-8"""
objXMLHTTP.setRequestHeader "SOAPAction", "http://schemas.microsoft.com/sharepoint/soap/UpdateListItems"
@ -20,20 +27,17 @@ Public Function Add_Item(ListName As String, SharepointUrl As String, ValueVar A
strSoapBody = "<soap:Envelope xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance' " _
& "xmlns:xsd='http://www.w3.org/2001/XMLSchema' " _
& "xmlns:soap='http://schemas.xmlsoap.org/soap/envelope/'><soap:Body><UpdateListItems " _
& "xmlns='http://schemas.microsoft.com/sharepoint/soap/'><listName>" & strListNameOrGuid _
& "xmlns='http://schemas.microsoft.com/sharepoint/soap/'><listName>" & ListName _
& "</listName><updates>" & strBatchXml & "</updates></UpdateListItems></soap:Body></soap:Envelope>"
objXMLHTTP.send strSoapBody
If objXMLHTTP.Status = 200 Then
Set xmlhttpResponse = objXMLHTTP.responseXML
Add_Item = CInt(xmlhttpResponse.SelectSingleNode("//UpdateListItemsResult//Results//Result//z:row").Attributes.getNamedItem("ows_ID").Text)
CreateSPItem = CInt(xmlhttpResponse.SelectSingleNode("//UpdateListItemsResult//Results//Result//z:row").Attributes.getNamedItem("ows_ID").Text)
Else
MsgBox ("Some kind of error happened. Wut?")
Add_Item = -1
CreateSPItem = -1
End If
Set objXMLHTTP = Nothing
End Function