Macro for Font Names and Sizes

apollox · #1 04-25-2018, 08:41 AM

I am very new to macros and I am learning and rookie at vba. I am trying to write a macro which will detect if the document has uniform font size and using same font except for Title page and headings. If any sentence has a different size or different font name then a comment should be added automatically saying check font size or name. For example.

This is an example to test the font sizes macro

If something like this appears then a comment should be automatically added saying check the font name or size. I dont know how to embed about font name so far it only checks font size.

Code:

Sub CheckFonts()

  Dim objSingleWord As Range
  Dim objDoc As Document
  Dim mycomment As Object
 
  Set objDoc = ActiveDocument
 
  With objDoc
    For Each objSingleWord In .Words
      If objSingleWord.Font.Size > 10 Then
        objSingleWord.Font.Size = 10
            mycomment.AddComment "here a comment"
    .Comment.Visible = False
      End If
    Next
  End With
End Sub

This is what I have so far but instead of writing a comment it is changing the font size and doesn't detect the font name.

Any help is much appreciated.

Thank you in advance

slaycock · #2 04-25-2018, 12:57 PM

Most of what you have written is a good attempt but there are a number of simplifications that can be made and a couple of misunderstandings that need to be corrected.

The definition and assignment

Dim mycomment As Object

Set objDoc = ActiveDocument

