Arabic specific scripts for Word cleanup

Arabic.bas

Private Sub FormatArabicStyles()

Dim objUndo As UndoRecord
Set objUndo = Application.UndoRecord
objUndo.StartCustomRecord ("Format Arabic text styles")
Application.ScreenUpdating = False

'-----First clear formatting, then set styles-----'

'CLEAR FORMATTING

'https://stackoverflow.com/a/60842981
For Each myStory In ActiveDocument.StoryRanges
    If myStory.StoryType = wdMainTextStory Then
        myStory.Select
        Selection.ClearCharacterDirectFormatting
        Selection.ClearParagraphDirectFormatting
        Selection.Collapse

    ElseIf myStory.StoryType = wdFootnotesStory Then
        With myStory.Footnotes
            If myStory.Footnotes.count >= 1 Then
                For Each footnote In myStory.Footnotes
                    footnote.Range.FormattedText.Select
                    Selection.ClearCharacterDirectFormatting
                    Selection.ClearParagraphDirectFormatting
                    Selection.Collapse
                Next
            End If
        End With
    End If
Next myStory

'SET STYLES

Dim sNor As style
Dim H1 As style
Dim H2 As style
Dim H3 As style
Dim H4 As style
Dim H5 As style
Dim sTit As style
Dim Block As style

