VBCommons/word/ex_Word.bas

Attribute VB_Name = "ex_Word"
'================ Word helper functions =============
' Shared module version: 20220911
' Tested in: TestWord
' Depends on:
' Required reference:
Option Private Module
Option Explicit

Public Function WordIntersectRanges(rng1 As Word.Range, rng2 As Word.Range) As Word.Range
  If rng1.Document <> rng2.Document Then _
    Exit Function
  If rng1.Start >= rng2.End Or rng2.Start >= rng1.End Then _
    Exit Function
  If rng1.Start >= rng2.Start Then
    If rng2.End > rng1.Start Then _
      Set WordIntersectRanges = rng1.Document.Range(rng1.Start, IIf(rng1.End > rng2.End, rng2.End, rng1.End))
  Else
    If rng1.End > rng2.Start Then _
      Set WordIntersectRanges = rng1.Document.Range(rng2.Start, IIf(rng1.End > rng2.End, rng2.End, rng1.End))
  End If
End Function

Public Function WordPutText(sText$, iDoc As Word.Document, nWhere&, Optional aStyle$ = vbNullString) As Word.Range
  Set WordPutText = iDoc.Range(nWhere, nWhere)
  With WordPutText
    Call .InsertAfter(sText)
    If aStyle <> vbNullString Then _
      .Style = aStyle
  End With
End Function

Public Function WordAppendTo(sText$, ByRef rWhere As Word.Range, Optional aStyle$ = vbNullString) As Word.Range
  Const ASCII_NEWLINE = 13
  
  If rWhere.Characters.Count > 0 Then _
    If AscW(rWhere.Characters.Last) = ASCII_NEWLINE Then _
      Call rWhere.MoveEnd(wdCharacter, -1)
  
  Call rWhere.InsertAfter(sText)
  Dim insertedRng As Word.Range: Set insertedRng = rWhere.Duplicate
  insertedRng.Start = rWhere.End - VBA.Len(sText)
  If aStyle <> vbNullString Then _
    insertedRng.Style = aStyle
  Set WordAppendTo = insertedRng
End Function

Public Function WordAddLine(sText$, rWhere As Word.Range, Optional aStyle$ = vbNullString) As Word.Range
  Dim nEnd&: nEnd = rWhere.End
  If rWhere.Tables.Count > 0 Then
    If rWhere.Cells.Count > 0 Then
      Dim theLastCell As Word.Cell: Set theLastCell = rWhere.Cells(rWhere.Cells.Count)
      If nEnd >= theLastCell.Range.End - 1 Then
        Set WordAddLine = AddLineLastInCell(sText, theLastCell, aStyle)
        GoTo SAFE_EXIT
      End If
    End If
  End If
  
  Dim nParaEnd&: nParaEnd = rWhere.Paragraphs.Last.Range.End
  If rWhere.End = rWhere.Document.Range.End Then
    Call rWhere.InsertAfter(vbNewLine)
    Set WordAddLine = WordPutText(sText, rWhere.Document, rWhere.End - 1, aStyle)
    Call WordAddLine.MoveEnd(wdCharacter, 1)
    GoTo SAFE_EXIT
  End If
  
  If nEnd <> nParaEnd Then
    If rWhere.Next(wdCharacter, 1).End = nParaEnd Then
      Call rWhere.MoveEnd(wdCharacter, 1)
    Else
      Call rWhere.InsertAfter(vbNewLine)
    End If
  End If
  Set WordAddLine = WordPutText(sText & vbNewLine, rWhere.Document, rWhere.End, aStyle)
  
SAFE_EXIT:
  rWhere.End = nEnd
End Function

Public Function WordFindAndReplace(iDoc As Word.Document, findText$, ReplaceText$, _
                            Optional mCase As Boolean = False, _
                            Optional wildCard As Boolean = False, _
                            Optional wholeWord As Boolean = True) As Long
  Dim findRange As Word.Range: Set findRange = iDoc.Range
  Dim nResult&: nResult = 0
  With findRange.Find
    .Text = findText
    .MatchCase = mCase
    .MatchWholeWord = wholeWord
    .MatchWildcards = wildCard
    .Replacement.Text = ReplaceText
    .Format = True
    .Font.Hidden = False
    
    Do While .Execute(Replace:=1)
      nResult = nResult + 1
      Call findRange.Collapse(Direction:=wdCollapseEnd)
    Loop
  End With
  WordFindAndReplace = nResult
End Function

Public Function WordDeleteHyperlinks(iDoc As Word.Document) As Long
  On Error Resume Next
  WordDeleteHyperlinks = 0
  Do Until iDoc.Hyperlinks.Count = 0
    Call iDoc.Hyperlinks(1).Delete
    WordDeleteHyperlinks = WordDeleteHyperlinks + 1
  Loop
