Thursday 6 June 2013

Fetching data from Excell to Sharepoint List

Dim s As String
Dim listName As String
Dim viewName As String
Dim strSoapAction As String
'Private oSoapClient As SoapClient30
Sub Button1_Click()
Call PublishList
End Sub
Option Explicit
Public Sub PublishList()
    ' WebService URL
    Dim serviceUrl As String
    serviceUrl = "http://einstein/sites/Vendors/_vti_bin/Lists.asmx"
    'serviceUrl = "http://zew-v-0ac2806f.vpc2-eu.aws.shell-cloud.com:84/sites/vendors/_vti_bin/Lists.asmx"
    'list guid for list name (SERP Create on Dev Seat http://zew-v-0ac2806f.vpc2-eu.aws.shell-cloud.com:84/sites/vendors)
    listName = "{1B3DFFF3-E3E4-435C-A1FA-C99181770F40}"
    'viewName = "{47B9A34B-38E7-44E2-B04D-08B38CAF1832}"
   
    s = "<Batch OnError='Continue' ListVersion='1' ViewName='" & viewName & "'>" & _
    "<Method ID='1' Cmd='New'>" & _
            "<Field Name='ID'>New</Field>" & _
            "<Field Name='Title'>Hello Indicator</Field>" & _
      "</Method>" & _
"</Batch>"
' Creating Soap Envelop
Dim soapEnv As String
soapEnv = "<soapenv:Envelope xmlns:soapenv=""http://schemas.xmlsoap.org/soap/envelope/"">" & _
          "<soapenv:Body>" & _
            "<UpdateListItems xmlns=""http://schemas.microsoft.com/sharepoint/soap/"">" & _
              "<listName>" & listName & "</listName>" & _
              "<updates>" & _
                    "<Batch OnError='Continue' ListVersion='1' ViewName='" & viewName & "'>" & _
                        "<Method ID='1' Cmd='New'>" & _
                            "<Field Name='ID'>New</Field>" & _
                            "<Field Name='Title'>Hello Ashok</Field>" & _
                        "</Method>" & _
                    "</Batch>" & _
              "</updates>" & _
            "</UpdateListItems>" & _
         "</soapenv:Body>" & _
        "</soapenv:Envelope>"
       
   strSoapAction = "http://schemas.microsoft.com/sharepoint/soap/UpdateListItems"
 MsgBox soapEnv
  Call PostWebservice(serviceUrl, strSoapAction, soapEnv)
End Sub
Private Function PostWebservice(ByVal AsmxUrl As String, ByVal SoapActionUrl As String, ByVal XmlBody As String) As String
    Dim objDom As Object
    Dim objXmlHttp As Object
    Dim strRet As String
    Dim intPos1 As Integer
    Dim intPos2 As Integer
   
    On Error GoTo Err_PW
   
    MsgBox XmlBody
   
    ' Create objects to DOMDocument and XMLHTTP
    Set objDom = CreateObject("MSXML2.DOMDocument")
    Set objXmlHttp = CreateObject("MSXML2.XMLHTTP")
   
    ' Load XML
    objDom.async = False
    objDom.LoadXML XmlBody
    ' Open the webservice
    objXmlHttp.Open "POST", AsmxUrl, False
   
    ' Create headings
    objXmlHttp.setRequestHeader "Content-Type", "text/xml; charset=utf-8"
    objXmlHttp.setRequestHeader "SOAPAction", SoapActionUrl
   
    ' Send XML command
    objXmlHttp.send objDom.XML
    ' Get all response text from webservice
    strRet = objXmlHttp.responseText
    MsgBox strRet
    ' Close object
    Set objXmlHttp = Nothing
   
    ' Extract result
    intPos1 = InStr(strRet, "Result>") + 7
    intPos2 = InStr(strRet, "</")
    If intPos1 > 7 And intPos2 > 0 Then
        strRet = Mid(strRet, intPos1, intPos2 - intPos1)
    End If
   
    ' Return result
    PostWebservice = strRet
   
Exit Function
Err_PW:
    PostWebservice = "Error: " & Err.Number & " - " & Err.Description
End Function

No comments:

Post a Comment