[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1164
  • Last Modified:

HTTPPost, read/write XML, and SSL "O" My ASP.net (VB)

I have an existing ASP.net (VB) application that I am trying to integrate with the UPS online tools. The sample provided my UPS is VB6. can anyone point me in the right direction on how to update this sample for use in my app. I have provided the sample code bellow:

Public Sub Main()

On Error GoTo ErrorHandle
Dim doc As New MSXML2.DOMDocument30
Dim rNode As MSXML2.IXMLDOMElement
Dim doc1 As MSXML2.DOMDocument30
Dim RespFile As String
Dim ReqFile As String
Dim Service As String

'Create the XML document
Set doc = New MSXML2.DOMDocument30
If (createXMLDocument("AccessLicenseAgreementRequest", doc)) Then
   

' ******* Build an Access License Agreement Request *****************

'Adding Nodes to the XML document that was previously created "doc"
    AddNode doc, "AccessLicenseAgreementRequest", "", "", "xml:lang", "en-US"
    AddNode doc, "AccessLicenseAgreementRequest", "Request", "EMPTY_NODE", "", ""
    AddNode doc, "AccessLicenseAgreementRequest", "AccessLicenseNumber", "8B505CD8A2612824", "", ""
    AddNode doc, "AccessLicenseAgreementRequest", "AccessLicenseProfile", "EMPTY_NODE", "", ""
    AddNode doc, "Request", "TransactionReference", "EMPTY_NODE", "", ""
    AddNode doc, "Request", "RequestAction", "AccessLicense", "", ""
    AddNode doc, "Request", "RequestOption", "AllTools", "", ""
    AddNode doc, "TransactionReference", "CustomerContext", "License Test", "", ""
    AddNode doc, "TransactionReference", "XpicVersion", "1.0", "", ""
    AddNode doc, "AccessLicenseProfile", "CountryCode", "US", "", ""
    AddNode doc, "AccessLicenseProfile", "LanguageCode", "EN", "", ""

indata = InputBox("Enter the full path and filename of Request to be created." & vbCrLf & vbCrLf & _
    "If the path is not valid no file will be created", "Request File")
If Len(Trim(indata)) <> 0 Then
    ReqFile = indata
    doc.save (ReqFile)
    MsgBox "Finish, see " & ReqFile & " for the generated XML Request."
Else
    MsgBox "No demo for you"
End If
End If

Exit Sub
ErrorHandle:
MsgBox "Error running Sample Code"
End Sub
 

Public Function createXMLDocument(rootname As String, xml As MSXML2.DOMDocument30) As Boolean

 On Error GoTo ErrHand
   
    Dim docXML As New MSXML2.DOMDocument30
    Dim parentNode As IXMLDOMNode
    Dim root  As IXMLDOMElement
    Dim Prop As MSXML2.IXMLDOMProcessingInstruction
   
    docXML.async = False
    Set root = docXML.createElement(rootname)
    docXML.loadXML root.xml
    Set parentNode = root
   
    Set Prop = docXML.createProcessingInstruction("xml", "version = '1.0'")
    docXML.loadXML (Prop.xml & root.xml)
   
    Set xml = docXML
    createXMLDocument = True
    Exit Function
   
ErrHand:
Debug.Print "Error creating Document (" & rootname & ")"
createXMLDocument = False
Debug.Print Err.Description
End Function

Public Function AddNode(doc As MSXML2.DOMDocument30, strParentTag As String, newTagName As String, _
        textString As String, attrName As String, AttrValue As String)

    On Error GoTo ErrHand
    Dim Item As MSXML2.IXMLDOMElement
    Dim root As MSXML2.IXMLDOMElement
    Dim oAttr As MSXML2.IXMLDOMAttribute
    Dim parentTag As MSXML2.IXMLDOMNode
    Dim Node As MSXML2.IXMLDOMNode
    Dim pNode As MSXML2.IXMLDOMNode
    Dim child As MSXML2.IXMLDOMNode
    Dim ThisNode As MSXML2.IXMLDOMText
    AddNode = True
    ' we are getting a nodelist because it allows us to specify the parent element
    ' by its string name; that way, we don't have to pass Elements around
    Dim N1 As MSXML2.IXMLDOMNodeList
   Set parentTag = doc
   Set N1 = doc.getElementsByTagName(strParentTag)
   If N1.length > 0 Then
       Set Parent = N1.Item(N1.length - 1)
    Else
        Set Parent = parentTag
    End If
        If Not (StrComp(textString, "") = 0) Then
           
                Set Node = doc.createNode(NODE_ELEMENT, newTagName, "")
                If Not (StrComp(textString, "EMPTY_NODE") = 0) Then
                    Node.nodeTypedValue = textString
                End If
                Parent.appendChild Node
               
                AddNode = True
       
         Else
                If Not (((StrComp(attrName, "") = 0) Or (StrComp(AttrValue, "") = 0))) Then
                Set oAttr = doc.createAttribute(attrName)
                Parent.setAttribute attrName, AttrValue
               
                AddNode = True
                Else
                AddNode = False
                End If
        End If
        Exit Function
ErrHand:
        AddNode = False
Debug.Print "Error Addong Node (" & ErrObject & ")"
Debug.Print Err.Description
End Function


Public Function FillXML(xnodes() As String, strXML As String) As String
'This method requires that the array size be greater than or equal to the amount
'of "writable" nodes in the XML document. Also, the order of the values in the
'array should sync up with the order of their respective "writable" nodes in the 'XML document.
On Error GoTo ErrFill

Dim I As Integer
Dim str As String
Dim objXMl As DOMDocument30
Dim objXMLList As IXMLDOMNodeList

Set objXMl = New DOMDocument30
objXMl.loadXML strXML

Set objXMLList = objXMl.getElementsByTagName("*")
t = 0
MaxNodes = objXMl.getElementsByTagName("*").length

For I = 0 To MaxNodes - 1
'Here we make a list of child nodes for every element in the list.
Set ElementList = objXMLList.Item(I).childNodes
'If there is only one child in the list then we write the value in the array to that node.
If ElementList.length = 1 Then
objXMl.getElementsByTagName("*").Item(I).Text = xnodes(t)
t = t + 1
End If
Next I
FillXML = True
strXML = objXMl.xml
Exit Function

ErrFill:
FillXML = False
End Function

Public Function PostXML(sBuffer As String, strUrl As String, Optional sResponse As String) As String

Dim iRetVal     As Integer

Dim lBufferLen  As Long
Dim vDllVersion As tWinInetDLLVersion
Dim sStatus     As String
Dim sOptionBuffer   As String
Dim lOptionBufferLen As Long
Dim lblMajor As String
Dim lblMinor As String
Dim dwTimeOut As Long
Dim bDoLoop             As Boolean
Dim sReadBuffer         As String * 2048
Dim lNumberOfBytesRead  As Long
Dim sResponseBuffer             As String
'***************************************************
Const username As String = "demo22"
Const password As String = "demo22"
'Normally you would take the strUrl parameter and parse it but for example purposes we are using constants.
Const URL As String = "ups.com"
Const URLObject As String = "/ups.app/xml/Track" ' This portion of the URL will not always have 'Track' in it. The last word will change base on the tool you are using.
'***************************************************

'Set the Time out value for the INTERNET_OPTION_CONNECT_TIMEOUT, INTERNET_OPTION_RECEIVE_TIMEOUT,INTERNET_OPTION_SEND_TIMEOUT
dwTimeOut = 60000

If Len(Trim(strUrl)) <> 0 Then mvtxtUrl = strUrl

lBufferLen = Len(sBuffer)

hInternetSession = 0
hHttpOpenRequest = 0
hInternetConnect = 0

' Open session
hInternetSession = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, "proxy.ups.com:8080", vbNullString, 0)

