Fix Scrivener Longlasting Stupidity

FixScrevener.vb

' - Scrivener has a host of bugs and is rarely updated--this document will be my knowledge share with my writing on how I've worked around this.
' - Always compile to rtf.
' - Load rtf in word.
' - Save as docx.
' - Open print dialog and close it to force table of contents to update.
' - Paperback 6x9 margins: all 0.75, except outside is 0.45, gutter 0.13
' - Paperback 6x9 custom size 6x9
' - Paperback 6x9 layout header 0.5, footer 0.0
' - Highlight all text in footers, open layout -> paragraph -> check keep lines together
' - On the File tab, go to Options > Customize Ribbon. Under Customize the Ribbon and under Main Tabs, select the Developer check box.
' - Press Alt + F11 to open the VBA editor in Word.
' - In the VBA editor, go to Insert > Module to create a new module.
' - Paste in the following text, save, and then back in word, go to developer tab, click macros, and run any as needed.

Sub ConvertPlainTextURLsToHyperlinksInFooters()
    Dim sec As Section
    Dim ftr As HeaderFooter
    Dim ftrRange As Range
    Dim regex As Object
    Dim matches As Object
    Dim match As Object
    Dim startPos As Long
    Dim endPos As Long
    Dim url As String
    Dim rng As Range
    
    ' Define a simple URL pattern
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Global = True
        .IgnoreCase = True
        .Pattern = "(http|https)://[^\s]+"
    End With
    
    ' Disable screen updating
    Application.ScreenUpdating = False

    ' Start the undo record
    Application.UndoRecord.StartCustomRecord "Ensure footers have proper hyperlinks"
    
    ' Loop through each section in the document
    For Each sec In ActiveDocument.Sections
        ' Loop through each footer in the section
        For Each ftr In sec.Footers
            ' If the footer is not empty
            If ftr.Range.Text <> vbCr Then
                Set ftrRange = ftr.Range
                ' Find matches
                If regex.test(ftrRange.Text) Then
                    Set matches = regex.Execute(ftrRange.Text)
                    ' Loop through matches in reverse to avoid messing up positions
                    For i = matches.Count - 1 To 0 Step -1
                        Set match = matches(i)
                        startPos = match.FirstIndex + 1
                        endPos = startPos + match.Length - 1
                        url = match.Value
                        ' Set the range for the URL
                        Set rng = ftrRange.Characters(startPos)
                        rng.End = ftrRange.Characters(endPos).End
                        ' Add hyperlink
                        ftrRange.Hyperlinks.Add Anchor:=rng, Address:=url, TextToDisplay:=url
                    Next i
                End If
            End If
        Next ftr
    Next sec
    
    ' End the undo record
    Application.UndoRecord.EndCustomRecord
    
    ' Re-enable screen updating
    Application.ScreenUpdating = True
    
    MsgBox "All plain text URLs in footers have been converted to hyperlinks."
End Sub

Sub RemoveFirstBlankLineEachPage()
    Dim doc As Document
    Set doc = ActiveDocument
    Dim i As Integer
    Dim rngParagraph As Range
    
    ' Disable screen updating
    Application.ScreenUpdating = False

    ' Start the undo record
    Application.UndoRecord.StartCustomRecord "Fix blank lines on start of pages"

    Application.ScreenUpdating = False
    For i = 1 To doc.ComputeStatistics(wdStatisticPages)
        ' Go to the beginning of each page
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i
        Selection.HomeKey Unit:=wdLine
        
        ' Set range to the first paragraph in the page
        Set rngParagraph = Selection.Paragraphs(1).Range
        
        ' Check if the paragraph is empty
        If Len(Trim(rngParagraph.Text)) = 1 Then
            If Asc(rngParagraph.Text) = 13 Then ' Check if it is a carriage return
                If Selection.Paragraphs.Count = 1 Then
                    rngParagraph.Delete
                ElseIf rngParagraph.ParagraphFormat.Alignment = wdAlignParagraphJustify And Selection.Paragraphs(2).Range.ParagraphFormat.Alignment <> wdAlignParagraphCenter Then
                    rngParagraph.Delete
                End If
            End If
        End If
    Next i
        
    ' End the undo record
    Application.UndoRecord.EndCustomRecord
    
    ' Re-enable screen updating
    Application.ScreenUpdating = True
    
    MsgBox "Blank lines at start of pages have been removed."
End Sub

Sub ChangeFootnoteNumbersTo10Point()
    Dim footnote As footnote
    Dim storyRange As Range
    Dim footnoteRange As Range
    
    ' Disable screen updating
    Application.ScreenUpdating = False

    ' Start the undo record
    Application.UndoRecord.StartCustomRecord "Fix footnote fonts"

    ' Change the font size of the footnote reference numbers in the main text
    For Each footnote In ActiveDocument.Footnotes
        footnote.Reference.Font.Size = 10
    Next footnote

    ' Change the font size of the footnote numbers at the bottom of the page
    For Each storyRange In ActiveDocument.StoryRanges
        If storyRange.StoryType = wdFootnotesStory Then
            Set footnoteRange = storyRange
            footnoteRange.Font.Size = 10
        End If
    Next storyRange
    
    ' End the undo record
    Application.UndoRecord.EndCustomRecord
    
    ' Re-enable screen updating
    Application.ScreenUpdating = True

    ' Inform the user that the operation is complete
    MsgBox "All footnote numbers have been changed to 10 point."
End Sub

