formatStr

Public Function MakeProper(StringIn As Variant) As String
    'Upper-Cases the first letter of each word in in a string
    On Error Goto HandleErr
    Dim strBuild As String
    Dim intLength As Integer
    Dim intCounter As Integer
    Dim strChar As String
    Dim strPrevChar As String
    intLength = Len(StringIn)
    'Bail out if there is nothing there
    If intLength > 0 Then
        strBuild = UCase(Left(StringIn, 1))
        For intCounter = 1 To intLength
            strPrevChar = Mid$(StringIn, intCounter, 1)
            strChar = Mid$(StringIn, intCounter + 1, 1)
            Select Case strPrevChar
                Case Is = " ", ".", "/"
                    strChar = UCase(strChar)
                Case Else
            End Select
            strBuild = strBuild & strChar
        Next intCounter
        MakeProper = strBuild
        strBuild = MakeWordsLowerCase(strBuild, _
            " and ", " or ", " the ", " a ", " To ")
        MakeProper = strBuild
    End If
    ExitHere:
    Exit Function
    HandleErr:
    Select Case Err.Number
        Case Else
            LogError "MakeProper", Err.Number, _
                Err.Description, Err.Source
            Resume ExitHere
    End Select
End Function

Function MakeWordsLowerCase(StringIn As String, _
        ParamArray WordsToCheck()) As String
    'Looks for the words in the WordsToCheck
    '     Array within
    'the StringIn string and makes them lowe
    '     r case
    On Error Goto HandleErr
    Dim strWordToFind As String
    Dim intWordStarts As Integer
    Dim intWordEnds As Integer
    Dim intStartLooking As Integer
    Dim strResult As String
    Dim intLength As Integer
    Dim intCounter As Integer
    
    'Initialize the variables
    strResult = StringIn
    intLength = Len(strResult)
    intStartLooking = 1
    
    For intCounter = LBound(WordsToCheck) To _
            UBound(WordsToCheck)
        strWordToFind = WordsToCheck(intCounter)
        Do
        intWordStarts = InStr(intStartLooking, _
            strResult, strWordToFind)
        If intWordStarts = 0 Then Exit Do
        intWordEnds = intWordStarts + _
            Len(strWordToFind)
        strResult = Left(strResult, intWordStarts _
            - 1) & LCase(strWordToFind) & _
            Mid$(strResult, intWordEnds, (intLength - intWordEnds) + 1)
        intStartLooking = intWordEnds
        Loop While intWordStarts > 0
        intStartLooking = 1
    Next intCounter
    
    MakeWordsLowerCase = strResult
    ExitHere:
    
    Exit Function
    HandleErr:
    Select Case Err.Number
        Case Else
            LogError "MakeWordsLowerCase", Err.Number, _
                Err.Description, Err.Source
            Resume ExitHere
    End Select
End Function

Function OrdinalNumber(NumberIn As Long) As String
    'Formats a number as an ordinal number
    On Error Goto HandleErr
    Dim intLastDigit As Integer
    Dim intLastTwoDigits As Integer
    intLastDigit = NumberIn Mod 10
    intLastTwoDigits = NumberIn Mod 100
    Select Case intLastTwoDigits
        Case 11 To 19
            OrdinalNumber = CStr(NumberIn) & "th"
        Case Else
            Select Case intLastDigit
                Case Is = 1
                    OrdinalNumber = CStr(NumberIn) & "st"
                Case Is = 2
                    OrdinalNumber = CStr(NumberIn) & "nd"
                Case Is = 3
                    OrdinalNumber = CStr(NumberIn) & "rd"
                Case Else
                    OrdinalNumber = CStr(NumberIn) & "th"
            End Select
    End Select
    ExitHere:
    Exit Function
    HandleErr:
    Select Case Err.Number
        Case Else
            LogError "OrdinalNumber", Err.Number, _
                Err.Description, Err.Source
            Resume ExitHere
    End Select
End Function

