Attribute VB_Name = "Module1"
        
        Private Function ServerName() As String
            ServerName = "http://youserver/pwa/"
        End Function
        

        Public Sub GetProjectList()
            
            Dim sRequest As String
            Dim sSoapPostURL As String
            Dim sSoapAction As String
            Dim xmlDoc As New DOMDocument30
            Dim xmlObj As IXMLDOMElement
            
            sSoapPostURL = ServerName & "_vti_bin/psi/project.asmx"
            sRequest = "<ReadProjectList xmlns=""http://schemas.microsoft.com/office/project/server/webservices/Project/"" />"
            sSoapAction = "http://schemas.microsoft.com/office/project/server/webservices/Project/ReadProjectList"
                     
            Set xmlDoc = SoapRequestWorker(sSoapPostURL, sSoapAction, sRequest)
            
            Set xmlObj = xmlDoc.DocumentElement
            
            Dim projects As IXMLDOMNodeList
            
            Set projects = xmlObj.ChildNodes(0).ChildNodes(0).ChildNodes(0).ChildNodes(1).ChildNodes(0).ChildNodes
            
            Dim oXLSheet As Worksheet
            Set oXLSheet = Application.ActiveSheet
            oXLSheet.Rows.Clear
                        
            oXLSheet.Cells(1, 1) = "Project Name"
            oXLSheet.Cells(1, 2) = "Project Guid"
            
            For i = 0 To projects.Length - 1
                oXLSheet.Cells(i + 2, 1) = projects(i).ChildNodes(1).Text
                oXLSheet.Cells(i + 2, 2) = projects(i).ChildNodes(0).Text
            Next i
        
            oXLSheet.Name = "Project List"
            oXLSheet.Columns(1).ColumnWidth = 42
            oXLSheet.Columns(2).ColumnWidth = 42
        End Sub
    
        Private Function SoapRequestReturnAsXML(sSoapPostURL As String, sSoapAction As String, sSoapBody As String) As String
            Dim xmlDoc As DOMDocument30
            Set oXmlDoc = SoapRequestWorker(sSoapPostURL, sSoapAction, sSoapBody)
            If IsNull(oXmlDoc) Then
                SoapRequestReturnAsXML = ""
            Else
                SoapRequestReturnAsXML = oXmlDoc.XML
            End If
        End Function
    
    
        Private Function SoapRequestWorker(sSoapPostURL As String, sSoapAction As String, sSoapBody As String) As DOMDocument30
            Dim sRequest As String
            sRequest = "<?xml version=""1.0"" encoding=""UTF-8""?>" & _
              "<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>" & sSoapBody & "</soap:Body>" & "</soap:Envelope>"
            Dim xmlDoc As DOMDocument30
            Dim xmlhttp As XMLHTTP30
            Set xmlhttp = New XMLHTTP30
            
                Call MsgBox("Request = " & sRequest, vbOKOnly, "Request")
            
            Call xmlhttp.Open("POST", sSoapPostURL, False)
            Call xmlhttp.setRequestHeader("Content-Type", "text/xml; charset=utf-8")
            Call xmlhttp.setRequestHeader("SOAPAction", sSoapAction)
            Call xmlhttp.send(sRequest)
            
            Set oXmlDoc = xmlhttp.responseXML
            If IsNull(oXmlDoc) Then
                SoapRequestWorker = Null
            Else
                Set SoapRequestWorker = oXmlDoc
            End If
            
        End Function
        

        Public Sub DisplayProjectDetails()

            Dim projectGuid As String
            projectGuid = Application.ActiveCell
            If Not IsGuid(projectGuid) Then
                Call MsgBox(projectGuid & " is an invalid Guid", vbOKOnly, "Invalid Guid")
                Exit Sub
            End If
            
            Dim sRequest As String
            
            Dim sSoapPostURL As String
            Dim sSoapAction As String
            Dim xmlDoc As New DOMDocument30
            Dim xmlObj As IXMLDOMElement
          
            sSoapPostURL = ServerName & "_vti_bin/psi/project.asmx"
            
            sRequest = "<ReadProject xmlns=""http://schemas.microsoft.com/office/project/server/webservices/Project/""><projectUid>" & projectGuid & "</projectUid><dataStore>WorkingStore</dataStore></ReadProject>"
            sSoapAction = "http://schemas.microsoft.com/office/project/server/webservices/Project/ReadProject"
            
            Set xmlDoc = SoapRequestWorker(sSoapPostURL, sSoapAction, sRequest)
            
            Set xmlObj = xmlDoc.DocumentElement
            
            Dim project As IXMLDOMNodeList

            If xmlObj.ChildNodes(0).ChildNodes(0).ChildNodes(0).ChildNodes(1).ChildNodes.Length = 0 Then
                Call MsgBox("No data available for project")
                Exit Sub
            End If
            Set project = xmlObj.ChildNodes(0).ChildNodes(0).ChildNodes(0).ChildNodes(1).ChildNodes(0).ChildNodes(0).ChildNodes
            
            Dim oXLSheet As Worksheet
            Set oXLSheet = Application.Worksheets.Add()
            
            For i = 0 To project.Length - 1
                oXLSheet.Cells(i + 2, 1) = project(i).BaseName
                oXLSheet.Cells(i + 2, 2) = project(i).Text
            Next i
        
        
            ' Add TASK, ASSIGNMENT, CUSTOMFIELD, etc information
            Dim entities As IXMLDOMNodeList
            Dim entity As IXMLDOMElement

            Set entities = xmlObj.ChildNodes(0).ChildNodes(0).ChildNodes(0).ChildNodes(1).ChildNodes(0).ChildNodes

            Dim entityRowBase As Integer
            entityRowBase = project.Length + 3
            
            Dim strentities As String
            For j = 1 To entities.Length - 1 'NOTE start at 1 to skip project entity
                Set entity = entities(j)
                oXLSheet.Cells(entityRowBase, 1) = entities(j).BaseName
                entityRowBase = entityRowBase + 1
                
                For i = 0 To entity.ChildNodes.Length - 1
                    oXLSheet.Cells(entityRowBase, 2) = entity.ChildNodes(i).BaseName
                    oXLSheet.Cells(entityRowBase, 3) = entity.ChildNodes(i).Text
                    entityRowBase = entityRowBase + 1
                    If entityRowBase = 32767 Then
                        MsgBox "PSI data was larger than 32768 elements.  Data in the worksheet is truncated", vbOKOnly, "Row limit reached"
                        Exit Sub
                    End If
                Next i
            
             Next j
                 
            oXLSheet.Name = oXLSheet.Cells(3, 2).Value
            oXLSheet.Columns(1).ColumnWidth = 42
            oXLSheet.Columns(2).ColumnWidth = 42
            oXLSheet.Columns(3).ColumnWidth = 42
            
        
        End Sub

