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

Developing a lightweight WebSocket library

Late in 2016, I began development on a lightweight, isomorphic WebSocket library for Node.js called ws-wrapper .  Today, this library is stable and has been successfully used in many production apps. Why?  What about socket.io ?  In my opinion, socket.io and its dependencies are way too heavy .  Now that the year is 2018, this couldn't be more true.  Modern browsers have native WebSocket support meaning that all of the transports built into the socket.io project are just dead weight.  On the other hand, ws-wrapper and its dependencies weigh about 3 KB when minified and gzipped.  Similarly, ws-wrapper consists of about 500 lines of code; whereas, socket.io consists of thousands of lines of code.  As Dijkstra once famously said: "Simplicity is prerequisite for reliability." ws-wrapper also provides a few more features out of the box.  The API exposes a two-way, Promise-based request/response interface.  That is, clients can request dat...
Post a 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

Wedding Prediction - October, 2013

Carla and I are planning on getting married sometime in October next year.  We need to pick a date, and that decision may  involve some science and mathematics.  :) For example, we want the weather to be nice.  To be more precise, we'd like the high temperature for the wedding day to be between 60 and 80 degrees Fahrenheit.  Obviously, we have both lived in Ohio our entire lives, and we have a pretty good idea of what the weather will be like.  We both hypothesised that October was a "hit or miss" sort of month; it could be cold, or it could be nice. But, for me, a simple hypothesis was not enough; I really wanted to know the probabilities of decent weather based on historical weather data.  Many websites on the Internet (i.e. almanac.com) charge you to review historical weather data, but Carla and I discovered a cool page on cleveland.com that provided exactly what we wanted.  I loaded the historical temperature data from 1903 to 2011 f...
2 comments
Read more