If CBool(hInternetSession) Then
    'Set DLL Major/Minor version variables
    InternetQueryOption hInternetSession, INTERNET_OPTION_VERSION, vDllVersion, Len(vDllVersion)
    lblMajor = vDllVersion.lMajorVersion
    lblMinor = vDllVersion.lMinorVersion
   
   'Open Connection
    hInternetConnect = InternetConnect(hInternetSession, URL, INTERNET_DEFAULT_HTTPS_PORT, _
    vbNullString, vbNullString, INTERNET_SERVICE_HTTP, 0, 0)
   
    If hInternetConnect > 0 Then
            sOptionBuffer = sBuffer
         
            lOptionBufferLen = Len(sOptionBuffer)
         
            hHttpOpenRequest = HttpOpenRequest(hInternetConnect, "POST", URLObject, "HTTP/1.0", vbNullString, 0, _
            INTERNET_FLAG_RELOAD Or INTERNET_FLAG_MULTIPART Or INTERNET_FLAG_SECURE Or INTERNET_FLAG_IGNORE_CERT_CN_INVALID Or INTERNET_FLAG_IGNORE_CERT_DATE_INVALID, 0)
   
        If CBool(hHttpOpenRequest) Then
                       
            sHeader = "Content-Length: " & lOptionBufferLen & vbCrLf
            iRetVal = HttpAddRequestHeaders(hHttpOpenRequest, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
            Debug.Print iRetVal & " " & sHeader;
           
            sHeader = "Accept-Language: en" & vbCrLf
            iRetVal = HttpAddRequestHeaders(hHttpOpenRequest, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
            Debug.Print iRetVal & " " & sHeader
                       
            sHeader = "Connection: Keep-Alive" & vbCrLf
            iRetVal = HttpAddRequestHeaders(hHttpOpenRequest, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
            Debug.Print iRetVal & " " & sHeader;
 
            sHeader = "Content-Type: application/x-www-form-urlencoded" & vbCrLf
            iRetVal = HttpAddRequestHeaders(hHttpOpenRequest, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
            Debug.Print iRetVal & " " & sHeader;
       
           iRetVal = InternetSetOptionStr(hHttpOpenRequest, INTERNET_OPTION_PROXY_USERNAME, username, Len(username) + 1)
                Debug.Print "in by proxy usr " & iRetVal
           
            iRetVal = InternetSetOptionStr(hHttpOpenRequest, INTERNET_OPTION_PROXY_PASSWORD, password, Len(password) + 1)
                Debug.Print "in by proxy psw " & iRetVal
           
            iRetVal = InternetSetOption(hHttpOpenRequest, INTERNET_OPTION_CONNECT_TIMEOUT, dwTimeOut, 4)
            Debug.Print iRetVal & " " & Err.LastDllError & " " & "INTERNET_OPTION_CONNECT_TIMEOUT"
           
            iRetVal = InternetSetOption(hHttpOpenRequest, INTERNET_OPTION_RECEIVE_TIMEOUT, dwTimeOut, 4)
            Debug.Print iRetVal & " " & "INTERNET_OPTION_RECEIVE_TIMEOUT"
           
            iRetVal = InternetSetOption(hHttpOpenRequest, INTERNET_OPTION_SEND_TIMEOUT, dwTimeOut, 4)
            Debug.Print iRetVal & " " & "INTERNET_OPTION_SEND_TIMEOUT"
             
           
Resend:
       
            iRetVal = HttpSendRequest(hHttpOpenRequest, vbNullString, 0, sOptionBuffer, lOptionBufferLen)
               
            Dim dwStatus As Long, dwStatusSize As Long
            dwStatusSize = Len(dwStatus)
            HttpQueryInfo hHttpOpenRequest, HTTP_QUERY_FLAG_NUMBER Or HTTP_QUERY_STATUS_CODE, dwStatus, dwStatusSize, 0
            Select Case dwStatus
                Case HTTP_STATUS_PROXY_AUTH_REQ
                'make sure change it to your user name and password.
                'Note Poxy authentication only works for IE40 wininet. For IE3.0x, you need to
                'manually add Proxy-Authentication header.
                'GoTo Resend
              Case HTTP_STATUS_DENIED
                iRetVal = InternetSetOptionStr(hHttpOpenRequest, INTERNET_OPTION_USERNAME, _
        username, Len(username) + 1)
                iRetVal = InternetSetOptionStr(hHttpOpenRequest, INTERNET_OPTION_PASSWORD, _
        password, Len(password) + 1)
            GoTo Resend
           End Select
           
       Else
            ' HttpOpenRequest failed
           sResponse = "HttpOpenRequest call failed; Error code: " & Err.LastDllError & "."
           PostXML = False
        End If
    Else
        ' InternetConnect failed
       sResponse = "InternetConnect call failed; Error code: " & Err.LastDllError & "."
        PostXML = False
    End If
Else
    ' hInternetSession handle not allocated
    sResponse = "InternetOpen call failed: Error code: " & Err.LastDllError & "."
    PostXML = False
End If

'This code will capture the response from the server and passes it back out through the sResponse variable
On Error GoTo ErrHand

bDoLoop = True

While bDoLoop
    sReadBuffer = vbNullString
    bDoLoop = InternetReadFile(hHttpOpenRequest, sReadBuffer, Len(sReadBuffer), TotalBytesRead)
    sResponseBuffer = sResponseBuffer & Left$(sReadBuffer, TotalBytesRead)
    If Not CBool(TotalBytesRead) Then bDoLoop = False
    Debug.Print sReadBuffer
Wend
sResponse = sResponseBuffer
PostXML = True
Exit Function

ErrHand:
sResponse = "There was a problem processing the XML response."
PostXML = False
 
End Function

Public Sub DecodeLabels(strXML As String)
On Error Resume Next
   
    Dim xnodelist As IXMLDOMNodeList
    Dim TrackNum As String
    Dim xnode As IXMLDOMNode
    Dim xdoc As DOMDocument30
    Dim ynode As IXMLDOMNode
    Dim objNode As IXMLDOMNode
    Dim xElement As IXMLDOMElement
    Dim I As Long
    Dim xmlDoc As New MSXML2.DOMDocument30
    Dim xmlDocTest As New MSXML2.DOMDocument30
    Dim childNode As IXMLDOMText
    Dim btArr() As Byte
   
    Debug.Print "Decode Label"
    Set xdoc = New DOMDocument30
    xdoc.loadXML strXML
   
    'Set xnode = xdoc.selectSingleNode("ShipmentAcceptResponse/ShipmentResults/PackageResults/LabelImage/GraphicImage")
    Set xnodelist = xdoc.getElementsByTagName("*")
   
    Set xnode = xnodelist.nextNode
   
  For Each xnode In xnodelist
    Select Case xnode.nodeName
   
        Case "GraphicImage"
                   
                    Set xmlDoc.documentElement = xmlDoc.createElement("Label")
                    Set childNode = xmlDoc.createNode(NODE_TEXT, "", "")
                    xmlDoc.documentElement.appendChild childNode
                    xmlDoc.documentElement.dataType = "bin.base64"
                    childNode.nodeTypedValue = xnode.Text
                    xmlDocTest.async = False
                    xmlDocTest.Load xmlDoc
                    Debug.Print xmlDoc.xml
                    Set ynode = xmlDocTest.selectSingleNode("Label")
                   
                    btArr = ynode.nodeTypedValue
                    Debug.Print btArr
                    strFile = "d:\ShippingTests\Label" & TrackNum & ".gif"
                    Open strFile For Binary As #1
                    Put #1, 1, btArr
                    Close #1
        Case "HTMLImage"
               
                Set xmlDoc.documentElement = xmlDoc.createElement("HTML")
                Set childNode = xmlDoc.createNode(NODE_TEXT, "", "")
                xmlDoc.documentElement.appendChild childNode
                xmlDoc.documentElement.dataType = "bin.base64"
                childNode.nodeTypedValue = xnode.Text
                xmlDocTest.async = False
                xmlDocTest.Load xmlDoc
                Debug.Print xmlDoc.xml
                Set ynode = xmlDocTest.selectSingleNode("HTML")
               
                btArr = ynode.nodeTypedValue
                Debug.Print btArr
                strFile = "d:\ShippingTests\" & TrackNum & ".html"
                Open strFile For Binary As #2
                Put #2, 1, btArr
            Close #2
        Case "TrackingNumber"
                    TrackNum = xnode.Text
    End Select
  Next
End Sub
0
kanden
Asked:
kanden
  • 2
1 Solution
 
Bob LearnedCommented:
Did you ask UPS if they had an updated version for .NET?

Bob
0
 
kandenAuthor Commented:
The Don't,

But I did find this asp version. Is there a way to do this in .net(VB)

<%
  Response.Buffer = True
  Dim objXMLHTTP, xml
  Set xml = Server.CreateObject("Microsoft.XMLHTTP")

  'post the xml to UPS
  xml.Open "POST", "(your UPS URL)", False
  xml.Send "(your formatted XML request)"

  'get xml response from UPS
  upsResponse = xml.responseText

  Set xml = Nothing

  'add code here to load the upsResponse into
  'an XML DOM object so you can parse through
  'it.
%>
 
0
 
Bob LearnedCommented:
This is C#, but it can be converted:

How to use HttpWebRequest to send POST request to another web server
http://www.netomatix.com/HttpPostData.aspx

Bob
0
 
netsmithcentralCommented:
The code provided by UPS has several problems.

1.  In the AddNode function, Parent shoud be defined:
    Dim Parent As MSXML2.IXMLDOMElement

2. In the AddNode function, oAttr is defined in a Dim statement and Set but not used

3. No explanation of how the FillXML function is actually used.

The documentation "UPS OnlineTools Rates and Service Selection XML Tool"
is not in the RSS_dev_guide directory of the zip file but rather in the root as
RSS_Tool_02_09_09.pdf

This information is provided in the hope of shortening development time for other Visual Basic developers (took me hours).
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now