Function MonthName(DateIn As Date) As String
    'Returns the full name of the month of the
    'date passed in
    On Error Goto HandleErr
    Dim dv As New DevTools
    Select Case Month(DateIn)
        Case Is = 1
            MonthName = "January"
        Case Is = 2
            MonthName = "February"
        Case Is = 3
            MonthName = "March"
        Case Is = 4
            MonthName = "April"
        Case Is = 5
            MonthName = "May"
        Case Is = 6
            MonthName = "June"
        Case Is = 7
            MonthName = "July"
        Case Is = 8
            MonthName = "August"
        Case Is = 9
            MonthName = "September"
        Case Is = 10
            MonthName = "October"
        Case Is = 11
            MonthName = "November"
        Case Is = 12
            MonthName = "December"
    End Select
    ExitHere:
    Exit Function
    HandleErr:
    Select Case Err.Number
        Case Else
            LogError "MonthName", Err.Number, _
                Err.Description, Err.Source
            Resume ExitHere
    End Select
End Function

Function DateWord(DateIn As Date) As String
    'Accepts: DateIn--the date to be converted
    'Returns: DateWord--the date in "5th day of
    'August, 1997" format Comments: Calls
    'OrdinalNum for the day  value and MonthName
    'for the Month
    On Error Goto HandleErr
    Dim strDay As String
    Dim strMonth As String
    Dim strYear As String
    Dim lngIntDayNum As Long
    strMonth = MonthName(DateIn)
    strYear = CStr(Year(DateIn))
    lngIntDayNum = CInt(Day(DateIn))
    strDay = OrdinalNum(lngIntDayNum)
    DateWord = strDay & _
        " day of " & strMonth & _
        ", " & strYear
    ExitHere:
    
    Exit Function
    HandleErr:
    Select Case Err.Number
        Case Else
            LogError "DateWord", Err.Number, _
                Err.Description, Err.Source
            Resume ExitHere
    End Select
End Function

Public Sub LogError(ProcedureName As String, _
        ErrorNumber As Long, ErrorDescription _
        As String, ErrorSource As String)
    On Error Goto HandleErr
    
    Dim lngFileNo As Long
    Dim strTextFile As String
    Dim strPath As String
    Dim strLogText As String
    
    'Build a text entry for the error log file
    strLogText = vbCrLf & Space(14) & " * BEGIN _
        Error RECORD * " & vbCrLf
    strLogText = strLogText & "Error " & _
        ErrorNumber
    strLogText = strLogText & " In Procedure " & _
        ProcedureName & " at " & Now() & vbCrLf
    strLogText = strLogText & ErrorDescription & _
        vbCrLf
    strLogText = strLogText & Space(14) & "* _
        End Error RECORD * " & _
        vbCrLf & vbCrLf
    
    'place the file in the application directory
    'and name it Error Log.txt
    strPath = App.Path
    strTextFile = strPath & "\Error Log.txt"
    'Open the file
    lngFileNo = FreeFile
    Open strTextFile For Append As #lngFileNo
    'Write the error entry
    Write #lngFileNo, strLogText
    'Close the file
    Close #lngFileNo
    ExitHere:
    Exit Sub
    HandleErr:
    Debug.Print "Error in LogError"
    Resume ExitHere
End Sub

Inputs:
MakeProper accepts a string. 
DateWord accepts a date.
MailingLabelText accepts a number 
of String arguments, many optional.

Returns:All of these functions return strings.
Assumes:MakeProper Calls MakeWordsLower
Case and passes it several words that are commonly
left lower case.You may wish to edit my selections.

Option Explicit
Option Compare Text
Public Type NameAndAddress
FullName As String
MailingName As String
StreetAddress As String
CompanyAddress As String
FullText As String
End Type
Public Function MailingLabelText(LastName _
As String, FirstName As String, _
Optional MI As String = "", _
Optional Title As String = "", _
Optional Honorific As String = "", _
Optional CompanyName As String = "", _
Optional AddrLine1 As String = "", _
Optional AddrLine2 As String = "", _
Optional City As String = "", _
Optional State As String = "", _
Optional ZipCode As String = "" _
) As NameAndAddress
'Generates a full address or as much as is

'available

On Error Goto HandleErr
Dim strName As String
Dim strAddress As String

'Build the name

If Len(MI) = 0 Then
strName = FirstName & " " & LastName
Else
strName = FirstName & " " & MI & " " & LastName
End If
'Assign the name to the FullName element

MailingLabelText.FullName = strName
'Add title or honorific if present

If Len(Honorific) = 0 Then
If Len(Title) > 0 Then
strName = Title & " " & strName
End If
Else
strName = strName & ", " & Honorific
End If
'assign the full name to the MailingName element

