Skip to main content

Zip code Functions for VBA

Haven't posted anything to my blog in a while... so here it goes.

I figured that I would contribute some of my code (albeit pretty horrible code) for those who use VBA. I personally don't care much for VBA, but I use it a lot to do some pretty neat stuff in Excel. Anyway... these VBA functions utilize Microsoft's XMLHTTP Object to get some valuable geographic/zip code information.

I have provided a few VBA functions. Some of these functions are definitely hacks, as they assume that the USPS website's structure will remain the same. Although, in my opinion, since USPS.com is run by the US government, it probably won't change any time soon. :)
  1. Function GetCityState(zipcode As String)
    This function connects to the USPS.com website to get the city and state abbreviation for the zip code provided.
  2. Function GetZipcode(address As String, city As String, stateAbbr As String) As String
    This function connects the USPS.com website and tries to get the zip code, given a street address, city, and state abbreviation. The address need not match exactly; it just has to be close enough for the USPS search engine to guess.
  3. Function IsZipCode(data As String) As Boolean
    Will return true if the input is a 5-digit numeric zip code with leading zeros, a 10-character zip code with format "xxxxx-yyyy", or a Canadian zip code with format "xyx yxy" where x is a letter and y is a number
  4. Function GetGeocode(zipcode As String) As String
    Goes to maps.google.com and returns the latitude and longitude of a central point in the zip code specified.
  5. Function GetGeocodeXML(zipcode As String) As String
    Prints out some information (in XML format) about the zip code provided. See the Google Maps API for more details.
OK... Here's the code...
https://blakecomserver.redirectme.net/svn/public/VBA/ZipcodeFunc.bas


Function GetCityState(zipcode As String) As String
Dim xmlHttp As New XMLHTTP60
Dim xmlText As String
Dim currPos As Long
Dim stopPos As Long

'Validate input
If Not IsZipCode(zipcode) Then Exit Function
If Len(zipcode) = 10 Then zipcode = Left(zipcode, 5)
If Len(zipcode) <> 5 Then Exit Function

xmlHttp.Open "GET", "http://zip4.usps.com/zip4/zcl_3_results.jsp?zip5=" & zipcode, False
xmlHttp.send
xmlText = xmlHttp.responseText
currPos = 1
currPos = InStr(currPos, xmlText, "<html") + 1
currPos = InStr(currPos, xmlText, "<body") + 1
currPos = InStr(currPos, xmlText, "<form") + 1
currPos = InStr(currPos, xmlText, "<div") + 1
currPos = InStr(currPos, xmlText, "<div") + 1
currPos = InStr(currPos, xmlText, "<div") + 1
currPos = InStr(currPos, xmlText, "<div") + 1
currPos = InStr(currPos, xmlText, "<div") + 1
currPos = InStr(currPos, xmlText, "<div") + 1
currPos = InStr(currPos, xmlText, "<table") + 1
currPos = InStr(currPos, xmlText, "<tr") + 1
currPos = InStr(currPos, xmlText, "<tr") + 1
currPos = InStr(currPos, xmlText, "<td") + 1
currPos = InStr(currPos, xmlText, "<b") + 1
stopPos = InStr(currPos, xmlText, "</b>")
currPos = currPos + 2
If stopPos = 0 Then
GetCityState = ""
Else
GetCityState = Mid(xmlText, currPos, stopPos - currPos)
'Validate output
If InStr(GetCityState, ", ") = 0 Then GetCityState = ""
End If
End Function
Function GetZipcode(address As String, city As String, stateAbbr As String) As String
Dim xmlHttp As New XMLHTTP60
Dim xmlText As String
Dim currPos As Long
Dim stopPos As Long
Dim i As Integer

