Results 1 to 6 of 6

Thread: Find font info

  1. #1
    Lounger
    Join Date
    Jan 2001
    Location
    Missouri, USA
    Posts
    41
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Find font info

    I'm working with a large number of Word docs and I need to find font information about each doc. Mostly it's searching for a particular font such as Symbol. I currently have to open each doc and do a Find for Symbol font.

    I'd love to be able to run a macro that would allow me to specify a directory or group of files, specify a font, then would find all docs that contain that font.

    Anyone know how to do that in Word 2000? Or am I just dreaming? TIA

  2. #2
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,852
    Thanks
    4
    Thanked 259 Times in 239 Posts

    Re: Find font info

    It can certainly be done but I haven't the time at the moment. What I can do is give you some magnificent related code that was posted here previously by Robin Trew (I couldn't find it so I guess it was on the olde site) which searches across all open documents.
    <pre>Option Explicit
    Private Const TOOLNAME As String = "FindAcrossDocs"
    Private Const SECTION As String = "PLACEMARKERS"
    Private Const STARTDOCKEY As String = "StartDocName"
    Private Const CURRENTDOCKEY As String = "CurrentDocName"
    Private Const TARGETKEY As String = "TargetString"
    Private Const INDEXKEY As String = "CurrentDoc"
    Private Const STARTINDEXKEY As String = "StartDoc"
    Private Const TEXTPOSNKEY As String = "PlaceInText"
    Sub AddButtons()
    Const FINDTAG As String = "FindInDocs"
    Const FINDAGAINTAG As String = "FindAgainInDocs"
    Dim ctl As CommandBarControl
    Dim ctls As CommandBarControls
    Dim btn As CommandBarButton
    With CommandBars("Menu Bar")
    Set ctls = .Controls
    'delete any previous versions
    For Each ctl In ctls
    If ctl.Tag = FINDTAG Then
    ctl.Delete
    ElseIf ctl.Tag = FINDAGAINTAG Then
    ctl.Delete
    End If
    Next
    Set btn = ctls.Add(msoControlButton)
    With btn
    .BeginGroup = True
    .Caption = "&d"
    .FaceId = 133
    .OnAction = FINDTAG
    .Style = msoButtonIconAndCaption
    .Tag = FINDTAG
    .TooltipText = "Search for term in all open documents"
    End With
    Set btn = ctls.Add(msoControlButton)
    With btn
    .Caption = "&n"
    .FaceId = 136
    .OnAction = FINDAGAINTAG
    .Style = msoButtonIconAndCaption
    .Tag = FINDAGAINTAG
    .TooltipText = "Repeat search for term in all open documents"
    End With
    End With
    End Sub
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~
    ' Purpose: Search for a term across all of the currently open
    ' documents. If the term is found, saves status in the
    ' registry to allow for a companion "Find Again" function
    ' to continue where it left off.
    ' Called: by AddButtons(), by FindAgainInDocs()
    ' Author: Robin Trew (Cambridge, England) .
    ' Created: 1999 Sep 15, 1:58am
    ' Last Edited: 1999 Sep 15, 11:44pm
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~
    Public Sub FindInDocs()
    Dim Doc As Word.Document ' Reference to current document
    Dim strStartDoc As String ' Path of doc in which search began
    Dim strTerm As String ' Search term
    Dim strIndex As String ' Hold string version of integer index to Nth document.
    Dim lngStartIndex As Long ' Index of doc in which search began
    Dim lngDocIndex As Long ' Index of any other doc
    Dim lngDocs As Long ' Number of open documents.
    Dim iDoc As Long ' Index counter
    Dim blnFound As Boolean ' Result of search
    ' Record initial document and selection.
    With ActiveDocument
    .Range.Select
    strStartDoc = UCase$(.FullName)
    End With
    ' Get the index of the initial document.
    For iDoc = 1 To Documents.count
    If UCase$(Documents(iDoc).FullName) = strStartDoc Then
    lngStartIndex = iDoc
    Exit For
    End If
    Next iDoc
    strTerm = GetSetting(TOOLNAME, SECTION, TARGETKEY)
    ' Get a search term.
    strTerm = InputBox("Look for:", "Find across documents", strTerm)
    ' Store all of this in the registry for the Find Again function.
    SaveSetting TOOLNAME, SECTION, STARTDOCKEY, strStartDoc
    SaveSetting TOOLNAME, SECTION, TARGETKEY, strTerm
    strIndex = CStr(lngStartIndex)
    SaveSetting TOOLNAME, SECTION, STARTINDEXKEY, strIndex
    SaveSetting TOOLNAME, SECTION, INDEXKEY, strIndex
    ' Fire the starting pistol.
    GoFind strTerm, iDoc, lngStartIndex
    End Sub
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~
    ' Purpose: Companion function for FindInDocs - continues a search
    ' for a term across all of the currently open documents.
    ' Retrieves the current status of the search from the
    ' registry, and check the environment to see if the data
    ' still seems relevant. If not, inititiates a fresh search.
    ' Author: Robin Trew (Cambridge, England).
    ' Created: 1999 Sep 15, 2:08am
    ' Last Edited: 1999 Sep 15, 11:43pm
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~
    Public Sub FindAgainInDocs()
    Dim docCurrent As Word.Document
    Dim rngSearchScope As Word.Range
    Dim strStartDoc As String
    Dim strCurrentDoc As String
    Dim strTerm As String
    Dim lngStartIndex As Long
    Dim lngIndex As Long
    Dim lngTextPosn As Long
    Dim lngDocs As Long
    Dim iDoc As Long
    Dim blnFindNext As Boolean
    strTerm = GetSetting(TOOLNAME, SECTION, TARGETKEY)
    strStartDoc = UCase$(GetSetting(TOOLNAME, SECTION, STARTDOCKEY))
    strCurrentDoc = UCase$(GetSetting(TOOLNAME, SECTION, CURRENTDOCKEY))
    lngStartIndex = CLng(GetSetting(TOOLNAME, SECTION, STARTINDEXKEY))
    lngIndex = CLng(GetSetting(TOOLNAME, SECTION, INDEXKEY))
    lngTextPosn = CLng(GetSetting(TOOLNAME, SECTION, TEXTPOSNKEY))
    blnFindNext = False
    lngDocs = Word.Documents.count

    If lngDocs >= lngStartIndex Then
    If UCase$(Documents(lngStartIndex).FullName) = strStartDoc Then
    If lngDocs >= lngIndex Then
    Set docCurrent = Documents(lngIndex)
    With docCurrent
    If UCase$(.FullName) = strCurrentDoc Then
    If .Range.Characters.count > lngTextPosn Then
    Set rngSearchScope = .Range
    With rngSearchScope
    .Start = lngTextPosn
    .Select
    blnFindNext = True
    End With
    Else
    If lngDocs > lngIndex Then
    lngIndex = lngIndex + 1
    If lngIndex <> lngStartIndex Then
    Set docCurrent = Documents(lngIndex)
    With docCurrent
    .Activate
    .Range.Select
    End With
    blnFindNext = True
    Else
    MsgBox strTerm & " not Found.", vbInformation, "Find in Docs"
    End If
    End If
    End If
    Else
    FindInDocs
    End If
    End With
    Else
    FindInDocs
    End If
    Else
    FindInDocs
    End If
    Else
    FindInDocs
    End If
    If blnFindNext Then GoFind strTerm, lngIndex, lngStartIndex
    End Sub

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~
    ' Purpose: Searches for a given term in the currently selected
    ' range. If the term is not found, continues to look in
    ' other open documents. If the term is foundl, stores
    ' details in the registry for subequent re-use by FindAgainInDocs()
    ' Called: by FindInDocs(), by FindAgainInDocs()
    ' Author: Robin Trew (Cambridge, England) .
    ' Created: 1999 Sep 15, 2:11am
    ' Last Edited: 1999 Sep 15, 11:43pm
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~
    Private Sub GoFind(Term As String, ByVal CurrentIndex, ByVal StartDocIndex As Long)
    Dim Doc As Word.Document
    Dim rngSelection As Word.Range
    Dim strTerm As String
    Dim lngStartIndex As Long
    Dim lngDocs As Long
    Dim iDoc As Long
    Dim blnFound As Boolean
    Set rngSelection = Selection.Range
    iDoc = CurrentIndex
    lngStartIndex = StartDocIndex
    blnFound = False
    With Selection.Find
    '.ClearAllFuzzyOptions
    .ClearFormatting
    .Forward = True
    .MatchCase = False
    .Wrap = wdFindStop
    blnFound = .Execute(Term)
    End With
    lngDocs = Documents.count
    Do While Not blnFound
    iDoc = iDoc + 1
    If iDoc > lngDocs Then
    iDoc = 1
    End If
    If iDoc <> lngStartIndex Then
    SaveSetting TOOLNAME, SECTION, INDEXKEY, CStr(iDoc)
    Set Doc = Documents(iDoc)
    With Doc
    .Activate
    .Range.Select
    End With
    With Selection.Find
    '.ClearAllFuzzyOptions
    .ClearFormatting
    blnFound = .Execute(Term, MatchCase:=False, Forward:=True, Wrap:=wdFindStop)
    End With
    Else
    Exit Do
    End If
    Loop
    If Not blnFound Then
    Selection.Collapse
    MsgBox "Not found in these documents", vbInformation, "Find across docs"
    Else
    SaveSetting TOOLNAME, SECTION, CURRENTDOCKEY, UCase$(ActiveDocument.FullName)
    SaveSetting TOOLNAME, SECTION, INDEXKEY, CStr(iDoc)
    SaveSetting TOOLNAME, SECTION, TEXTPOSNKEY, Selection.End + 1
    End If
    End Sub</pre>

    Andrew Lockton, Chrysalis Design, Melbourne Australia

  3. #3
    Platinum Lounger
    Join Date
    Feb 2001
    Location
    Yilgarn region of Toronto, Ontario
    Posts
    5,453
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Find font info

    My "Files" processor does most of what you want. You point it at a set of files and run it.

    The most you would have to do is record/write a simple macro called "process" that would determine if the active document contained the font. That sounds like a simple record of an Edit Find command.

  4. #4
    Super Moderator
    Join Date
    Dec 2000
    Location
    New York, NY
    Posts
    2,970
    Thanks
    3
    Thanked 29 Times in 27 Posts

    Re: Find font info

    Tekvet,

    You're well advised to take a look at Chris' files processor (and I intend to take some time off and read Robin's code <g>), but in the meantime insomnia has driven me to put the following code together (gotta do something when you can't sleep!).

    This knits together large chunks of code posted here by James Brooks and Chris Green. You should be alerted that this (my knitting it together that is) is real quick and dirty work; there's no error handling and it's only had cursory testing. Still, it gets at what you need (one last little warning: do not put the document from which you run this code, in the same directory you are going to search!):

    <pre>Public Sub FindFontInDocs()
    'Cobbled together from code posted on Woody's Lounge
    'by Chris Green and James Brooks
    Dim strFolder As String
    Dim strFindFont As String
    Dim objCurDoc As Document
    Dim objListDoc As Document
    Dim aStory As Range
    Dim strDocsList As String
    Dim i As Long
    Dim objView As View
    Dim bHidden As Boolean

    strFindFont = InputBox("Enter the name of the font to look for.", "Find Font")
    With Dialogs(wdDialogCopyFile)
    If .Display = -1 Then strFolder = .Directory
    End With

    strDocsList = "The following documents in " & strFolder _
    & " contain the font " & strFindFont & ":" & vbCr

    Application.ScreenUpdating = False
    With Application.FileSearch
    .FileName = "*"
    .FileType = msoFileTypeWordDocuments
    .LookIn = strFolder
    .Execute
    .SearchSubFolders = False
    For i = 1 To .FoundFiles.Count
    WordBasic.disableautomacros
    Set objCurDoc = Documents.Open(.FoundFiles(i))
    With objCurDoc
    Set objView = ActiveWindow.View
    bHidden = objView.ShowHiddenText 'show hidden text if it's hidden
    objView.ShowHiddenText = True
    For Each aStory In objCurDoc.StoryRanges
    With aStory.Find
    .ClearFormatting
    .Font.Name = strFindFont
    .Wrap = wdFindContinue
    .Forward = True
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    If .Execute = True Then
    strDocsList = strDocsList & vbCrLf & objCurDoc.Name
    Exit For
    End If
    End With
    Next aStory
    'restore show hidden setting:
    objView.ShowHiddenText = bHidden
    objCurDoc.Close wdSaveChanges
    End With
    Next i
    End With
    Set objListDoc = Documents.Add
    objListDoc.Content = strDocsList
    objListDoc.Activate

    Set objCurDoc = Nothing
    Set objListDoc = Nothing
    Application.ScreenUpdating = True
    End Sub
    </pre>

    Gary

  5. #5
    Lounger
    Join Date
    Jan 2001
    Location
    Missouri, USA
    Posts
    41
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Find font info

    Thanks guys! I hope to be able to really look at all of this soon (as soon as I get my head above water at work anyway <g>). I appreciate the effort you took.

  6. #6
    JustCallMeAl
    Guest

    Re: Find font info

    Just a caveat to this font search procedure. It works great, except if the font you are searching for is Symbol and you have inserted a Symbol font character via the Insert, Symbol dialog box.

    If you select the text and change the font to Symbol, the procedure will find it. If you use Insert, Symbol, and the Symbol font, it will not.

    (At least in Word97 SR2)

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •