Proxy Authenticaton VBA - How to not prompt? - vba

Question

I track POD's Online. I do it from behind a proxy and use Microsoft Access in a query to execute the function to download the tracking information and parse it out. The base code is below. The function I use is TrackNew(trackingNumber). Each morning when I run this access.exe is asking for my credentials. I track from UPS and FedEx xml gateways and it doesn't ask for the proxy credentials. Is there a way that I can add the credentials inside my code so it doesn't prompt for this?
Here at the top is everything that makes this work. At the bottom is the actual function.
Private Enum HTTPequestType
HTTP_GET
HTTP_POST
HTTP_HEAD
End Enum
#If VBA7 Then
' 64-bit
Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet"
(ByRef dwflags As LongPtr, _
ByVal dwReserved As Long) As Long
#Else
' pre 64-bit
Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet"
(ByRef dwflags As Long, _
ByVal
dwReserved As Long) As Long
#End If
Private Const CONNECT_LAN As Long = &H2
Private Const CONNECT_MODEM As Long = &H1
Private Const CONNECT_PROXY As Long = &H4
Private Const CONNECT_OFFLINE As Long = &H20
Private Const CONNECT_CONFIGURED As Long = &H40
' Application Objects
Private xl As Access.Application
' misc symbols
Private Const CHAR_SPACE As String = " "
Private Const CHAR_UNDERSCORE As String = "_"
Private Const CHAR_COMMA As String = ","
Private Const CHAR_SLASH As String = "/"
Private Const AT_SYMBOL As String = "#"
' list of carriers (must be UPPER CASE, comma-delimited)
Private Const CARRIER_LIST As String =
"UPS,UPS1,UPS2,UPS3,UPS4,UPS5,UPS6,UPS7,UPS8,NEW,DHL,DHL1,FEDEX,FEDEX2,FEDEX3,FEDEX4,FEDEX5,HOLLAND,CONWAY,ABF,CEVA,USPS,TNT,YRCREGIONAL,YRC,NEMF,A1,RWORLDCOURIER,BLUEDART,TCIXPS,PUROLATOR,EXPINT,CMACGM,SAFM,PLG,DHL,ONTRAC,AAACT,RLC,ODFL,SAIA,DHLGLOBAL,LASERSHIP"
' MSXML stuff
Private Const MSXML_VERSION As String = "6.0"
' error Msgs
Private Const UNKNOWN_CARRIER As String = "Unknown carrier"
Private Const ERROR_MSG As String = "Error"
Private Const PACKAGE_NOT_FOUND As String = "Package Not Found"
Private Const MSIE_ERROR As String = "Cannot start Internet Explorer."
Private Const MSXML_ERROR As String = "Cannot start MSXML 6.0."
Private Const MSHTML_ERROR As String = "Cannot load MSHTML Object library."
' URLs for each carrier
Private Const NEWUrl As String = "https://www.newpenn.com/embeddable-tracking-results/?track="
'
' system functions
'
Private Function GetAppTitle() As String
GetAppTitle = App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision
End Function
Private Function IsWindowsOS() As Boolean
' true if operating system is Windows
IsWindowsOS = (GetWindowsOS Like "*Win*")
End Function
'
' required addin procedures
'
Private Sub AddinInstance_OnAddInsUpdate(custom() As Variant)
' needed for operation
Exit Sub
End Sub
Private Sub AddinInstance_OnStartupComplete(custom() As Variant)
' needed for operation
Exit Sub
End Sub
' helper functions
Private Function GetRequestType(reqType As HTTPequestType) As String
Select Case reqType
Case 1
GetRequestType = "POST"
Case 2
GetRequestType = "HEAD"
Case Else ' GET is default
GetRequestType = "GET"
End Select
End Function
Private Function IsValidCarrier(CarrierName As String) As Boolean
' returns TRUE if the given carrier is on the global list
Dim carriers() As String
carriers = Split(CARRIER_LIST, ",")
IsValidCarrier = (UBound(Filter(carriers, CarrierName)) > -1)
End Function
Private Function GetHTMLAnchors(htmlDoc As Object) As Object ' MSHTML.IHTMLElementCollection
On Error Resume Next
Set GetHTMLAnchors = htmlDoc.anchors
End Function
Private Function LoadError(xmlDoc As Object) As Boolean
' checks if a xml file load error occurred
LoadError = (xmlDoc.parseError.ErrorCode <> 0)
End Function
Private Function GetRootNode(xmlDoc As Object) As Object
' returns root node
Set GetRootNode = xmlDoc.DocumentElement
End Function
Private Function GetNode(parentNode As Object, nodeNumber As Long) As Object
On Error Resume Next
' if parentNode is a MSXML2.IXMLDOMNodeList
Set GetNode = parentNode.Item(nodeNumber - 1)
' if parentNode is a MSXML2.IXMLDOMNode
If GetNode Is Nothing Then
Set GetNode = parentNode.ChildNodes(nodeNumber - 1)
End If
End Function
Private Function CreateFile(fileName As String, contents As String) As String
' creates file from string contents
Dim TempFile As String
Dim nextFileNum As Long
nextFileNum = FreeFile
TempFile = fileName
Open TempFile For Output As #nextFileNum
Print #nextFileNum, contents
Close #nextFileNum
CreateFile = TempFile
End Function
Here is where it prompts me for the windows domain credentials for the proxy.
Private Function GetResponse(xml As Object, requestType As HTTPequestType, _
destinationURL As String, Optional async As Boolean, _
Optional requestHeaders As Variant, Optional postContent As String) As String
Dim reqType As String
Dim response As String
Dim i As Long
reqType = GetRequestType(requestType)
With xml
.Open reqType, destinationURL, async
' check for headers
If Not IsMissing(requestHeaders) Then
For i = LBound(requestHeaders) To UBound(requestHeaders)
.setRequestHeader requestHeaders(i, 1), requestHeaders(i, 2)
Next i
End If
' if HTTP POST, need to send contents
' will not harm GET or HEAD requests
.Send (postContent)
' if HEAD request, return headers, not response
If reqType = "HEAD" Then
response = xml.getAllResponseHeaders
Else
response = xml.responseText
End If
End With
GetResponse = response
End Function
Private Function GetRequestHeaders() As Variant
Dim tempArray(1 To 1, 1 To 2) As Variant
tempArray(1, 1) = "Content-Type"
tempArray(1, 2) = "application/x-www-form-urlencoded"
GetRequestHeaders = tempArray
End Function
' major objects
Private Function GetMSIE() As Object ' InternetExplorer.Application
On Error Resume Next
Set GetMSIE = CreateObject("InternetExplorer.Application")
End Function
Private Function CreateHTMLDoc() As Object ' MSHTML.HTMLDocument
On Error Resume Next
Set CreateHTMLDoc = CreateObject("htmlfile")
End Function
Private Function GetMSXML() As Object ' MSXML2.XMLHTTP60
On Error Resume Next
Set GetMSXML = CreateObject("MSXML2.XMLHTTP" & IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
End Function
Private Function GetServerMSXML() As Object
On Error Resume Next
Set GetServerMSXML = CreateObject("MSXML2.ServerXMLHTTP" &
IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
End Function
Private Function CreateXMLDoc() As Object ' MSXML2.DOMDocument60
On Error Resume Next
Set CreateXMLDoc = CreateObject("MSXML2.DOMDocument" & IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
End Function
' XMLHTTP or MSIE
'''''Private Function GetMSXMLWebResponse(URL As String) As String
''''' Dim webObject As Object ' MSXML2.XMLHTTP60
''''' Set webObject = GetMSXML
''''' If webObject Is Nothing Then ' cannot start MSXML6
''''' Exit Function
''''' End If
''''' ' open URL and scrape result
''''' With webObject
''''' .Open "GET", URL, False
''''' .send
''''' End With
''''' GetMSXMLWebResponse = webObject.responseText
'''''End Function
Private Function GetMSIEWebResponse(URL As String) As String
Dim webObject As Object ' InternetExplorer.Application
Set webObject = GetMSIE
If webObject Is Nothing Then ' cannot start MSIE
Exit Function
End If
'open the url
webObject.navigate URL
'wait for the site to be ready
Do Until webObject.readyState = 4 ' READYSTATE_COMPLETE
DoEvents
Loop
'read the text from the body of the site
GetMSIEWebResponse = webObject.Document.body.innerText
webObject.Quit
End Function
Here is the actual tracking code:
Private Function TrackNEW(trackingNumber As String) As String
Dim xml As Object
Dim tempString As String
Dim htmlDoc As Object ' MSHTML.HTMLDocument
Dim htmlBody As Object ' MSHTML.htmlBody
Dim anchors As Object ' MSHTML.IHTMLElementCollection
Dim anchor As Object ' MSHTML.IHTMLElement
Dim dda As Object ' MSHTML.IHTMLElementCollection
Dim ddb As Object
Dim ddc As Object
Dim ddd As Object
Dim span As Object
Dim div As Object
Dim class As Object ' MSHTML.IHTMLElement
Set xml = GetMSXML
If xml Is Nothing Then ' cannot start MSXML 6.0
TrackNEW = MSXML_ERROR
Exit Function
End If
tempString = GetResponse(xml, HTTP_GET, NEWUrl & trackingNumber, False)
If Len(tempString) = 0 Then
MsgBox "5"
TrackNEW = ERROR_MSG
Exit Function
End If
Set htmlDoc = CreateHTMLDoc
If htmlDoc Is Nothing Then ' cannot reference MSHTML object library
MsgBox "6"
TrackNEW = MSHTML_ERROR
Exit Function
End If
On Error Resume Next
Set htmlBody = htmlDoc.body
htmlBody.innerHTML = tempString
Set dda = htmlDoc.getElementsByTagName("span")
Set ddb = htmlDoc.getElementsByTagName("span")
Set ddc = htmlDoc.getElementsByTagName("span")
Set ddd = htmlDoc.getElementsByTagName("div")
Item = 1
For Each Strg4 In ddd
For ItemNumber4 = 400 To 450
Strg4 = ddd.Item(ItemNumber4).innerText
If InStr(Strg4, "Projected Delivery Date") >= 1 Then
Why = ItemNumber4
Strg4 = ddd.Item(Why).innerText
GoTo Line8
Else
End If
Next ItemNumber4
Next Strg4
GoTo Line9
Exit Function
Line8:
TrackNEW = "INTRANSIT" & "|" & Right(Strg4, 11)
Exit Function
Line9:
Item = 1
For Each Strg In dda
For ItemNumber = 160 To 200
Strg = dda.Item(ItemNumber).innerText
If InStr(Strg, "DELIVERED") >= 1 Then
That = ItemNumber
Strg = dda.Item(That).innerText
GoTo Line2
Else
End If
Next ItemNumber
Next Strg
GoTo Line1
Line2:
Item2 = 1
For Each Strg2 In ddb
For ItemNumber2 = 160 To 200
Strg2 = ddb.Item(ItemNumber2).innerText
If InStr(Strg2, "DELIVERED") >= 1 Then
This = ItemNumber2 + 3
Strg2 = ddb.Item(This).innerText
GoTo Line3
Else
End If
Next ItemNumber2
Next Strg2
GoTo Line1
Line3:
Item3 = 1
For Each Strg3 In ddb
For ItemNumber3 = 160 To 200
Strg3 = ddb.Item(ItemNumber3).innerText
If InStr(Strg3, "DELIVERED") >= 1 Then
How = ItemNumber3 + 5
Strg3 = ddc.Item(How).innerText
GoTo Line4
Else
End If
Next ItemNumber3
Next Strg3
GoTo Line1
Line4:
TrackNEW = Strg & "|" & Strg2 & "|" & Strg3
Set xml = Nothing
Set htmlDoc = Nothing ' MSHTML.HTMLDocument
Set htmlBody = Nothing ' MSHTML.htmlBody
Set anchors = Nothing ' MSHTML.IHTMLElementCollection
Set anchor = Nothing ' MSHTML.IHTMLElement
Set dda = Nothing
Exit Function
Line1:
TrackNEW = "TRACKING|CANNOT|BE|FOUND"
Set xml = Nothing
Set htmlDoc = Nothing ' MSHTML.HTMLDocument
Set htmlBody = Nothing ' MSHTML.htmlBody
Set anchors = Nothing ' MSHTML.IHTMLElementCollection
Set anchor = Nothing ' MSHTML.IHTMLElement
Set dda = Nothing
Exit Function
End Function
Any help would be appreciated. I need the actual lines of code or reference that would get around it from prompting me for the windows credentials the proxy.
I found this snippet of code. Under the GETMSXML i could add this?
'Set GetMSXML = CreateObject("MSXML2.ServerXMLHTTP" & IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
'xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
'GetMSXML.setProxy 2, "proxy.website.com:8080"
'GetMSXML.setProxyCredentials "user", "password"