Function fctnTakeFour(strText As String) As String
'First make sure that all mulitple spaces are reduced to one space
Do Until InStr(1, strText, " ", vbTextCompare) = 0
strText = Replace(strText, " ", " ", , , vbTextCompare)
Loop
'Then take the first four chars of each word.
Dim lngSpace As Long
Do Until InStr(1, strText, " ", vbTextCompare) = 0
lngSpace = InStr(1, strText, " ", vbTextCompare)
If lngSpace > 4 Then
fctnTakeFour = fctnTakeFour & Left$(strText, 4)
Else
fctnTakeFour = fctnTakeFour & Left$(strText, lngSpace - 1)
End If
strText = Mid$(strText, lngSpace + 1)
Loop
'Finally allow for leftover text after the last space.
If Len(strText) > 0 Then fctnTakeFour = fctnTakeFour & Left$(strText, 4)
End Function