Follow on to Access vba to adjust point/font size in word (1 Viewer)

sxschech

Registered User.
Local time
Yesterday, 19:10
Joined
Mar 2, 2010
Messages
791
Thought I had solved the issue with https://access-programmers.co.uk/forums/showthread.php?t=294335, however,

Came across another word file that had a different font size. It was set to 18, so when my code ran it was changing 18 to 20 rather than keeping at 18. Tried to modify the code to evaluate the size but it returns 9999999 rather than the size of the font of the text in question. I put in a Debug.Print .Replacement.Font.Size as well as debug.Print .Font.Size and that is how I learned that it was not giving the size I was expecting. I did some web searching and so far haven't found an example that would apply to the situation. (at least based on my search terms).

Code:
For Each wdRng In wdDoc.StoryRanges
            With wdRng.Find
                .Text = FindText
                .Replacement.Text = ReplaceText
                [B]Debug.Print .Replacement.Font.Size[/B]
                If Len(ReplaceText) > 50 AND .Font.Size > 20 Then
                    .Replacement.Font.Size = 20
                End If
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            End With
        Next wdRng
 
Last edited:

isladogs

MVP / VIP
Local time
Today, 02:10
Joined
Jan 14, 2017
Messages
18,186
@szschech

I believe this refers to a previous thread of yours.
Suggest you post a link to that thread here
 

sxschech

Registered User.
Local time
Yesterday, 19:10
Joined
Mar 2, 2010
Messages
791
ridders: have edited the post to include reference to original thread per your suggestion.

ashleedawg: let me know if the previous thread provides the information or if you would like me to expand on what the current issue is. Essentially taking data from an access table, using find and replace on text in a word doc, may need to adjust the point size of the font if text wraps more than 2 lines. Received a new word doc and when applied the vba via access to automate word, discovered that this new file had a point size of 18 rather than 20 so code was causing the text to increase rather than remain at 18. When I tried to determine in vba the point size, hovering the mouse over the statement ".Font.Size" showed 9999 rather than the expected 18, 20 or 24. So the logic of the if statement would never work because 9999 is always > 20.
 

ashleedawg

"Here for a good time"
Local time
Yesterday, 19:10
Joined
Jun 22, 2017
Messages
154
Hmm, I'm still a little unclear on what you need to accomplish, but I can tell you that the reason you're getting .Replacement.Font.Size = 999999 is because you're asking for the size of the replacement text before the replacement has been setup or occurred. I'm surprised it doesn't just give you an error.

Perhaps a line line this would be more suitable:
Code:
If .Font.Size > 50 Then .Replacement.Font.Size = 20
...but it's hard to say without seeing more of your code. From what I see, you're trying to say, for example.

  • FindText = "Goose"
  • ReplaceText = "Duck"
  • if ReplaceText is longer than 50 characters and fontsize is larger than 20 then make the fontsize 20.

...but I'm confused, since already we know the length of "Duck" before the procedure even runs. Perhaps if you share the whole procedure it will make more sense?
 

sxschech

Registered User.
Local time
Yesterday, 19:10
Joined
Mar 2, 2010
Messages
791
Thanks for looking into this. Regarding the font size, if you look at original post in this thread
If Len(ReplaceText) > 50 AND .Font.Size > 20 Then
I would assume that this is referring to the existing Font/Text, not the replacement font size. Shouldn't the existing Font/Text be known as it was previously saved in the word docx, rather than showing up as 9999?

Here is the procedure code. It takes the filename, the find text and replace text and locates the appropriate word doc, opens it up, and replaces the text. These are used for building pdf "ebooks" where we have some "standard title" page word doc files that we "slap on" to different pdf files. In general the "cover" page has some graphics, then the name of the book and the name of the author. (There are also multi part books that have a third line devoted to location or date of presentation) They usually prefer that the title of the book is on one line or max of two lines. Since some authors provide titles that are quite long, they wrap onto several lines. I was trying to use vba via access (where the data are stored in tables regarding the book names and other elements needed that are extracted from a cloud based database in csv for other aspects of the work flow.) The original word doc I was given as a prototype was 24 points in the Title, so that was where I discovered the wrapping issue. Another person who does the books "by hand" and requested automation assistance, gave me another word doc to work on and that doc, it turns out was at 18 points. Perhaps that person adjusted to 18 points because their title was too long. Anyway, that is why I was trying to figure out how to evaluate the point size in addition to the character size (string length).

Code:
Sub PrintWordDocs(FilePath As String, FileName As String, FindText As String, BookTitle As String, AuthorCred As String, Acro As String, Optional HandoutNo As Integer)
'http://www.vbaexpress.com/forum/showthread.php?48071-Find-and-replace-in-word-doc-from-excel-vba
'set ref to ms word
'https://social.msdn.microsoft.com/Forums/en-US/d525b79d-ab45-4173-98d9-17f916c35ed4/save-word-document-as-pdf-using-vba?forum=isvvba
'20170413
'Added if statement to reduce point size from 24 to 20 if replacetext
'exceeds 50 characters to have Book Title wrap to 2 lines as this number
'of characters takes 3 lines.  Since based on character length and not
'character width, may still have ocassions where the Book Title will
'wrap to 3 lines, but this should take care of most instances
'20170621
    Dim wdApp As word.Application
    Dim wdDoc As word.Document
    Dim wdRng As word.Range
    Dim stAcro As String
    
    Set wdApp = CreateObject("word.application")
    wdApp.Visible = True
    Set wdDoc = wdApp.Documents.Open(FileName)
    
    If InStr(FileName, "Policies") Then
        ReplaceText = AuthorCred
    Else
        ReplaceText = BookTitle
    End If
    'stAcro = Trim(Me.cboSearch.Column(4))
    For i = 1 To 2
        For Each wdRng In wdDoc.StoryRanges
            With wdRng.Find
                .Text = FindText
                .Replacement.Text = ReplaceText
                'Needs to be adjusted so that works only in case existing size is >20 as
                'revised docx seems to be 18 points and code would be changing 18 points
                'to 20 points, which is unneeded
                'If Len(ReplaceText) > 50 Then
                '    .Replacement.Font.Size = 20
                'End If
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            End With
        Next wdRng
               
        'Change Path if manual entry
        '20170504
        If Me.optManualEntry Then
            FilePath = Me.txtManualEntry
        End If
        
        If i = 1 And InStr(FileName, "Policies") > 0 Then
            FindText = "ACRONYM"
            ReplaceText = Acro 'Me.cboSearch.Column(4) 'InputBox("Acro:", "Replace Acronym")
            FileName = FilePath & Acro & "\Policies.pdf"
        ElseIf i = 1 And (InStr(FileName, "Cover") > 0 Or InStr(FileName, "Title") > 0) Then
            FindText = "Author Name, Credentials"
            ReplaceText = AuthorCred 'Trim(Me.cboSearch.Column(5)) =
            If InStr(FileName, "Cover") > 0 Then
                If HandoutNo > 0 Then
                    FileName = FilePath & Acro & "\CoverHO" & HandoutNo & ".pdf"
                Else
                    FileName = FilePath & Acro & "\Cover.pdf"
                End If
            Else
                FileName = FilePath & Acro & "\TitlePage.pdf"
            End If
        End If
    Next i
    'Save as PDF and close doc
    wdApp.ActiveDocument.SaveAs2 FileName, 17 'Replace(FileName, ".docx", ".pdf"), 17
    wdApp.ActiveDocument.Close savechanges:=wdDoNotSaveChanges
    wdApp.Quit
    Set wdApp = Nothing: Set wdDoc = Nothing: Set wdRng = Nothing
    'Place copy of cover in temp directory so can be
    'easily swapped in pdf file when using actions
    'since the action hard codes the directory, enabling
    'the swap to run without user intervention
    '20170424
    If Dir("C:\Temp", vbDirectory) = "" Then
        MkDir "C:\Temp"
    End If
    If Right(FileName, 9) = "Cover.pdf" Then
        FileCopy FilePath & Acro & "\Cover.pdf", "C:\temp\Cover.pdf"
    End If
End Sub
 

Users who are viewing this thread

Top Bottom