This should be easy, but I can't figure it out.  I am using Outlook 2003 and
Word 2003.   I have tried everything I can think of (and everything I have
found through a Google search and I have also been to Slipstick.com) to set
the AddressLayout so that it skips blank fields, but to no avail.  If the
Outlook contact has no company name or title, I get two empty lines in my
address.  If there is either a company or a title but not the other, I get
one empty line in my address.  I am at my wit's end on how to do this
through Word and Outlook.  I thought of searching the string for double or
triple carriage returns and removing the extras, however, the user can click
the To button repeatedly to add another address to the text box (which means
that each time a new address is selected, there will be two carriage returns
after the previous address in the list.  This is how the AddressLayout is
stored in AutoText in my letter template:

{{<PR_DISPLAY_NAME>}}

{{<PR_TITLE>}}

{{<PR_COMPANY_NAME>}}

{{<PR_POSTAL_ADDRESS>}}

I am using the following code to allow the user to retrieve an address and
insert it into the text box.  In addition, there are several functions that
are called which enable me to pull the First field (which is the
PR_DISPLAY_NAME) add to another string which is used in the second page
header in the letter.

 Dim strAddress As String
 Dim strToHeader As String
 Dim astrToHeader() As String

 If txtTo = "" Then
   strAddress = Application.GetAddress(, , True, 1, , _
     , True, True)
   txtTo.Text = strAddress
   StringToArray strAddress, astrToHeader(), vbCr
   strToHeader = astrToHeader(0)
   If ActiveDocument.Bookmarks.Exists("To") Then
     Application.ScreenUpdating = False
     Set BmRange = ActiveDocument.Bookmarks("To").Range
     BmRange.Text = strToHeader
     ActiveDocument.Bookmarks.Add Name:="To", Range:=BmRange
   End If
 Else
   strAddress = Application.GetAddress(, , _
     True, 1, , , True, True)
   txtTo.Text = txtTo.Text & vbCr & vbCr & strAddress
   StringToArray strAddress, astrToHeader(), vbCr
   If ActiveDocument.Bookmarks.Exists("To") Then
     Application.ScreenUpdating = False
     Set BmRange = ActiveDocument.Bookmarks("To").Range
   End If
   strToHeader = BmRange & Chr(11) & astrToHeader(0)
 End If

Public BmRange As Range

Public Function CountDelimitedWords( _

 pstrIn As String, _

 pstrChrDelimit As String) _

 As Long

 Dim lngWordCount As Long

 Dim lngPos As Long

 On Error GoTo PROC_ERR

 lngWordCount = 1

 ' Find the first occurence

 lngPos = InStr(pstrIn, pstrChrDelimit)

 Do While lngPos > 0

   ' Increment the hit counter

   lngWordCount = lngWordCount + 1

   ' Loop until no more occurrences

   lngPos = InStr(lngPos + 1, pstrIn, pstrChrDelimit)

 Loop

 ' Return the value

 CountDelimitedWords = lngWordCount

PROC_EXIT:

 Exit Function

PROC_ERR:

 MsgBox "Error: " & Err.Number & ". " & Err.Description, , _

   "CountDelimitedWords"

 Resume PROC_EXIT

End Function

Public Function GetDelimitedWord( _

 pstrIn As String, _

 ByVal plngIndex As Long, _

 pstrChrDelimit As String) _

 As String

 Dim lngCounter As Long

 Dim lngStartPos As Long

 Dim lngEndPos As Long

 Dim strDelimit As String

 On Error GoTo PROC_ERR

 ' Set initial values

 lngCounter = 1

 lngStartPos = 1

 strDelimit = Left$(pstrChrDelimit, 1)

 ' Count to the specified index

 For lngCounter = 2 To plngIndex

   ' Get the new starting position

   lngStartPos = InStr(lngStartPos, pstrIn, strDelimit) + 1

 Next lngCounter

 ' Determine the ending position

 lngEndPos = InStr(lngStartPos, pstrIn, strDelimit) - 1

 ' Ending position can't be less than 1

 If lngEndPos <= 0 Then

   lngEndPos = Len(pstrIn)

 End If

 ' Pull the word out and return it

 GetDelimitedWord = Mid$(pstrIn, lngStartPos, lngEndPos - lngStartPos + 1)

PROC_EXIT:

 Exit Function

PROC_ERR:

 MsgBox "Error: " & Err.Number & ". " & Err.Description, , _

   "GetDelimitedWord"

 Resume PROC_EXIT

End Function

Public Function ReplaceChars( _

 pstrIn As String, _

 pstrFind As String, _

 pstrReplace As String) _

 As String

 Dim lngCounter As Long

 Dim strTmp As String

 Dim strChrTmp As String * 1

 On Error GoTo PROC_ERR

 ' Loop through the string

 For lngCounter = 1 To Len(pstrIn)

   ' Get the current character

   strChrTmp = Mid$(pstrIn, lngCounter)

   If strChrTmp <> pstrFind Then

     ' Its not a match, do nothing

     strTmp = strTmp & strChrTmp

   Else

     ' Its a match, so use the replacement character

     strTmp = strTmp & pstrReplace

   End If

 Next lngCounter

 ' Return the value

 ReplaceChars = strTmp

PROC_EXIT:

 Exit Function

PROC_ERR:

 MsgBox "Error: " & Err.Number & ". " & Err.Description, , _

   "ReplaceChars"

 Resume PROC_EXIT

End Function

Public Function StringToArray( _

 pstrIn As String, _

 pastrIn() As String, _

 pstrChrDelimit As String) _

 As Long

 Dim lngCounter As Long

 Dim lngWordCount As Long

 On Error GoTo PROC_ERR

 ' Count the words

 lngWordCount = CountDelimitedWords(pstrIn, pstrChrDelimit)

 ' Resize the array accordingly

 ReDim pastrIn(0 To lngWordCount - 1)

 ' Walk through the words

 For lngCounter = 0 To lngWordCount - 1

   ' Add the words to the array

   pastrIn(lngCounter) = GetDelimitedWord(pstrIn, lngCounter + 1,
pstrChrDelimit)

 Next lngCounter

 ' Return the count

 StringToArray = lngWordCount

PROC_EXIT:

 Exit Function

PROC_ERR:

 MsgBox "Error: " & Err.Number & ". " & Err.Description, , _

   "StringToArray"

 Resume PROC_EXIT

End Function

Any ideas on how I can get the AddressLayout to remove those extra lines, or
how I can modify the code to have them removed?

Thanks,

Anne P.