Private Function IsGuid(Guid As String) As Boolean
    Dim pattern As String
    
     Select Case Len(Guid)
        Case 36
            ' verify format of a0f7aba2-7793-4d28-9480-00cfdaf50ad9
            pattern = "nnnnnnnn-nnnn-nnnn-nnnn-nnnnnnnnnnnn"
        Case 38
            ' verify format of {a0f7aba2-7793-4d28-9480-00cfdaf50ad9}
            pattern = "{nnnnnnnn-nnnn-nnnn-nnnn-nnnnnnnnnnnn}"
        Case 32
            ' verify format of a0f7aba277934d28948000cfdaf50ad9
            pattern = "nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn"
        Case Else
            IsGuid = False
            Exit Function
     End Select
     
     Dim curchar As Integer
     Dim validhex() As Variant
     validhex = Array(48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 97, 98, 99, 100, 101, 102)
     Dim found As Boolean
     For i = 1 To Len(pattern)
        found = False
        curchar = Asc(Mid(LCase(Guid), i, 1))
        Select Case Mid(pattern, i, 1)
            Case "n"
                For Each n In validhex
                    If curchar = n Then
                        found = True
                        Exit For
                    End If
                Next
            Case "{"
                If curchar = 123 Then
                    found = True
                End If
            Case "}"
                If curchar = 125 Then
                    found = True
                End If
            Case "-"
                If curchar = 45 Then
                    found = True
                End If
        End Select
        If found = False Then
            IsGuid = False
            Exit Function
        End If
     Next i
    
    IsGuid = True

End Function