MailingLabelText.MailingName = strName
'Build the Address

If Len(AddrLine1) > 0 Then
strAddress = AddrLine1
End If
If Len(AddrLine2) > 0 Then
strAddress = strAddress & vbCrLf & AddrLine2
End If
If Len(City) > 0 Then
strAddress = strAddress & vbCrLf & City
If Len(State) > 0 Then
strAddress = strAddress & ", " & State
End If
If Len(ZipCode) > 0 Then
If Right(ZipCode, 1) = "-" Then
ZipCode = Left(ZipCode, Len(ZipCode) - 1)
End If
strAddress = strAddress & " " & ZipCode
End If
End If

'Assign the string to the streetaddress element

MailingLabelText.StreetAddress = strAddress
With MailingLabelText
'Assign the other combinations as appropriate

If Len(CompanyName) > 0 Then
.CompanyAddress = CompanyName & vbCrLf & strAddress
End If
If (Len(strName) > 0 And Len(CompanyName) > 0) Then
.FullText = strName & vbCrLf & CompanyName & _
vbCrLf & strAddress
ElseIf (Len(strName) > 0 And Len(CompanyName) = 0) Then
.FullText = strName & vbCrLf & strAddress
ElseIf (Len(strName) = 0 And Len(CompanyName) > 0) Then
.FullText = CompanyName & vbCrLf & strAddress
Else
.FullText = strAddress
End If

End With
ExitHere:

Exit Function
HandleErr:
Select Case Err.Number
Case Else
LogError "MailingLabelText", Err.Number, _
Err.Description, Err.Source
Resume ExitHere
End Select
End Function

Public Function MakeProper(StringIn As Variant) As String
'Upper-Cases the first letter of each word in in a string

On Error Goto HandleErr
Dim strBuild As String
Dim intLength As Integer
Dim intCounter As Integer
Dim strChar As String
Dim strPrevChar As String
intLength = Len(StringIn)
'Bail out if there is nothing there

If intLength > 0 Then
strBuild = UCase(Left(StringIn, 1))
For intCounter = 1 To intLength
strPrevChar = Mid$(StringIn, intCounter, 1)
strChar = Mid$(StringIn, intCounter + 1, 1)
Select Case strPrevChar
Case Is = " ", ".", "/"
strChar = UCase(strChar)
Case Else
End Select
strBuild = strBuild & strChar
Next intCounter
MakeProper = strBuild
strBuild = MakeWordsLowerCase(strBuild, _
" and ", " or ", " the ", " a ", " To ")
MakeProper = strBuild
End If
ExitHere:
Exit Function
HandleErr:
Select Case Err.Number
Case Else
LogError "MakeProper", Err.Number, _
Err.Description, Err.Source
Resume ExitHere
End Select
End Function

Function MakeWordsLowerCase(StringIn As String, _
ParamArray WordsToCheck()) As String
'Looks for the words in the WordsToCheck

' Array within

'the StringIn string and makes them lowe

' r case

On Error Goto HandleErr
Dim strWordToFind As String
Dim intWordStarts As Integer
Dim intWordEnds As Integer
Dim intStartLooking As Integer
Dim strResult As String
Dim intLength As Integer
Dim intCounter As Integer

'Initialize the variables

strResult = StringIn
intLength = Len(strResult)
intStartLooking = 1

For intCounter = LBound(WordsToCheck) To _
UBound(WordsToCheck)
strWordToFind = WordsToCheck(intCounter)
Do
intWordStarts = InStr(intStartLooking, _
strResult, strWordToFind)
If intWordStarts = 0 Then Exit Do
intWordEnds = intWordStarts + _
Len(strWordToFind)
strResult = Left(strResult, intWordStarts _
- 1) & LCase(strWordToFind) & _
Mid$(strResult, intWordEnds, (intLength - intWordEnds) + 1)
intStartLooking = intWordEnds
Loop While intWordStarts > 0
intStartLooking = 1
Next intCounter

MakeWordsLowerCase = strResult
ExitHere:

Exit Function
HandleErr:
Select Case Err.Number
Case Else
LogError "MakeWordsLowerCase", Err.Number, _
Err.Description, Err.Source
Resume ExitHere
End Select
End Function

