VB Script Code for Formatting Phone, Email, Address

File contents

Public Function Addr(Address)
' Returns a standardized address.

    Dim a As String
    
    a = Proper(Address) & " "
    a = Replace(a, ".", "", , , vbTextCompare)
    a = Replace(a, ",", "", , , vbTextCompare)
    a = Replace(a, "-", " ", , , vbTextCompare)
    a = Replace(a, " NORTH ", " N ", , , vbTextCompare)
    a = Replace(a, " SOUTH ", " S ", , , vbTextCompare)
    a = Replace(a, " EAST ", " E ", , , vbTextCompare)
    a = Replace(a, " WEST ", " W ", , , vbTextCompare)
    a = Replace(a, " Se ", " SE ", , , vbTextCompare)  'only necessary because of proper() above
    a = Replace(a, " SOUTHEAST ", " SE ", , , vbTextCompare)
    a = Replace(a, " Sw ", " SW ", , , vbTextCompare)  'only necessary because of proper() above
    a = Replace(a, " SOUTHWEST ", " SW ", , , vbTextCompare)
    a = Replace(a, " Ne ", " NE ", , , vbTextCompare)  'only necessary because of proper() above
    a = Replace(a, " NORTHEAST ", " NE ", , , vbTextCompare)
    a = Replace(a, " Nw ", " NW ", , , vbTextCompare)  'only necessary because of proper() above
    a = Replace(a, " NORTHWEST ", " NW ", , , vbTextCompare)
    a = Replace(a, " AVENUE ", " Ave ", , , vbTextCompare)
    a = Replace(a, " AV ", " Ave ", , , vbTextCompare)
    a = Replace(a, " STREET ", " St ", , , vbTextCompare)
    a = Replace(a, " COURT ", " Ct ", , , vbTextCompare)
    a = Replace(a, " ROAD ", " Rd ", , , vbTextCompare)
    a = Replace(a, " PLACE ", " Pl ", , , vbTextCompare)
    a = Replace(a, " LANE ", " Ln ", , , vbTextCompare)
    a = Replace(a, " DRIVE ", " Dr ", , , vbTextCompare)
    a = Replace(a, "   ", " ", , , vbTextCompare)
    a = Replace(a, "  ", " ", , , vbTextCompare)
    a = Replace(a, "APT # ", "Apt ", , , vbTextCompare)
    a = Replace(a, "APT #", "Apt ", , , vbTextCompare)
    
    ' Don't return an empty string.
    a = Trim(a)
    If Len(a) > 0 Then
        Addr = a
    Else
        Addr = Null
    End If
End Function


Public Function Phon(Phone)
' Returns a phone number in this format:  (206) 555-1212

    Dim strP As String
    Dim strNums As String
    Dim i As Integer, n As Integer
    Dim C As String * 1
    
    If Not IsNull(Phone) Then
    
        strP = CStr(Phone)
               
        For i = 1 To Len(strP)
            C = Mid(strP, i, 1)
            
            Select Case C
                Case "0" To "9"
                    strNums = strNums + C
                Case "-"
                Case Else
                    If Len(strNums) = 7 Or Len(strNums) > 9 Then Exit For
            End Select
        Next i
        
        If Len(strNums) = 7 Then
            strNums = "206" + strNums
            i = InStr(4, strP, Right(strNums, 4)) + 4
            Phon = RTrim(Format(strNums, "(000) 000-0000") + " " + _
                Trim(LCase(Right(strP, Len(strP) - i + 1))))
        ElseIf Len(strNums) = 10 Then
            Phon = RTrim(Format(strNums, "(000) 000-0000") + " " + _
                Trim(LCase(Right(strP, Len(strP) - i + 1))))
        ElseIf Len(strNums) > 0 Then
            Phon = Trim(LCase(strP))
        Else
            Phon = Null
        End If
        
    End If
End Function



Function Proper(anyValue As Variant) As Variant
' Converts first letter of each word to uppercase
' Note: although this function converts most proper names correctly, it converts
'       'McKee' to 'Mckee', 'van Buren' to 'Van Buren', 'John III' to 'John Iii'

    Dim ptr As Integer
    Dim theString As String
    Dim currChar As String, prevChar As String

    If IsNull(anyValue) Then
        Exit Function
    End If

    theString = CStr(anyValue)
    For ptr = 1 To Len(theString)           'Go through string char by char.
        currChar = Mid$(theString, ptr, 1)  'Get the current character.
        
        Select Case prevChar                'If previous char is letter or digit,
                                            'this char should be lowercase.
                                            
            Case "A" To "Z", "a" To "z", "0" To "9", "'"
                Mid(theString, ptr, 1) = LCase(currChar)
            
            Case Else
                Mid(theString, ptr, 1) = UCase(currChar)
        
        End Select
        prevChar = currChar
    Next ptr
    Proper = CVar(theString)

End Function

Function get1email(emailField As Variant) As Variant
' Returns the first good email it can find, otherwise null

    Dim sIn As String
    Dim sWord As Variant
    Dim s() As String
    Dim sOut As String
    Dim pos As Integer
    
    If IsNull(emailField) Then Exit Function
    
    ' break up possible emails by delimiters
    sIn = emailField
    sIn = Replace(sIn, ";", " ")
    sIn = Replace(sIn, ",", " ")
    s = Split(sIn, " ")
    
    For Each sWord In s
        pos = InStr(2, sWord, "@")
        If pos > 0 And InStr(pos + 1, sWord, "@") = 0 Then
            pos = InStr(pos + 2, sWord, ".")
           'If pos > 0 And InStr(pos + 1, sWord, ".") = 0 Then
           'Above line modified as it throws out some valid email addresses with multiple dots after the @
           'blah.blah@some.thing.here.com is valid!
            If pos > 0 Then
                If Len(sWord) > pos Then
                
                    ' found a good email!
                    get1email = sWord
                    Exit For
                    
                End If
            End If
        End If
    Next
End Function