End Function

Public Function WordStyleExists(iDoc As Word.Document, target$) As Boolean
  WordStyleExists = True
  On Error GoTo RET_FALSE
  Dim aStyle As Word.Style: Set aStyle = iDoc.Styles(target)
  Exit Function
  
RET_FALSE:
  WordStyleExists = False
End Function

' Requires: wordApp should be Application, responsible for both documents (if any or both are open)
Public Function WordCopyStyle(wordApp As Word.Application, sSource$, sDestination$, sStyle$) As Boolean
  WordCopyStyle = True
  On Error GoTo RETURN_FALSE
  Call wordApp.OrganizerCopy(sSource, sDestination, sStyle, wdOrganizerObjectStyles)
  On Error GoTo 0
  Exit Function
RETURN_FALSE:
  WordCopyStyle = False
End Function

Public Function WordStyleIsUsed(iDoc As Word.Document, aStyle As Word.Style) As Boolean
  On Error Resume Next
  Dim findRange As Word.Range: Set findRange = iDoc.Range
  With findRange.Find
    .Text = vbNullString
    .Format = True
    .Style = aStyle
    WordStyleIsUsed = .Execute
  End With
End Function

Public Function WordAdjustRange(target As Word.Range) As Word.Range
  Dim rExpansion As Word.Range: Set rExpansion = target.Duplicate
  If Not rExpansion.Characters.First Like "[" & " " & Chr(160) & "]" Then
    Call rExpansion.StartOf(wdWord, wdExtend)
    Call rExpansion.MoveStartWhile("""'<27><><EFBFBD><EFBFBD>", wdBackward)
  End If
  
  If rExpansion.Start <> rExpansion.End Then _
    Call rExpansion.EndOf(wdWord, wdExtend)
  
  If Not rExpansion.Characters.Last Like "[" & " " & Chr(160) & "]" Then
    Call rExpansion.MoveEndWhile("""'<27><><EFBFBD><EFBFBD>", wdForward)
    Call rExpansion.MoveEndWhile(" " & Chr(160), wdForward)
  End If

  Set WordAdjustRange = rExpansion
End Function

Public Function AcceptAuthorsRevision(oAuthors As Collection, target As Word.Document) As Long
  AcceptAuthorsRevision = 0
  Dim itemChange As Word.Revision
  For Each itemChange In target.Revisions
    Dim sAuthor As Variant
    For Each sAuthor In oAuthors
      If sAuthor = itemChange.Author Then
        Call itemChange.Accept
        AcceptAuthorsRevision = AcceptAuthorsRevision + 1
        GoTo NEXT_ITEM
      End If
    Next sAuthor
NEXT_ITEM:
  Next itemChange
End Function

Public Function AcceptFormatRevision(iDoc As Word.Document) As Long
  AcceptFormatRevision = 0
  Dim itemChange As Word.Revision
  Dim theType As WdRevisionType
  For Each itemChange In iDoc.Revisions
    theType = itemChange.Type
    If theType = wdRevisionParagraphProperty Or _
       theType = wdRevisionStyle Or _
       theType = wdRevisionProperty Then
      itemChange.Accept
      AcceptFormatRevision = AcceptFormatRevision + 1
    End If
  Next itemChange
End Function

Public Function StyleByName(sStyle$, iDoc As Word.Document) As Word.Style
  On Error GoTo RETURN_NOTHING
  Set StyleByName = iDoc.Styles(sStyle)
RETURN_NOTHING:
End Function

Public Function ExtractCommentText(target As Word.Range) As String
  If target.Comments.Count <> 0 Then
    ExtractCommentText = target.Comments(1).Range.Text
    Exit Function
  End If
  
  Dim theDoc As Word.Document: Set theDoc = target.Document
  Dim aComment As Word.Comment
  For Each aComment In theDoc.Comments
    If target.InRange(aComment.Scope) Then
      ExtractCommentText = aComment.Range.Text
      Exit Function
    End If
  Next aComment
  ExtractCommentText = vbNullString
End Function

' =====
Private Function AddLineLastInCell(sText$, whereCell As Word.Cell, aStyle$) As Word.Range
  Dim nWhere&: nWhere = whereCell.Range.End - 1
  If whereCell.Range.Characters.Count > 1 Then
    Call WordPutText(vbNewLine, whereCell.Range.Document, nWhere)
    nWhere = nWhere + 1
  End If
  Set AddLineLastInCell = WordPutText(sText, whereCell.Range.Document, whereCell.Range.End - 1, aStyle)
End Function