Re: stop selection when finding certain font

Tech-Archive recommends: Speed Up your PC by fixing your registry

Hi Dan,

Yes, it will work "decently enough", but if the document is large and
the first font change occurs a few thousand characters after the start
of the Selection, it's going to be a long wait while it checks each
character.

This macro is faster because it uses a technique called "binary
search", meaning that each iteration of the loop cuts the remaining
region in half and then determines which half to look at next. It also
relies on an oddity of VBA, that the property oRg.Font.Name returns an
empty string if the range contains more than one font.

Sub DiffFont2()
Dim oRg As Range
Dim nStart As Long, nEnd As Long
Dim nDiff As Long, nSame As Long

nStart = Selection.Start
nEnd = ActiveDocument.Range.End
Set oRg = ActiveDocument.Range(nStart, nEnd)

nSame = nStart
nDiff = nEnd

Do While (nSame < nDiff - 1)
nEnd = Int((nSame + nDiff) / 2)
Set oRg = ActiveDocument.Range(nStart, nEnd)
If (oRg.Font.Name = "") Then
nDiff = nEnd
Else
nSame = nEnd
End If
Loop

If (oRg.Font.Name = "") Then
oRg.End = oRg.End - 1
End If

oRg.Select
Set oRg = Nothing
End Sub

--
Regards,
Jay Freedman
Microsoft Word MVP FAQ: http://word.mvps.org

On Thu, 7 Jul 2005 14:55:03 -0700, Dan <Dan@xxxxxxxxxxxxxxxxxxxxxxxxx>
wrote:

>This will work decently enough:
>Public Sub DiffFont()
>Dim rngStart As Range
>Dim strStartFont As String
>Selection.Collapse wdCollapseStart
>Selection.MoveRight unit:=wdCharacter, Count:=1, Extend:=True
>Set rngStart = Selection.Range
>strStartFont = Selection.Font.Name
>Do
> Selection.MoveRight unit:=wdCharacter, Count:=1
> If Selection.End = ActiveDocument.Content.End - 1 Then rngStart.End =
>Selection.End + 1: Exit Do
> If Selection.Font.Name <> strStartFont Then rngStart.End =
>Selection.Range.End - 1: Exit Do
>Loop
>rngStart.Select
>Set rngStart = Nothing
>End Sub
>
>
>"Tony Logan" wrote:
>
>> I have a document where there's an unknown amount of text that is font x (x
>> being Arial, or Times, or whatever). This text will sometimes include
>> paragraph marks.
>>
>> I want to select all the text that is font x and stop selecting as soon as I
>> get to a font that isn't x.
>>
>> I thought the below code would do the trick, but instead I'm getting caught
>> in an endless loop. Any ideas? Thanks.
>>
>> code (assumes the cursor is at the first character of font x):
>>
>> With Selection
>> .ExtendMode = True
>> Do Until Selection.Font.Name <> "Arial"
>> .MoveRight Unit:=wdCharacter
>> Loop
>> End With
>>

.

Relevant Pages

  • Re: Limit .find to one pass
    ... Dim r As Long ... 'Copy the right-most character to the next column ... Loop Until ActiveCell.Address = startCell.Address ...     Loop ...
    (microsoft.public.excel.programming)
  • Re: UDF for Data into 128 B barcode problem
    ... Every font is different. ... Dim Sum As Integer, i As Integer ... Dim Checksum As Integer, Checkchar As Integer ... ' Scan the string and add character value times position ...
    (microsoft.public.excel.worksheet.functions)
  • Re: Limit .find to one pass
    ... "Robert H" skrev i meddelelsen ... Dim r As Long ... 'Copy the right-most character to the next column ... Loop Until ActiveCell.Address = startCell.Address ...
    (microsoft.public.excel.programming)
  • Re: Font Width Tables
    ... Here's a simple macro that outputs the 1pt character widths for the standard character set in whatever font attributes are in use at your selection point. ... Dim ChrWidths As String ...
    (microsoft.public.word.printingfonts)
  • Re: Individual Character fonts in a cell
    ... The code could be modified easily enough by creating a one-dimensional array for each font attribute that a character could possibly have and then doing to them exactly what I did to the Colors array... ... Dim X As Long ...
    (microsoft.public.excel.programming)