are not necessary as you only use active document once in your macro. So you could use Activedocument directly (as ActiveDocument.storyranges(wdmaintextstory). If you wanted this macro to be usable by multiple documents it would be better to have a parameter of word.range which represents the range you want to check.

e.g.

Sub CheckFonts(this_range as word.range)

If you then wanted to add flexibility you could make the parameter optional so that if no parameter was provided the active document is used. The default action can be specified as the parameter to assign to the optional argument if no such parameter is supplied but unfortunately you can't specify the active document as the default range.

Sub CheckFonts(optional this_range as word.range=nothing)

The with statement is useful for providing a shortcut to save retyping qualifier text multiple times. Thuis it makes more sense to use the full reference in the for loop and to dereference objSingleWord within the loop

The method .addcomment is an Excel method so won't work in Word. You can check on the definition of keywords by clicking on the keyword and then pressing F1. This will bring up the MS help page for the keyword. This would have helped you see that you'd got an Excel rather than Word method.

The correct syntax is '<range>.comments.add range:=<a_range>, Text:=<comment text>

Unfortunately, in word, uou cannot change the visibility of individual comments. You can only have all or none displayed. The visibility of comments is a property of the View object which is in turn a property of the ActiveWindow object. To hide all the comments you are adding use

this_range.application.activewindow.view.showcomme nts=false

For the name of the font this is obtained using .font.name

Code:

Sub test1()
    
    CheckFonts 
    
End Sub

sub test2()

    CheckFonts ActiveDocument.StoryRanges(wdTextMainStory)

End Sub

Sub test3()                                               

dim my_section                                          as Word.Section

    for each my_section in activedocument.sections
        checkfonts my_section.range
        ' do something for each section?
    next

end sub

Sub CheckFonts(Optional this_range As Word.Range = Nothing)

Dim objSingleWord                                     As Word.Range
Dim my_comment                                      As Word.Comment


    If this_range Is Nothing Then
        Set this_range = ActiveDocument.StoryRanges(wdMainTextStory)
    End If

    this_range.Application.ActiveWindow.view.ShowComments = False
    For Each objSingleWord In this_range.Words
        With objSingleWord
            If .Font.Size <> 10 Then
                .Comments.Add Range:=objSingleWord, Text:="Warning: Font size is " & .Font.Size
                ' or, if you wish to do other activities with the added comment use
                ' Set my_comment = .Comments.Add(Range:=objSingleWord, Text:="here a comment")
            End If
            If .Font.name <> "Arial" Then
                .Comments.Add Range:=objSingleWord, Text:="Warning: Font name is " & .Font.name
            End If
        End With
    Next
End Sub

apollox · #3 05-08-2018, 10:43 AM

Thank you. I will work on what you said.

macropod · #4 05-08-2018, 08:48 PM

All you really need to test for uniformity is something like:

Code:

Sub TestFonts()
With ActiveDocument.Range
  If .Font.Name = "" Then .InsertBefore "Check Font Name" & vbCr
  If .Font.Size = 9999999 Then .InsertBefore "Check Font Size" & vbCr
End With
End Sub

David Matthews · #5 05-09-2018, 01:00 PM

This gives a list of all fonts used, but not the sizes (oh, it takes a while to run, BTW):

Public Sub ListFontsInDoc1()
Dim FontList(199) As String
Dim FontCount As Integer
Dim FontName As String
Dim J As Integer, K As Integer, L As Integer
Dim X As Long, Y As Long
Dim FoundFont As Boolean
Dim rngChar As Range
Dim strFontList As String

FontCount = 0
X = ActiveDocument.Characters.Count
Y = 0
' For-Next loop through every character
For Each rngChar In ActiveDocument.Characters
Y = Y + 1
FontName = rngChar.Font.Name
StatusBar = Y & ":" & X
' check if font used for this char already in list
FoundFont = False
For J = 1 To FontCount
If FontList(J) = FontName Then FoundFont = True
Next J
If Not FoundFont Then
FontCount = FontCount + 1
FontList(FontCount) = FontName
End If
Next rngChar

' sort the list
StatusBar = "Sorting Font List"
For J = 1 To FontCount - 1
L = J
For K = J + 1 To FontCount
If FontList(L) > FontList(K) Then L = K
Next K
If J <> L Then
FontName = FontList(J)
FontList(J) = FontList(L)
FontList(L) = FontName
End If
Next J

StatusBar = ""
' put in new document
Documents.Add
Selection.TypeText Text:="There are " & _
FontCount & " fonts used in the document, as follows:"
Selection.TypeParagraph
Selection.TypeParagraph
For J = 1 To FontCount
Selection.TypeText Text:=FontList(J)
Selection.TypeParagraph
Next J
End Sub

macropod · #6 05-09-2018, 02:26 PM

Quote:

Originally Posted by David Matthews

This gives a list of all fonts used, but not the sizes

But that isn't what the OP is trying to find out...

PS: When posting code, please use the code tags, indicated by the # button on the posting menu. Without them, your code loses much of whatever structure it had.

apollox · #7 06-12-2018, 12:45 PM

Any of the above codes are working out for me when it comes to detecting font names. I am having heard time writing a code where it will NOT change the font size of the headings or sub headings bit only to paragraphs. Any suggestions will be very helpful

macropod · #8 06-13-2018, 02:19 AM

Apart from inserting the relevant 'check font' text, my code makes no changes to either your fonts or their sizes.

Guessed · #9 06-13-2018, 06:00 AM

Assuming you only want to test font sizes and typefaces from the first heading onwards, you could use code like this

Code:

Sub CommentMania()
  Dim aRng As Range, aPara As Paragraph
  Set aRng = ActiveDocument.Range.GoTo(What:=wdGoToHeading, Which:=wdGoToFirst, Count:=1)
  aRng.End = ActiveDocument.Range.End
  For Each aPara In aRng.Paragraphs
    If Left(aPara.Style.NameLocal, 7) <> "Heading" Then
      If aPara.Range.Font.Size <> 10 Then
        ActiveDocument.Comments.Add aPara.Range, "Check font size"
      ElseIf aPara.Range.Font.Name <> "Arial" Then
        ActiveDocument.Comments.Add aPara.Range, "Check typeface"
      End If
    End If
  Next aPara
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Same selection of font..different sizes...	Garyz	Word	8	02-02-2016 09:13 AM
Change font sizes in template	Calab	PowerPoint	1	12-23-2013 09:29 AM
Reply: huge font sizes...	Uli	Outlook	3	09-19-2012 06:57 PM
Font sizes in Outlook 2003	peterandrew	Outlook	3	09-18-2012 04:26 AM
Changing all different font sizes by a value	Puffin617	Word VBA	6	05-21-2009 08:23 AM