'Validate/correct input
address = UCase(address)
city = UCase(city)
stateAbbr = UCase(stateAbbr)
address = Replace(address, "&", "")
address = Replace(address, "=", "")
address = Replace(address, ";", "")
address = Replace(address, """", "")
If Len(stateAbbr) <> 2 Then Exit Function

xmlHttp.Open "GET", "http://zip4.usps.com/zip4/zcl_0_results.jsp?pagenumber=0&firmname=&address1=&address2=" & address & "&city=" & city & "&state=" & stateAbbr & "&zip5=&urbanization=", False
xmlHttp.send
xmlText = xmlHttp.responseText
currPos = 1
currPos = InStr(currPos, xmlText, "<html") + 1
currPos = InStr(currPos, xmlText, "<body") + 1
For i = 1 To 11
currPos = InStr(currPos, xmlText, "<div") + 1
Next i
currPos = InStr(currPos, xmlText, "<table") + 1
currPos = InStr(currPos, xmlText, "<tr") + 1
currPos = InStr(currPos, xmlText, "<th") + 1
currPos = InStr(currPos, xmlText, "<th") + 1
currPos = InStr(currPos, xmlText, "<h2>ZIP + 4 Code</h2>") + 1
If currPos = 1 Then
'<h2>ZIP + 4 Code</h2> was not found. This may only have one zipcode possibility
currPos = InStr(currPos, xmlText, "<html") + 1
currPos = InStr(currPos, xmlText, "<body") + 1
currPos = InStr(currPos, xmlText, "<form") + 1
For i = 1 To 7
currPos = InStr(currPos, xmlText, "<div") + 1
Next i
currPos = InStr(currPos, xmlText, "<table") + 1
currPos = InStr(currPos, xmlText, "<tr") + 1
currPos = InStr(currPos, xmlText, "<tr") + 1
currPos = InStr(currPos, xmlText, "<td") + 1
currPos = InStr(currPos, xmlText, "<br") + 1
currPos = InStr(currPos, xmlText, "&nbsp;&nbsp;") + 1
currPos = currPos + 11
Else
'Find the first zipcode in the list
currPos = InStr(currPos, xmlText, "<tr") + 1
currPos = InStr(currPos, xmlText, "<td") + 1
currPos = InStr(currPos, xmlText, "<td") + 1
currPos = InStr(currPos, xmlText, ">") + 1
End If
stopPos = InStr(currPos, xmlText, "-")
If stopPos = 0 Then
GetZipcode = ""
Else
GetZipcode = Replace(Mid(xmlText, currPos, stopPos - currPos), Chr(9), "")
GetZipcode = Replace(GetZipcode, Chr(10), "")
GetZipcode = Replace(GetZipcode, Chr(13), "")
GetZipcode = Trim(GetZipcode)
'Validate output
If Len(GetZipcode) <> 5 Then
GetZipcode = ""
ElseIf Not IsZipCode(GetZipcode) Then
GetZipcode = ""
End If
End If
End Function
Function IsZipCode(data As String) As Boolean
'Will check to see if this specified data matches the one of the following:
' A 5-digit numeric zip code with leading zeros
' A 10-character zip code with format "xxxxx-yyyy"
' A Canadian zip code with format "xyx yxy" where x is a letter and y is a number
Dim firstFive As String
Dim lastFour As String

If Len(data) = 5 And IsNumeric(data) Then
IsZipCode = (Format(Int(data), "00000") = data)
' ElseIf Len(data) = 9 And IsNumber(data) Then
' IsZipCode = (Format(Int(data), "000000000") = data)
ElseIf Len(data) = 10 And Mid(data, 6, 1) = "-" Then
firstFive = Left(data, 5)
lastFour = Right(data, 4)
If IsNumeric(firstFive) And IsNumeric(lastFour) Then
IsZipCode = (Format(Int(firstFive), "00000") = firstFive) And (Format(Int(lastFour), "0000") = lastFour)
End If
ElseIf Len(data) = 7 Then
Dim numData As String
Dim letterData As String
Dim i As Integer
numData = Mid(data, 2, 1) & Mid(data, 5, 1) & Mid(data, 7, 1)
letterData = UCase(Mid(data, 1, 1) & Mid(data, 3, 1) & Mid(data, 6, 1))
'Remove numerics
For i = 48 To 57
numData = Replace(numData, Chr(i), "")
Next i
'Remove uppercase letters
For i = 65 To 90
letterData = Replace(letterData, Chr(i), "")
Next i
IsZipCode = (Len(numData & letterData) = 0)
Else
IsZipCode = False
End If
End Function
Function GetGeocode(zipcode As String) As String
Dim xmlHttp As New XMLHTTP60
Dim xmlText As String
Dim currPos As Long
Dim stopPos As Long

'Validate input
If Not IsZipCode(zipcode) Then Exit Function
If Len(zipcode) = 10 Then zipcode = Left(zipcode, 5)
If Len(zipcode) <> 5 Then Exit Function

xmlHttp.Open "GET", "http://maps.google.com/maps/api/geocode/xml?sensor=false&address=" & zipcode, False
xmlHttp.send
xmlText = xmlHttp.responseText
currPos = 1
currPos = InStr(currPos, xmlText, "<result") + 1
currPos = InStr(currPos, xmlText, "<body") + 1
currPos = InStr(currPos, xmlText, "<geometry") + 1
currPos = InStr(currPos, xmlText, "<location") + 1
currPos = InStr(currPos, xmlText, "<lat") + 1
stopPos = InStr(currPos, xmlText, "</lat>")
currPos = currPos + 4
GetGeocode = Mid(xmlText, currPos, stopPos - currPos)
currPos = InStr(currPos, xmlText, "<lng") + 1
stopPos = InStr(currPos, xmlText, "</lng>")
currPos = currPos + 4
GetGeocode = GetGeocode & ", " & Mid(xmlText, currPos, stopPos - currPos)
End Function
Function GetGeocodeXML(zipcode As String) As String
Dim xmlHttp As New XMLHTTP60

'Validate input
If Not IsZipCode(zipcode) Then Exit Function
If Len(zipcode) = 10 Then zipcode = Left(zipcode, 5)
If Len(zipcode) <> 5 Then Exit Function

xmlHttp.Open "GET", "http://maps.google.com/maps/api/geocode/xml?sensor=false&address=" & zipcode, False
xmlHttp.send
GetGeocodeXML = xmlHttp.responseText
End Function

Comments

Louis Martin said…
Address Standardisation

Nice.
7:13 AM
Post a Comment

Popular posts from this blog

Beware the Ides of March...in 9 days

Stupid heading for this blog, but whatever.  I was amused.   So, a lot has happened since my last entry, which I believe was sometime in January.  I have officially started a new business -- OnlineFixShop, LLC.  The web address is http://www.onlinefixshop.com/ .  Check it out!  For the next few months, my business will be focusing on home PC repair.     I am offering services that can help you:   Rid your computer of spyware and viruses Retrieve lost information and data Gain access to the Internet Increase your computer's performance and speed Learn your way around various types of software Setup a secure wireless or wired network Back-up personal and valuable data Secure your computer(s) and protect your data Eventually, I am planning to focus on repairing computers over the Internet using remote administration technology, which I have yet to design.   Right now, I am working to setup an onlin...
1 comment
Read more

JavaScript Sticky Footer and Scroll Effect

This post talks about two different HTML/JavaScript effects: How to keep a page footer stuck at the bottom of the browser window. How to create a scrolling <div> without using a scroll bar OK. So... you have a website. You want a header stuck at the top of your page and the footer stuck at the bottom of your page. The stuff in the middle, you want to be able to scrollable. But, you don't want those ugly scrollbars to the right of your scrollable text. Maybe, instead, you'll have up arrows and down arrows above and below your <div>. When you mouseover the arrows, the text in the <div> will move up or down and create a scrolling effect. Suppose your page looks like this... <html> <head> <title>Test</title> </head> <body> <div style="position: relative; width: 700px; margin-left: auto; margin-right: auto;"> <div id="header">Header</div> <div id="scrollUp...
1 comment
Read more

Today's Quote

This is simply a brain dump.  I'm sleepy, and I want to type out some of the thoughts currently in my head. "Luck is where preparation and opportunity meet."  This is so remarkably true, and today I'm making it a mantra.  I believe that luck is merely an illusion that we perceive, but it truly when we have prepared ourselves for the right opportunity... and then a great opportunity comes along.  Many great opportunities pass us by every day.  Once we begin to recognize them and prepare for them, then we start to experience the thrill of luck. Interestingly, as described in "Good to Great", Mr. James Collins talks about how "Level 5" leaders often attribute their great success to luck .  That's a humble way of saying, "I planned on taking advantage of every opportunity ."   Hmmm...
1 comment
Read more