Function OrdinalNumber(NumberIn As Long) As String
'Formats a number as an ordinal number

On Error Goto HandleErr
Dim intLastDigit As Integer
Dim intLastTwoDigits As Integer
intLastDigit = NumberIn Mod 10
intLastTwoDigits = NumberIn Mod 100
Select Case intLastTwoDigits
Case 11 To 19
OrdinalNumber = CStr(NumberIn) & "th"
Case Else
Select Case intLastDigit
Case Is = 1
OrdinalNumber = CStr(NumberIn) & "st"
Case Is = 2
OrdinalNumber = CStr(NumberIn) & "nd"
Case Is = 3
OrdinalNumber = CStr(NumberIn) & "rd"
Case Else
OrdinalNumber = CStr(NumberIn) & "th"
End Select
End Select
ExitHere:
Exit Function
HandleErr:
Select Case Err.Number
Case Else
LogError "OrdinalNumber", Err.Number, _
Err.Description, Err.Source
Resume ExitHere
End Select
End Function

Function MonthName(DateIn As Date) As String
'Returns the full name of the month of the

'date passed in

On Error Goto HandleErr
Dim dv As New DevTools
Select Case Month(DateIn)
Case Is = 1
MonthName = "January"
Case Is = 2
MonthName = "February"
Case Is = 3
MonthName = "March"
Case Is = 4
MonthName = "April"
Case Is = 5
MonthName = "May"
Case Is = 6
MonthName = "June"
Case Is = 7
MonthName = "July"
Case Is = 8
MonthName = "August"
Case Is = 9
MonthName = "September"
Case Is = 10
MonthName = "October"
Case Is = 11
MonthName = "November"
Case Is = 12
MonthName = "December"
End Select
ExitHere:
Exit Function
HandleErr:
Select Case Err.Number
Case Else
LogError "MonthName", Err.Number, _
Err.Description, Err.Source
Resume ExitHere
End Select
End Function

Function DateWord(DateIn As Date) As String
'Accepts: DateIn--the date to be converted

'Returns: DateWord--the date in "5th day of

'August, 1997" format Comments: Calls

'OrdinalNum for the day value and MonthName

'for the Month

On Error Goto HandleErr
Dim strDay As String
Dim strMonth As String
Dim strYear As String
Dim lngIntDayNum As Long
strMonth = MonthName(DateIn)
strYear = CStr(Year(DateIn))
lngIntDayNum = CInt(Day(DateIn))
strDay = OrdinalNum(lngIntDayNum)
DateWord = strDay & _
" day of " & strMonth & _
", " & strYear
ExitHere:

Exit Function
HandleErr:
Select Case Err.Number
Case Else
LogError "DateWord", Err.Number, _
Err.Description, Err.Source
Resume ExitHere
End Select
End Function

Public Sub LogError(ProcedureName As String, _
ErrorNumber As Long, ErrorDescription _
As String, ErrorSource As String)
On Error Goto HandleErr

Dim lngFileNo As Long
Dim strTextFile As String
Dim strPath As String
Dim strLogText As String

'Build a text entry for the error log file

strLogText = vbCrLf & Space(14) & " * BEGIN _
Error RECORD * " & vbCrLf
strLogText = strLogText & "Error " & _
ErrorNumber
strLogText = strLogText & " In Procedure " & _
ProcedureName & " at " & Now() & vbCrLf
strLogText = strLogText & ErrorDescription & _
vbCrLf
strLogText = strLogText & Space(14) & "* _
End Error RECORD * " & _
vbCrLf & vbCrLf

'place the file in the application directory

'and name it Error Log.txt

strPath = App.Path
strTextFile = strPath & "\Error Log.txt"
'Open the file

lngFileNo = FreeFile
Open strTextFile For Append As #lngFileNo
'Write the error entry

Write #lngFileNo, strLogText
'Close the file

Close #lngFileNo
ExitHere:
Exit Sub
HandleErr:
Debug.Print "Error in LogError"
Resume ExitHere
End Sub

Inputs:
MakeProper accepts a string.
DateWord accepts a date.
MailingLabelText accepts a number
of String arguments, many optional.

Returns:All of these functions return strings.
Assumes:MakeProper Calls MakeWordsLower
Case and passes it several words that are commonly
left lower case.You may wish to edit my selections.