'Alok Mehta
'February 2005
'MSDN VBA WebService Example

Option Explicit On 

Imports System
Imports System.Data
Imports System.Data.SqlClient
Imports System.Web.Services

<WebService(Namespace:="http://myCollege.edu/")> _
Public Class Service
    Inherits System.Web.Services.WebService
   
    'Provide grades for all homework, exams, and so on. Based on 
    'professor and course
    <WebMethod()> Public Function Get_Grades( _
        ByVal nProfessorID As Long, ByVal lngCourseID As Long) As String
        
        'Make sure its a valid request
        If bValidUser(nProfessorID, lngCourseID) Then
            'Dataset to store the results
            Dim GradesDataSet As DataSet = New DataSet()
 
            'Make connection to the Grades database; the connection
            'string would be in a config file in real application
            Dim GradesConn As SqlConnection = New SqlConnection( _
                "Data Source=localhost;Integrated Security=SSPI;" & _
                "Initial Catalog=Grades")
            Try
                'SQL to get the students grades for a particular 
                'professor and course
                Dim strSQL As String
                strSQL = "SELECT tbl_Student.Student_Name, " & _
                    "tbl_Grades.Quiz_Grade, tbl_Grades.HomeWork, " & _
                    "tbl_Grades.MidTerm, tbl_Grades.Participation, " & _
                    "tbl_Grades.FinalExam FROM tbl_Student INNER JOIN " & _
                    "(tbl_Professor INNER JOIN (tbl_Course INNER JOIN " & _
                    "tbl_Grades ON " & _
                  "tbl_Course.Course_ID=tbl_Grades.Course_ID) ON " & _
                  "tbl_Professor.Professor_ID=tbl_Grades.Professor_ID) " &_
                  "ON tbl_Student.Student_ID=tbl_Grades.Student_ID " & _
                  "WHERE tbl_Professor.Professor_ID=@profID AND " & _
                  "tbl_Course.Course_ID=@courseID"

                'Create the command to execute
                Dim Comm as SqlCommand = New SqlCommand(strSQL, GradesConn)
                Comm.Parameters.Add("@profID", nProfessorID)
                Comm.Parameters.Add("@courseID", lngCourseID)

                'Use a data adapter to fill the DataSet, then get as XML
                Dim dataGrades As SqlDataAdapter = New SqlDataAdapter(Comm)
                dataGrades.Fill(GradesDataSet)
                Get_Grades = GradesDataSet.GetXml
            Catch e As Exception
                'Return any error messages
                Get_Grades = e.Message
            Finally
                GradesConn.Close()
            End Try
        Else
            'In case its not a valid user     
            Get_Grades = "Invalid user"
        End If
    End Function

    Private Function bValidUser(ByVal nProfessorid, ByVal lngCourseid) _
                                As Boolean
        'This function should be replaced by your security standards 
        'such as a Web service token etc. For simplicity we just allow 
        'a specific professor ID and course ID
        If nProfessorid = 1 And lngCourseid = 1 Then
            bValidUser = True
        Else
            bValidUser = False
        End If
    End Function

End Class

'*****************************************************************
'This class was created by the Microsoft Office 2003 Web Services Toolkit.
'
'Description:
'This class is a Visual Basic for Applications class representation of the 
'Web service as defined by http://localhost/grades/WebService.asmx?wsdl.
'
'To Use:
'Dimension a variable as new clsws_Service, and then write code to
'use the methods provided by the class.
'Example:
' Dim ExampleVar as New clsws_Service
' debug.print ExampleVar.wsm_Get_Grades("Sample Input")
'
'For more information, see Complex Types in Microsoft Office 2003
'Web Services Toolkit Help.
'
'Changes to the code in this class may result in incorrect behavior.
'
'*****************************************************************

'Dimensioning private class variables.
Private sc_Service As SoapClient30
Private Const c_WSDL_URL As String = _
    "http://localhost/grades/WebService.asmx?wsdl"
Private Const c_SERVICE As String = "Service"
Private Const c_PORT As String = "ServiceSoap"
Private Const c_SERVICE_NAMESPACE As String = "http://myCollege.edu/"

Private Sub Class_Initialize()
    '*****************************************************************
    'This subroutine will be called each time the class is instantiated.
    'Creates sc_ComplexTypes as new SoapClient30, and then
    'initializes sc_ComplexTypes.mssoapinit2 with WSDL file found in
    'http://localhost/grades/WebService.asmx?wsdl.
    '*****************************************************************

    Dim str_WSML As String
    str_WSML = ""

    Set sc_Service = New SoapClient30

    sc_Service.MSSoapInit2 c_WSDL_URL, str_WSML, c_SERVICE, c_PORT, _
        c_SERVICE_NAMESPACE
    'Use the proxy server defined in Internet Explorer's LAN settings by
    'setting ProxyServer to <CURRENT_USER>
    sc_Service.ConnectorProperty("ProxyServer") = "<CURRENT_USER>"
    'Autodetect proxy settings if Internet Explorer is set to autodetect
    'by setting EnableAutoProxy to True
    sc_Service.ConnectorProperty("EnableAutoProxy") = True