Set sNor = ActiveDocument.Styles(wdStyleNormal)
Set H1 = ActiveDocument.Styles(wdStyleHeading1)
Set H2 = ActiveDocument.Styles(wdStyleHeading2)
Set H3 = ActiveDocument.Styles(wdStyleHeading3)
Set H4 = ActiveDocument.Styles(wdStyleHeading4)
Set H5 = ActiveDocument.Styles(wdStyleHeading5)
Set H6 = ActiveDocument.Styles(wdStyleHeading6)
Set sTit = ActiveDocument.Styles(wdStyleTitle)
Set Block = ActiveDocument.Styles("Block Text")

    With sNor
        .LanguageId = wdArabicEgypt 'https://learn.microsoft.com/en-us/office/vba/api/Word.wdlanguageid
        .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
        .Font.Name = "Verdana"
        .Font.Size = 11
        .Font.NameBi = "Arial"
        .Font.SizeBi = 18
        .Font.ColorIndexBi = wdBlack
        .ParagraphFormat.SpaceAfter = 10
        .ParagraphFormat.FirstLineIndent = 0
        '.ParagraphFormat.Alignment = wdAlignParagraphLeft
        .ParagraphFormat.LineSpacingRule = wdLineSpaceMultiple
        .ParagraphFormat.LineSpacing = LinesToPoints(1)
    End With
    
    'Title Page Text
    With sTit
        .LanguageId = wdArabicEgypt 'https://learn.microsoft.com/en-us/office/vba/api/Word.wdlanguageid
        .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
        .Font.NameBi = "Arial"
        .Font.SizeBi = 42
        .Font.BoldBi = True
        .Font.Name = "Arial"
        .Font.Size = 42
        .Font.Bold = True
        .Font.Color = RGB(70, 147, 165)
        .ParagraphFormat.SpaceBefore = 108
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
        .ParagraphFormat.FirstLineIndent = 0
    End With
    
    With H1
        .LanguageId = wdArabicEgypt 'https://learn.microsoft.com/en-us/office/vba/api/Word.wdlanguageid
        .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
        .Font.BoldBi = True
        .Font.NameBi = "Arial"
        .Font.SizeBi = 26
        .Font.ColorIndexBi = wdBlack
        .ParagraphFormat.Alignment = wdAlignParagraphRight
        .ParagraphFormat.SpaceAfter = 0
        .ParagraphFormat.FirstLineIndent = 0
        .ParagraphFormat.PageBreakBefore = True
        
        'Default "Latin" styling so it looks right in the style panel
        .Font.Bold = True
        .Font.Name = "Verdana"
        .Font.Size = 18
        .Font.ColorIndex = wdBlack
    End With
    
    With H2
        .LanguageId = wdArabicEgypt 'https://learn.microsoft.com/en-us/office/vba/api/Word.wdlanguageid
        .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
        .Font.BoldBi = True
        .Font.ItalicBi = False
        .Font.NameBi = "Arial"
        .Font.SizeBi = 26
        .Font.ColorIndexBi = wdBlack
        .ParagraphFormat.Alignment = wdAlignParagraphRight
        .ParagraphFormat.SpaceBefore = 0
        .ParagraphFormat.SpaceAfter = 30
        .ParagraphFormat.FirstLineIndent = 0
        
        'Default "Latin" styling so it looks right in the style panel
        .Font.Bold = True
        .Font.Name = "Verdana"
        .Font.Size = 18
        .Font.ColorIndex = wdBlack
    End With

    With H3
        .LanguageId = wdArabicEgypt 'https://learn.microsoft.com/en-us/office/vba/api/Word.wdlanguageid
        .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
        .Font.BoldBi = True
        .Font.NameBi = "Arial"
        .Font.SizeBi = 18
        .Font.ColorIndexBi = wdBlack
        .ParagraphFormat.KeepWithNext = True
        .ParagraphFormat.SpaceBefore = 12
        .ParagraphFormat.SpaceAfter = 8
        .ParagraphFormat.FirstLineIndent = 0
        .ParagraphFormat.Shading.BackgroundPatternColor = 14277081
        
        'Default "Latin" styling so it looks right in the style panel
        .Font.Bold = True
        .Font.Italic = False
        .Font.Name = "Verdana"
        .Font.Size = 11
    End With

    With H4
        .LanguageId = wdArabicEgypt 'https://learn.microsoft.com/en-us/office/vba/api/Word.wdlanguageid
        .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
        .Font.BoldBi = True
        .Font.ItalicBi = False
        .Font.NameBi = "Arial"
        .Font.SizeBi = 18
        .Font.ColorIndexBi = wdBlack
        .ParagraphFormat.KeepWithNext = True
        .ParagraphFormat.SpaceBefore = 8
        .ParagraphFormat.SpaceAfter = 8
        .ParagraphFormat.FirstLineIndent = 0
        
        'Default "Latin" styling so it looks right in the style panel
        .Font.Bold = True
        .Font.Italic = False
        .Font.Name = "Verdana"
        .Font.Size = 11
    End With

    With H5
        .LanguageId = wdArabicEgypt 'https://learn.microsoft.com/en-us/office/vba/api/Word.wdlanguageid
        .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
        .Font.BoldBi = True
        .Font.ItalicBi = True
        .Font.NameBi = "Arial"
        .Font.SizeBi = 18
        .Font.ColorIndexBi = wdBlack
        .ParagraphFormat.KeepWithNext = True
        .ParagraphFormat.SpaceAfter = 8
        .ParagraphFormat.FirstLineIndent = 0
        
        'Default "Latin" styling so it looks right in the style panel
        .Font.Bold = True
        .Font.Italic = True
        .Font.Name = "Verdana"
        .Font.Size = 11
    End With

    With H6
        .LanguageId = wdArabicEgypt 'https://learn.microsoft.com/en-us/office/vba/api/Word.wdlanguageid
        .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
        .Font.BoldBi = False
        .Font.ItalicBi = True
        .Font.NameBi = "Arial"
        .Font.SizeBi = 18
        .Font.ColorIndexBi = wdBlack
        .ParagraphFormat.KeepWithNext = True
        .ParagraphFormat.SpaceAfter = 8
        .ParagraphFormat.FirstLineIndent = 0

        'Default "Latin" styling so it looks right in the style panel
        .Font.Bold = False
        .Font.Italic = True
        .Font.Name = "Verdana"
        .Font.Size = 11
    End With
    
    With Block
      .LanguageId = wdArabicEgypt 'https://learn.microsoft.com/en-us/office/vba/api/Word.wdlanguageid
      .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
      .Font.Name = "Verdana"
      .Font.Size = 11
      .Font.NameBi = "Arial"
      .Font.SizeBi = 18
      .Font.Italic = False
      .Font.ItalicBi = False
      .Font.ColorIndexBi = wdBlack
      .ParagraphFormat.SpaceAfter = 8
      .ParagraphFormat.SpaceBefore = 0
      .ParagraphFormat.FirstLineIndent = 0
      .ParagraphFormat.Alignment = wdAlignParagraphRight
      .ParagraphFormat.LineSpacingRule = wdLineSpaceMultiple
      .ParagraphFormat.LineSpacing = LinesToPoints(1.15)
      .ParagraphFormat.LeftIndent = InchesToPoints(0.5)
      .ParagraphFormat.RightIndent = 0
      .ParagraphFormat.Borders.Enable = False
      .Visibility = True
      .QuickStyle = True
      .UnhideWhenUsed = True
    End With

    Dim Ftnt As style
    Set Ftnt = ActiveDocument.Styles("Footnote Text")
    With Ftnt
      .LanguageId = wdArabicEgypt 'https://learn.microsoft.com/en-us/office/vba/api/Word.wdlanguageid
      .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
      .Font.Name = "Verdana"
      .Font.Size = 9
      .Font.NameBi = "Arial"
      .Font.SizeBi = 13
      .Font.Italic = False
      .Font.ItalicBi = False
      .Font.ColorIndexBi = wdBlack
      .ParagraphFormat.SpaceAfter = 2
      .ParagraphFormat.SpaceBefore = 0
      .ParagraphFormat.FirstLineIndent = 0
      .ParagraphFormat.Alignment = wdAlignParagraphRight
      .ParagraphFormat.LineSpacingRule = wdLineSpaceMultiple
      .ParagraphFormat.LineSpacing = LinesToPoints(1.15)
    End With

