我跟踪POD的在线资讯。我从代理后面执行此操作并在查询中使用Microsoft Access来执行该功能以下载跟踪信息并将其解析出来。基本代码如下。我使用的功能是TrackNew（trackingNumber）。每天早上，当我运行此access.exe时，都要求我提供凭据。我从UPS和FedEx xml网关跟踪，它没有要求代理凭证。有没有办法可以在我的代码中添加凭据，所以它没有提示这个？ 在顶部是使这项工作的一切。底部是实际功能。
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
这是提示我输入代理的Windows域凭据的地方。
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
以下是实际跟踪代码：
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
任何帮助将不胜感激。我需要实际的代码或引用行，以提示我代理Windows凭据。
我找到了这段代码。在GETMSXML下我可以添加这个吗？
'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"