End Sub

Private Sub Class_Terminate()
    '*****************************************************************
    'This subroutine will be called each time the class is destructed.
    'Sets sc_ComplexTypes to Nothing.
    '*****************************************************************

    'Error Trap
    On Error GoTo Class_TerminateTrap

    Set sc_Service = Nothing

Exit Sub

Class_TerminateTrap:
    ServiceErrorHandler ("Class_Terminate")
End Sub

Private Sub ServiceErrorHandler(str_Function As String)
    '*****************************************************************
    'This subroutine is the class error handler. It can be called from any    
    'class subroutine or function when that subroutine or function 
    'encounters an error. Then, it will raise the error along with the
    'name of the calling subroutine or function.
    '*****************************************************************

    'SOAP Error
    If sc_Service.FaultCode <> "" Then
        Err.Raise vbObjectError, str_Function, sc_Service.FaultString
    'Non SOAP Error
    Else
        Err.Raise Err.Number, str_Function, Err.Description
    End If

End Sub

Public Function wsm_Get_Grades(ByVal dcml_nProfessorID As Double, _
    ByVal dcml_lngCourseID As Double) As String
    '*****************************************************************
    'Proxy function created from 
    'http://localhost/grades/WebService.asmx?wsdl.
    '
    '"wsm_Get_Grades" is defined as XML. See Complex Types: XML Variables 
    'in Microsoft Office 2003 Web Services Toolkit Help for details on 
    'implementing XML variables.
    '*****************************************************************

    'Error Trap
    On Error GoTo wsm_Get_GradesTrap

    wsm_Get_Grades = sc_Service.Get_Grades(dcml_nProfessorID,  _
        dcml_lngCourseID)

Exit Function
wsm_Get_GradesTrap:
    ServiceErrorHandler "wsm_Get_Grades"
End Function

'MSDN VBA Excel-WebService Client Example Code
Option Explicit

'WebService Dataset will be temporarily saved in the following XML file
Const XMLFileName = "C:\Grades.XML"

'Professor will be given the following two IDs by the IT department.
Const Course_ID = 1
Const Professor_ID = 1

Private Sub cmdGetDataFromWebService_Click()
    On Error GoTo Error_Processing       
    Dim objGrades As New clsws_Service  'Instantiate the Web service proxy
    Dim strReturnValue As String        'XML string from the Web service
    Dim bSaveFile As Boolean            'Saved the XML file
    Dim intI As Integer                 'Local Counters
    Dim intJ As Integer
    Dim intOffset As Integer
    intOffset = 8                       'Starting Row
    Dim strColumn As String             'Spreadsheet Columns
    Dim strValue As String              'Values to be copied into cells
    Dim strFieldName As String          'XML fields mapped to the db fields
    Dim oRoot As MSXML2.IXMLDOMNode     'XML files's root
    Dim NewXMLdocument As New MSXML2.DOMDocument    'XML from the service

    'Get data from Web service
    strReturnValue = objGrades.wsm_Get_Grades(Professor_ID, Course_ID)
    bSaveFile = SaveToXML(XMLFileName, strReturnValue)

    If bSaveFile Then
        'Load the data from the file and iterate over the DOM
        Call NewXMLdocument.Load(XMLFileName)
        Set oRoot = NewXMLdocument.documentElement

        For intI = 0 To oRoot.childNodes.Length - 1
            For intJ = 0 To oRoot.childNodes.Item(intI).childNodes.Length 1                 

                'Get the value and field name for each node
                strValue = oRoot.childNodes.Item(intI) _
                    .childNodes.Item(intJ).Text    
                strFieldName = oRoot.childNodes.Item(intI) _
                    .childNodes.Item(intJ).baseName 
                 'Map the database fieldanme to the spreadsheet cells
                 Select Case strFieldName
                        Case "Student_Name":  strColumn = "A"
                        Case "Quiz_Grade":    strColumn = "C"
                        Case "HomeWork":      strColumn = "D"
                        Case "MidTerm":       strColumn = "E"
                        Case "Participation": strColumn = "F"
                        Case "FinalExam":     strColumn = "G"
                 End Select

                 'Set the cell's value based on the XML data
                 ActiveSheet.Cells(intI+intOffset,strColumn).Value=strValue    

                 'Keep track of what's happening to aid in debugging
                 Debug.Print strFieldName, strValue
             Next
        Next
        MsgBox "Web Service Data Get was successful"
    End If
    Set objGrades = Nothing    'Release the object
    Exit Sub
Error_Processing:        
    MsgBox "Error in Web Service Data Get " & Err.Description
End Sub


Private Function SaveToXML(strValue As String, strFileName As String) _
        As Boolean
    On Error GoTo Error_Processing
    'Saves a string value into a text file using FileSystemObject        
    Dim fs As Object
    Dim a        
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile(strValue, True)
    a.WriteLine (strFileName)
    a.Close
    SaveToXML = True
    Exit Function
Error_Processing:        
    MsgBox "Cannot Save XML File " & Err.Description
    SaveToXML = False
End Function