Sub AdjustImagesWithPaddingAndWrapping()
    Dim doc As Document: Set doc = ActiveDocument
	Dim shapeArray() As InlineShape
    Dim inlineShape As InlineShape
    Dim shape As shape
    Dim leftAlign As Boolean
    Dim anchorParagraph As Paragraph
    Dim anchorFormatting As ParagraphFormat
    Dim i As Long, n As Long
	
    Const DistanceFromText As Single = 9.36 ' 0.13 inches converted to points (1 inch = 72 points)
    Const FirstLineIndent As Single = 72 * 0.2
    Const MinHeightToProcess = 72 * 0.5
    
	n = doc.InlineShapes.Count
	ReDim shapeArray(1 To n)

	For i = 1 To n
		Set shapeArray(i) = doc.InlineShapes(i)
	Next i

    On Error Resume Next ' Enable error handling

    Set doc = ActiveDocument
    leftAlign = True ' Start with left alignment

    ' Disable screen updating
    Application.ScreenUpdating = False

    ' Start the undo record
    Application.UndoRecord.StartCustomRecord "Alternate Square Image Alignment"
    
    For i = n To 1 Step -1
        ' Convert the InlineShape to Shape
        Set inlineShape = shapeArray(i)
            
        ' Landscape and square images need processing
        If inlineShape.Type = wdInlineShapePicture And inlineShape.Width >= inlineShape.Height And inlineShape.Height > MinHeightToProcess Then
            Set shape = inlineShape.ConvertToShape

            If Err.Number <> 0 Then
                Err.Clear ' Clear the error
                GoTo NextIteration ' Skip the rest of the loop
            End If

            ' Nuke newline
            shape.Anchor.Paragraphs(1).Range.Delete 2, 1
            shape.Anchor.Paragraphs(1).Alignment = wdAlignParagraphJustify
            shape.Anchor.Paragraphs(1).Format.FirstLineIndent = FirstLineIndent
                
            If shape.Width = shape.Height Then
                ' Set distance from text
                With shape.WrapFormat
                    .DistanceTop = DistanceFromText
                    .DistanceBottom = DistanceFromText
                    .DistanceLeft = DistanceFromText
                    .DistanceRight = DistanceFromText
                    .Type = wdWrapSquare
                End With
				
				shape.RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
				shape.RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
				shape.Top = 0
	
                ' Alternate alignment
                If leftAlign Then
                    shape.Left = wdShapeLeft ' Align left
                Else
                    shape.Left = wdShapeRight ' Align right
                End If
                
                ' Toggle alignment for next image
                leftAlign = Not leftAlign
            Else
                With shape.WrapFormat
                    .DistanceTop = DistanceFromText ' Padding above the image
                    .DistanceBottom = DistanceFromText ' Padding below the image
                    .DistanceLeft = 0
                    .DistanceRight = 0
                    .Type = wdWrapTopBottom
                End With
                
                shape.RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
                shape.Left = wdShapeCenter
                'shape.Anchor.InsertParagraphAfter
                
                ' Adjust the vertical position so the image sits below the anchor paragraph.
                shape.RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
                ' Offset by the height of the anchor paragraph
                shape.Top = DistanceFromText + 2 'shape.Anchor.Paragraphs(1).Range.Information(wdVerticalPositionRelativeToPage)
            End If
        End If

NextIteration:

    Next i
    
    ' End the undo record
    Application.UndoRecord.EndCustomRecord
    
    ' Re-enable screen updating
    Application.ScreenUpdating = True

    MsgBox "All images have been adjusted."
End Sub

Sub ApplyDropCapToChapters()
    Const DROP_LINES  As Long = 3
    Const GAP_PT      As Single = 3.6

    Dim p        As Paragraph      ' our “outer” pointer
    Dim bodyP    As Paragraph      ' the paragraph we drop-cap
    Dim nextPara As Paragraph      ' where to resume after a cap

    Application.ScreenUpdating = False
    Application.UndoRecord.StartCustomRecord "Chapter-by-Chapter Drop Caps"
    
    Set p = ActiveDocument.Paragraphs(1)

    Do While Not p Is Nothing
        ' 1) Is this a Heading 1?
        If p.OutlineLevel = wdOutlineLevel1 Then

            ' 2) scan forward for the first justified, non-empty, non-heading para
            Set bodyP = p.Next
            Do While Not bodyP Is Nothing
                With bodyP
                    ' If statement must be separated due to VBA evaluating ALL parts even for And operator
                    If .Alignment = wdAlignParagraphJustify And .Range.ComputeStatistics(wdStatisticWords) > 0 Then
                        If .OutlineLevel = wdOutlineLevelBodyText Then
                            If .DropCap.Position = wdDropNormal Then
                                Exit Do ' Already did this chapter
                            End If

                            ' 3) apply the drop-cap
                            With .DropCap
                                .Position = wdDropNormal
                                .LinesToDrop = DROP_LINES
                                .DistanceFromText = GAP_PT
                                .FontName = bodyP.Range.Font.Name
                            End With

                            Exit Do
                        End If
                    End If
                End With
                Set bodyP = bodyP.Next
            Loop

            ' 4) now decide where the *outer* pointer jumps to:
            '    if we found a bodyP, go to the paragraph *after* it;
            '    otherwise we’re at the end of the doc so quit.
            If Not bodyP Is Nothing Then
                Set p = bodyP.Next
            Else
                Exit Do
            End If

        Else
            ' not a Heading 1, so just move to the next paragraph
            Set p = p.Next
        End If
    Loop
    
    Application.UndoRecord.EndCustomRecord
    Application.ScreenUpdating = True

    MsgBox "Done dropcapping chapters."
End Sub