Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Reading USPS page results
On Mon, 21 Sep 2009 07:39:01 -0700, Jim wrote:
I am trying to read a the Post Office web page after I submit a zip code. The following is what I have copied from anther site and have modified. The orginal code had "Set objTable = objDoc.getElementById("idTable")" to "Set objTable = objDoc.getElementsByTagName("table")" due to the table not having an id. Being new at programming, I'm not sure as to what I'm doing wrong. It will work until I get to Set objCell = objTable.Rows(c), then I take an error. My code is as follows: Sub MFHLookup() Dim objIE As Object Dim objDoc As Object Dim objTable As Object Dim objCell As Object Dim FormValue As String Dim Anymore As Boolean Dim Found As Boolean Dim c Do Until Anymore = True FormValue = ActiveCell.Value Set objIE = CreateObject("InternetExplorer.Application") objIE.Visible = False objIE.Navigate "http://zip4.usps.com/zip4/citytown_zip.jsp" Do While objIE.Busy: DoEvents: Loop Do While objIE.ReadyState < 4: DoEvents: Loop objIE.Visible = True With objIE .Document.getElementById("zip5").Focus .Document.getElementById("zip5").Value = "30339" .Document.getElementById("submit").Click Do While .Busy: DoEvents: Loop Do While .ReadyState < 4: DoEvents: Loop End With Set objDoc = objIE.Document Set objTable = objDoc.getElementsByTagName("table") c = 20 Set objCell = objTable.Rows(c) If Trim(objCell.InnerText) < "30339" Then Do Until Found = True c = c + 1 Set objCell = objTable.Cells(c) If Trim(objCell.InnerText) < "30339" Then Found = False Else Found = True End If Loop Else End If c = c + 1 Set objCell = objTable.Cells(c) ActiveCell.Offset(0, 1).Value = Trim(objCell.InnerText) objIE.Quit Set objIE = Nothing Set objDoc = Nothing Set objTable = Nothing Set objCell = Nothing ActiveCell.Offset(1, 0).Select Anymore = IsEmpty(ActiveCell.Value) Loop ActiveWorkbook.Save End Sub Thanks for the help, Jim The USPS Zip Code lookup page will return multiple acceptable city/state matches for a given 5 digit zip code. The function below will return all of them, in a 2 dimensional array with the cities in row 1; and the states in row2. So they can be accessed using the INDEX worksheet function, with the appropriate row and column entries. Also, the total number of city/state pairs returned would =counta(index(revzip(cell_ref))) / 2 However, this routine requires one call to the USPS page for each segment of the zip code. IF you are processing a large number, this can take quite a while. A more efficient method would be to input your data via the Sub which is also below, and precedes the function. It only requires a single call to the USPS page per zip-code, and then outputs all acceptable city/state matches to a location on the worksheet which, as written, would start with the selected cell. You could modify this in many ways, depending on what you ultimately require. Enjoy. Note that I use early binding for the IE object, and see the comments in the function for setting the appropriate reference. ============================================= Option Explicit Sub ZipLookup() Dim s As String Dim v As Variant Dim i As Long Dim c As Range s = InputBox("ZipCode") v = RevZip(s) Set c = Selection c.Value = "Zip Code: " & s For i = 0 To UBound(v, 2) c.Offset(i + 1, 0).Value = v(0, i) c.Offset(i + 1, 1).Value = v(1, i) Next i End Sub Function RevZip(ByRef sZip5 As String) As Variant 'returns 2D array of each city/state pair 'in the zip code 'Row 1 contains the acceptable cities 'Row 2 contains the associated states 'Set reference to Microsoft Internet Controls ' In Excel 2007, this is called "Microsoft Browser Helpers" Dim IE As InternetExplorer Const sURL As String = "http://zip4.usps.com/zip4/citytown_zip.jsp" Dim sHTML As String Dim sTemp() As String Dim i As Long ' Group2 = City Group3=State IGNORE CASE Const rePattern As String = "headers=pre(<b)?([^,]+),\s([^<]+)" Dim lNumCities As Long sZip5 = Format(Left(sZip5, 5), "00000") Application.Cursor = xlWait Set IE = New InternetExplorer IE.Navigate sURL IE.Visible = False Do While IE.ReadyState < READYSTATE_COMPLETE DoEvents Loop Do While IE.Busy = True DoEvents Loop IE.Document.all("zip5").Value = sZip5 IE.Document.all("Submit").Click Do While IE.ReadyState < READYSTATE_COMPLETE DoEvents Loop Do While IE.Busy = True DoEvents Loop sHTML = IE.Document.body.innerhtml IE.Quit Application.Cursor = xlDefault 'Note that the USPS site can return multiple 'cities for each zip code. So we need to 'return them all lNumCities = RegexCount(sHTML, rePattern) ReDim sTemp(0 To 1, 0 To lNumCities - 1) For i = 0 To lNumCities - 1 sTemp(0, i) = RegexMid(sHTML, rePattern, i + 1, 2) sTemp(1, i) = RegexMid(sHTML, rePattern, i + 1, 3) Next i RevZip = sTemp End Function Private Function RegexMid(s As String, sPat As String, _ Optional Index As Long = 1, _ Optional Subindex As Long, _ Optional CaseIgnore As Boolean = True, _ Optional Glbl As Boolean = True, _ Optional Multiline As Boolean = False) As String Dim re As Object, mc As Object Dim i As Long Set re = CreateObject("vbscript.regexp") re.Pattern = sPat re.IgnoreCase = CaseIgnore re.Global = Glbl re.Multiline = Multiline If re.Test(s) = True Then Set mc = re.Execute(s) If Subindex = 0 Then RegexMid = mc(Index - 1) ElseIf Subindex <= mc(Index - 1).SubMatches.Count Then RegexMid = mc(Index - 1).SubMatches(Subindex - 1) End If End If Set re = Nothing End Function Private Function RegexCount(s As String, sPat As String) As Long Dim re As RegExp, mc As MatchCollection Set re = New RegExp re.Pattern = sPat re.Global = True re.IgnoreCase = True Set mc = re.Execute(s) RegexCount = mc.Count Set re = Nothing End Function ========================================== --ron |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Reading USPS page results
Thanks Ron and everyone else who replied. I was able to get what I needed
through these posts. -- Jim "Ron Rosenfeld" wrote: On Mon, 21 Sep 2009 07:39:01 -0700, Jim wrote: I am trying to read a the Post Office web page after I submit a zip code. The following is what I have copied from anther site and have modified. The orginal code had "Set objTable = objDoc.getElementById("idTable")" to "Set objTable = objDoc.getElementsByTagName("table")" due to the table not having an id. Being new at programming, I'm not sure as to what I'm doing wrong. It will work until I get to Set objCell = objTable.Rows(c), then I take an error. My code is as follows: Sub MFHLookup() Dim objIE As Object Dim objDoc As Object Dim objTable As Object Dim objCell As Object Dim FormValue As String Dim Anymore As Boolean Dim Found As Boolean Dim c Do Until Anymore = True FormValue = ActiveCell.Value Set objIE = CreateObject("InternetExplorer.Application") objIE.Visible = False objIE.Navigate "http://zip4.usps.com/zip4/citytown_zip.jsp" Do While objIE.Busy: DoEvents: Loop Do While objIE.ReadyState < 4: DoEvents: Loop objIE.Visible = True With objIE .Document.getElementById("zip5").Focus .Document.getElementById("zip5").Value = "30339" .Document.getElementById("submit").Click Do While .Busy: DoEvents: Loop Do While .ReadyState < 4: DoEvents: Loop End With Set objDoc = objIE.Document Set objTable = objDoc.getElementsByTagName("table") c = 20 Set objCell = objTable.Rows(c) If Trim(objCell.InnerText) < "30339" Then Do Until Found = True c = c + 1 Set objCell = objTable.Cells(c) If Trim(objCell.InnerText) < "30339" Then Found = False Else Found = True End If Loop Else End If c = c + 1 Set objCell = objTable.Cells(c) ActiveCell.Offset(0, 1).Value = Trim(objCell.InnerText) objIE.Quit Set objIE = Nothing Set objDoc = Nothing Set objTable = Nothing Set objCell = Nothing ActiveCell.Offset(1, 0).Select Anymore = IsEmpty(ActiveCell.Value) Loop ActiveWorkbook.Save End Sub Thanks for the help, Jim The USPS Zip Code lookup page will return multiple acceptable city/state matches for a given 5 digit zip code. The function below will return all of them, in a 2 dimensional array with the cities in row 1; and the states in row2. So they can be accessed using the INDEX worksheet function, with the appropriate row and column entries. Also, the total number of city/state pairs returned would =counta(index(revzip(cell_ref))) / 2 However, this routine requires one call to the USPS page for each segment of the zip code. IF you are processing a large number, this can take quite a while. A more efficient method would be to input your data via the Sub which is also below, and precedes the function. It only requires a single call to the USPS page per zip-code, and then outputs all acceptable city/state matches to a location on the worksheet which, as written, would start with the selected cell. You could modify this in many ways, depending on what you ultimately require. Enjoy. Note that I use early binding for the IE object, and see the comments in the function for setting the appropriate reference. ============================================= Option Explicit Sub ZipLookup() Dim s As String Dim v As Variant Dim i As Long Dim c As Range s = InputBox("ZipCode") v = RevZip(s) Set c = Selection c.Value = "Zip Code: " & s For i = 0 To UBound(v, 2) c.Offset(i + 1, 0).Value = v(0, i) c.Offset(i + 1, 1).Value = v(1, i) Next i End Sub Function RevZip(ByRef sZip5 As String) As Variant 'returns 2D array of each city/state pair 'in the zip code 'Row 1 contains the acceptable cities 'Row 2 contains the associated states 'Set reference to Microsoft Internet Controls ' In Excel 2007, this is called "Microsoft Browser Helpers" Dim IE As InternetExplorer Const sURL As String = "http://zip4.usps.com/zip4/citytown_zip.jsp" Dim sHTML As String Dim sTemp() As String Dim i As Long ' Group2 = City Group3=State IGNORE CASE Const rePattern As String = "headers=pre(<b)?([^,]+),\s([^<]+)" Dim lNumCities As Long sZip5 = Format(Left(sZip5, 5), "00000") Application.Cursor = xlWait Set IE = New InternetExplorer IE.Navigate sURL IE.Visible = False Do While IE.ReadyState < READYSTATE_COMPLETE DoEvents Loop Do While IE.Busy = True DoEvents Loop IE.Document.all("zip5").Value = sZip5 IE.Document.all("Submit").Click Do While IE.ReadyState < READYSTATE_COMPLETE DoEvents Loop Do While IE.Busy = True DoEvents Loop sHTML = IE.Document.body.innerhtml IE.Quit Application.Cursor = xlDefault 'Note that the USPS site can return multiple 'cities for each zip code. So we need to 'return them all lNumCities = RegexCount(sHTML, rePattern) ReDim sTemp(0 To 1, 0 To lNumCities - 1) For i = 0 To lNumCities - 1 sTemp(0, i) = RegexMid(sHTML, rePattern, i + 1, 2) sTemp(1, i) = RegexMid(sHTML, rePattern, i + 1, 3) Next i RevZip = sTemp End Function Private Function RegexMid(s As String, sPat As String, _ Optional Index As Long = 1, _ Optional Subindex As Long, _ Optional CaseIgnore As Boolean = True, _ Optional Glbl As Boolean = True, _ Optional Multiline As Boolean = False) As String Dim re As Object, mc As Object Dim i As Long Set re = CreateObject("vbscript.regexp") re.Pattern = sPat re.IgnoreCase = CaseIgnore re.Global = Glbl re.Multiline = Multiline If re.Test(s) = True Then Set mc = re.Execute(s) If Subindex = 0 Then RegexMid = mc(Index - 1) ElseIf Subindex <= mc(Index - 1).SubMatches.Count Then RegexMid = mc(Index - 1).SubMatches(Subindex - 1) End If End If Set re = Nothing End Function Private Function RegexCount(s As String, sPat As String) As Long Dim re As RegExp, mc As MatchCollection Set re = New RegExp re.Pattern = sPat re.Global = True re.IgnoreCase = True Set mc = re.Execute(s) RegexCount = mc.Count Set re = Nothing End Function ========================================== --ron |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Reading USPS page results | Excel Programming | |||
Reading Multiple Pages Listing Top three Results. | Excel Worksheet Functions | |||
Reading results for automated Myers Briggs Type Indicator? | Excel Worksheet Functions | |||
Writing and reading from a template Excel file using ADO.Net - results not recalculated | Excel Programming | |||
Return US State Name or Territory from USPS Abbrevation - an example | Excel Programming |