So there's this guy sitting in front of me and his T-shirt reads "I am the Problem" or some such. I am examining the type face, it's a serif font. The next line down has the same text, but smaller. The letter "I" is beneath the space of "I am" amd the letter "m" is directly under the letter "e" of "Problem".

I figure that the length of each line is being reduced by two characters each time.

I figure I can do that.

Since I'm not in the T-Shirt business all I can do is type a line of text, click anywhere in the line, and run the macro below.



<pre>Public Sub cmd_ShrinkToPoint()
' Procedure : cmd_ShrinkToPoint
' Description: Shring a string/line of text to a small point size.
' By: Chris Greaves Inc.
' Inputs: None
' Returns: None
' Assumes: Nothing
' Side Effects: None.
' Tested: By a call from the user.

' Obtain the selected text, identify the length and the point size.
' reduce the size to the effect of a character at each end for successive lines.

Dim strText As String
If Len(Selection.Text) < 2 Then Selection.Paragraphs(1).Range.Select
strText = Selection.Text
If Right(strText, 1) = Chr$(13) Then strText = Left$(strText, Len(strText) - 1)
Dim intLenText As Integer
intLenText = Len(strText)
Dim intFontSize As Integer
Dim intNewSize As Integer
intFontSize = Selection.Font.Size
Selection.MoveRight unit:=wdCharacter
Selection.TypeParagraph

While intFontSize > 1
intNewSize = intFontSize * (intLenText - 2) / intLenText
If intNewSize = intFontSize Then intNewSize = intFontSize - 1
intFontSize = intNewSize
Selection.TypeText (strText)
Selection.Paragraphs(1).Range.Select
Selection.Font.Size = intFontSize
Selection.MoveRight unit:=wdCharacter
Selection.TypeParagraph
Wend
End Sub
</pre>