objUndo.EndCustomRecord
Application.ScreenUpdating = True

MsgBox "Finished styling doc"

End Sub


Private Sub CleanAndFormatArabicTextBoxes()

Application.ScreenUpdating = False

'https://narkive.com/EWve4CSW:2.570.423
Dim oStyle As style, NewStyle As style
Dim bFound As Boolean
Dim strNewStyle As String

'Check for the style
strNewStyle = "SGC Quote"
For Each oStyle In ActiveDocument.Styles
If LCase(oStyle.NameLocal) = LCase(strNewStyle) Then
bFound = True
Exit For
End If
Next oStyle

'If the style doesn't exist, create it
If Not bFound Then
Set NewStyle = ActiveDocument.Styles.Add(Name:=strNewStyle, _
Type:=wdStyleTypeParagraphOnly)
NewStyle.BaseStyle = ""
With NewStyle
 .LanguageId = wdArabicEgypt 'https://learn.microsoft.com/en-us/office/vba/api/Word.wdlanguageid
 .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
 .Font.Name = "Verdana"
 .Font.Size = 11
 .Font.NameBi = "Arial"
 .Font.SizeBi = 16
 .Font.ColorIndex = wdBlack
 .ParagraphFormat.SpaceBefore = 0
 .ParagraphFormat.SpaceAfter = 6
 .ParagraphFormat.Alignment = wdAlignParagraphCenter
 .ParagraphFormat.LineSpacing = LinesToPoints(1.1)
End With
End If

'Format the Shapes
'https://stackoverflow.com/a/68592329
Dim MyShape As Shape
For Each MyShape In ActiveDocument.Shapes
    If MyShape.Type = msoTextBox Then
        MyShape.AutoShapeType = msoShapeRectangle
        'https://stackoverflow.com/q/44981056
        With MyShape
        .Line.ForeColor = wdColorBlack
        .Line.Weight = 0.75
        .Shadow.Visible = msoFalse
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .TextFrame.MarginBottom = 0
        .TextFrame.MarginLeft = Application.InchesToPoints(0.1)
        .TextFrame.MarginRight = Application.InchesToPoints(0.1)
        .TextFrame.MarginTop = Application.InchesToPoints(0.1)
        .TextFrame.textRange.style = ActiveDocument.Styles("SGC Quote")
        .TextFrame.AutoSize = True
        'Set the padding around the textbox
        .WrapFormat.DistanceRight = 14.4
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
        .left = wdShapeLeft
        End With
    End If
    
    'Catch the "fancy" AutoShape textboxes
    If MyShape.Type = msoAutoShape Then
        MyShape.AutoShapeType = msoShapeRectangle
        
        'Some shapes were rotated, making the "bottom" border the left border
        'So we will rotate them back to upright position
        'https://answers.microsoft.com/en-us/msoffice/forum/all/vba-to-detect-rotation-of-inline-shape/3807b061-851b-44be-9eb1-da4c8aa2bdbf
        If MyShape.Rotation <> 0 Then
            MyShape.Rotation = 0
        Else
        'https://stackoverflow.com/q/44981056
        With MyShape
        .Line.ForeColor = wdColorBlack
        .Line.Weight = 0.75
        .Shadow.Visible = msoFalse
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .TextFrame.MarginBottom = 0
        .TextFrame.MarginLeft = Application.InchesToPoints(0.1)
        .TextFrame.MarginRight = Application.InchesToPoints(0.1)
        .TextFrame.MarginTop = Application.InchesToPoints(0.1)
        .TextFrame.textRange.style = ActiveDocument.Styles("SGC Quote")
        .TextFrame.AutoSize = True
        'Set the padding around the textbox
        .WrapFormat.DistanceRight = 14.4
        .WrapFormat.DistanceTop = 0
        .WrapFormat.DistanceBottom = 0
        .WrapFormat.DistanceLeft = 0
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
        .left = wdShapeLeft
        End With
        End If
    End If
