Reading USPS page results

J

Jim

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
 
B

Bernie Deitrick

Jim,

The function code below will return the post office's city, used like

=ZipToPostOffice("30339")
or
=ZipToPostOffice(30339)
or
=ZipToPostOffice(A2)
where A2 has 30339

Any of these will return "ATLANTA, GA"

HTH,
Bernie
MS Excel MVP

Function ZipToPostOffice(ZIP5 As String) As String

Dim ie As Object
Dim sResult As String
Dim sCityState As String
Dim lStartZip As Long
Dim dtTimer As Date
Dim lAddTime As Long

Const sUPSURL As String = "http://zip4.usps.com/zip4/citytown_zip.jsp"
'"http://zip4.usps.com/zip4/welcome.jsp"
Const lREADYSTATE_COMPLETE As Long = 4

Set ie = CreateObject("InternetExplorer.Application")
ie.silent = True
ie.navigate "http://zip4.usps.com/zip4/citytown_zip.jsp"
'"http://zip4.usps.com/zip4/welcome.jsp"

dtTimer = Now
lAddTime = TimeValue("00:00:20")

Do Until ie.readystate = lREADYSTATE_COMPLETE And Not ie.busy
DoEvents
If dtTimer + lAddTime > Now Then Exit Do
Loop

ie.document.form1.ZIP5.Value = ZIP5
ie.document.form1.submit

dtTimer = Now
lAddTime = TimeValue("00:00:20")

Do Until ie.readystate = lREADYSTATE_COMPLETE And Not ie.busy
DoEvents
If dtTimer + lAddTime > Now Then Exit Do
Loop

sResult = ie.document.body.innertext
lStartZip = InStr(1, sResult, ZIP5, vbTextCompare)
lStartZip = InStr(lStartZip + 1, sResult, ZIP5, vbTextCompare)
If lStartZip > 0 Then
ZipToPostOffice = Mid(sResult, lStartZip + 10, 100)
ZipToPostOffice = Mid(ZipToPostOffice, 1, InStr(1, ZipToPostOffice, Chr(13)) - 1)
Else
ZipToPostOffice = "Not Found"
End If

ie.Quit
Set ie = Nothing

End Function
 
K

ker_01

Alternatively, you can download the full list of USA zip codes and just embed
it in your workbook- for example, www.zipcodeworld.com (look at the 'free'
option) I think has zips with city name. I did a little more searching a
month or two ago and found a free database online that had zip, city, state,
latitude, and longitude. If you decide to go this route but can't find what
you are looking for, post back and we can connect offline.

HTH,
Keith
 
R

Ron Rosenfeld

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
Click to expand...

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
 
J

Jim

Thanks Ron and everyone else who replied. I was able to get what I needed
through these posts.
--
Jim


Ron Rosenfeld said:
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
Click to expand...

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
Click to expand...
 
R

Ron Rosenfeld

Alternatively, you can download the full list of USA zip codes and just embed
it in your workbook- for example, www.zipcodeworld.com (look at the 'free'
option) I think has zips with city name. I did a little more searching a
month or two ago and found a free database online that had zip, city, state,
latitude, and longitude. If you decide to go this route but can't find what
you are looking for, post back and we can connect offline.

HTH,
Keith
Click to expand...

Just for archival purposes, I would note that the FREE version only has state
information. There is no CITY information, which would be critical for this
application.
--ron
 
K

ker_01

I had suspected that might be the case- but I did find a free table online
*somewhere* recently that had the city/state as well (I'm using it in a
project I just finished)- but I figured the OP could find it as easily as I
could again, or they could connect with me outside of the forum to get a copy
directly from me

Best,
Keith
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Reading Post Office Web Page 1
2003 Macro not working in 2007 1
Download data from web page 11
HELP!! Download data to workbook 4
Download data from secure website into new Worksheet 12
web automation - repost 0
++ Web automation 2
Need Help Pls - What's wrong with this? 7

Top