Next
    
Application.ScreenUpdating = True

End Sub

Sub RemoveCharacterStyleFromHeadings()

Application.ScreenUpdating = False

'Timer
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer

Dim oPara As Paragraph
For Each oPara In ActiveDocument.Paragraphs
    If oPara.OutlineLevel = 1 Then
        oPara.Range.style = wdStyleDefaultParagraphFont 'Removes Character style and applies default character style
    End If
    If oPara.OutlineLevel = 2 Then
        oPara.Range.style = wdStyleDefaultParagraphFont
    End If
    If oPara.OutlineLevel = 3 Then
        oPara.Range.style = wdStyleDefaultParagraphFont
    End If
    If oPara.OutlineLevel = 4 Then
        oPara.Range.style = wdStyleDefaultParagraphFont
    End If
    If oPara.OutlineLevel = 5 Then
        oPara.Range.style = wdStyleDefaultParagraphFont
    End If
    If oPara.OutlineLevel = 6 Then
        oPara.Range.style = wdStyleDefaultParagraphFont
    End If
Next oPara

SecondsElapsed = Round(Timer - StartTime, 2)
Application.ScreenUpdating = True

MsgBox "This code took " & SecondsElapsed & " seconds to run."

End Sub

Sub CreateArabicTOC()

'Add page breaks to make all chapter titles start on an even page number
Dim rng As Range
Dim pgNum As Integer
Set rng = ActiveDocument.Range
With rng.Find
    .style = ActiveDocument.Styles("Heading 1")
    .Forward = True
    .Wrap = wdFindStop
    
    Do While .Execute
        pgNum = rng.Information(wdActiveEndPageNumber)
        If pgNum Mod 2 = 1 Then
            rng.Collapse Direction:=wdCollapseStart
            rng.InsertBreak Type:=wdPageBreak
        End If
    Loop
End With

'Create the TOC
Set myRange = ActiveDocument.Range(Start:=Selection.End, End:=Selection.End)
ActiveDocument.TablesOfContents.Add _
 Range:=myRange, _
 UseFields:=False, _
 UseHeadingStyles:=True, _
 LowerHeadingLevel:=2, _
 UpperHeadingLevel:=2
 
With ActiveDocument.Styles("TOC 2")
  .AutomaticallyUpdate = False
End With

'ADD NUMBERING TO THE TOC ENTRIES
Dim tocRange As Range
Dim tocParagraph As Paragraph
Set tocRange = ActiveDocument.TablesOfContents(1).Range
Set tocParagraph = tocRange.Paragraphs(1)
tocParagraph.Range.ListFormat.ApplyNumberDefault
tocParagraph.Range.ListFormat.ListOutdent

'Style the TOC
With ActiveDocument.Styles("TOC 2")
  .LanguageId = wdArabicEgypt 'https://learn.microsoft.com/en-us/office/vba/api/Word.wdlanguageid
  .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
  .Font.Name = "Arial"
  .Font.Bold = False
  .Font.Size = 14
  .Font.NameBi = "Arial"
  .Font.SizeBi = 18
  'https://stackoverflow.com/a/23449772
  .NoSpaceBetweenParagraphsOfSameStyle = True
  .ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
  .ParagraphFormat.LineSpacing = 20
  .ParagraphFormat.LeftIndent = 0
End With

'https://eileenslounge.com/viewtopic.php?t=37868
'Set the font specs for the numbered list in the TOC
tocParagraph.Range.ListFormat.ListTemplate.ListLevels(1).Font.Name = "Arial"
tocParagraph.Range.ListFormat.ListTemplate.ListLevels(1).Font.Size = 16
tocRange.ParagraphFormat.ReadingOrder = wdReadingOrderRtl
'Set indent so that numbers over 10 don't overflow to next line
tocRange.ParagraphFormat.LeftIndent = InchesToPoints(0.35)
tocRange.ParagraphFormat.FirstLineIndent = InchesToPoints(-0.35) 'hanging indent

End Sub