VBCommons/word/API_WordEditGuard.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "API_WordEditGuard"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ========= Îáîëî÷êà äëÿ ðåäàêòèðîâàíèÿ äîêóìåíòà â Ìàñòåðå Òåêñòîâ ===================
' Shared module version: 20220613
' Tested in:
' Depends on: API_WordWrapper
' Required reference: Word
Option Explicit

' Note: should synchronize with DocumentEditor
Private Const ERROR_HIGHLIGHT_COLOR = wdViolet

Private Const AUTOMATON_USER_NAME = "Ìàñòåð òåêñòîâ"
Private Const AUTOMATON_USER_INIT = "ÌÒ"

Private Const IGNORE_BM_PREFIX = "zIGNORE_"
Private Const AUTO_COMMENT_PREFIX = "AR"

Private document_ As Word.Document
Private word_ As API_WordWrapper

Private userName_ As String
Private userInitials_ As String
Private trackRevisions_ As Boolean
Private includeHiddenText_ As Boolean
Private includeFieldCodes_ As Boolean
Private deletedTextMark_ As WdDeletedTextMark
Private noProofing_ As Boolean

Private Sub Class_Terminate()
  Set document_ = Nothing
End Sub

Public Function Init(target As API_WordWrapper)
  Set document_ = target.Document
  Set word_ = target
End Function

Public Function InitDoc(target As Word.Document)
  Set document_ = target
  Set word_ = Nothing
End Function

Public Property Get Document() As Word.Document
  Set Document = document_
End Property

Public Property Get Wrapper() As API_WordWrapper
  Set Wrapper = word_
End Property

Public Function BeginEdit(bTrackRevisions As Boolean)
  With document_
    userName_ = .Application.UserName
    userInitials_ = .Application.UserInitials
    trackRevisions_ = .TrackRevisions
    includeHiddenText_ = .Range.TextRetrievalMode.IncludeHiddenText
    includeFieldCodes_ = .Range.TextRetrievalMode.IncludeFieldCodes
    deletedTextMark_ = .Application.Options.DeletedTextMark
    noProofing_ = .Range.NoProofing
  
    .ActiveWindow.View.ReadingLayout = False
    .Range.NoProofing = True
    .Application.ScreenUpdating = False
  End With
  
  Call HideIgnored
  Call ClearExistingFormat
  
  On Error Resume Next  ' Ñðàáàòûâàåò, åñëè îôèñ íå 2013 è ïàðàìåòðà Options.UseLocalUserInfo íå ñóùåñòâóåò
  With document_
    .TrackRevisions = bTrackRevisions
    .Range.TextRetrievalMode.IncludeHiddenText = False
    .Range.TextRetrievalMode.IncludeFieldCodes = False
    .Application.Options.DeletedTextMark = wdDeletedTextMarkHidden
    
    .Application.UserName = AUTOMATON_USER_NAME
    .Application.UserInitials = AUTOMATON_USER_INIT
    .Application.Options.UseLocalUserInfo = True
  End With
  On Error GoTo 0
End Function

Public Function EndEdit()
  If userName_ = vbNullString Then _
    userName_ = VBA.Environ("username")
    
  On Error Resume Next
  With document_
    .TrackRevisions = trackRevisions_
    Call UnHideIgnored
    
    .Application.UserName = userName_
    .Application.UserInitials = userInitials_
    .Range.TextRetrievalMode.IncludeHiddenText = includeHiddenText_
    .Range.TextRetrievalMode.IncludeFieldCodes = includeFieldCodes_
    .Application.Options.DeletedTextMark = deletedTextMark_
    .Range.NoProofing = noProofing_
    
    .Application.ScreenUpdating = True
    Call .Application.ScreenRefresh
  End With
End Function

Public Function SaveAndShowDiff()
  Dim oldName$: oldName = document_.FullName
  Dim newName$: newName = oldName
  newName = VBA.Left(newName, VBA.Len(newName) - VBA.Len(".docx"))
  newName = newName & "_" & VBA.Format(VBA.Now(), "MMddhhmm") & ".docx"
  Call document_.SaveAs(newName)
  
  Dim iWrap As New API_WordWrapper: Call iWrap.OpenDocument(oldName)
  Call document_.Application.CompareDocuments(iWrap.Document, document_, _
        Destination:=wdCompareDestinationNew, _
        CompareFields:=False, _
        RevisedAuthor:=AUTOMATON_USER_NAME)
End Function

Public Function BookmarkIgnored(target As Word.Range) As String
  Dim nIndex&: nIndex = document_.Bookmarks.Count + 1
  Dim sBookmark$: sBookmark = IGNORE_BM_PREFIX & nIndex
  Do While document_.Bookmarks.Exists(sBookmark)
    nIndex = nIndex - 1
    sBookmark = IGNORE_BM_PREFIX & nIndex
  Loop
  
  BookmarkIgnored = sBookmark
  If target.Bookmarks.Add(sBookmark, target) Is Nothing Then _
    Call Err.Raise(vbObjectError)
End Function

' ==============
Private Function HideIgnored()
' Ñêðûâàåì èãíîðèðóåìûå ÷àñòè òåêñòà
  Dim trackRev As Boolean: trackRev = document_.TrackRevisions
  document_.TrackRevisions = False

  Dim aBookmark As Word.Bookmark
  For Each aBookmark In document_.Bookmarks
    If IsBookmarkIgnored(aBookmark.Name) Then _
      aBookmark.Range.Font.Hidden = True
  Next aBookmark
  
  document_.TrackRevisions = trackRev
End Function

Private Function UnHideIgnored()
' Îòîáðàæàåì èãíîðèðóåìûå ÷àñòè òåêñòà
  Dim trackRev As Boolean: trackRev = document_.TrackRevisions
  document_.TrackRevisions = False
  
  Dim aBookmark As Word.Bookmark
  For Each aBookmark In document_.Bookmarks
    If IsBookmarkIgnored(aBookmark.Name) Then _
      aBookmark.Range.Font.Hidden = False
  Next aBookmark
  
  document_.TrackRevisions = trackRev
End Function

Private Function IsBookmarkIgnored(sBookmark$) As Boolean
  IsBookmarkIgnored = sBookmark Like IGNORE_BM_PREFIX & "*"
End Function

Private Function ClearExistingFormat()
' Î÷èùàåì ôîðìàòèðîâàíèå â äîêóìåíòå
  Dim trackRev As Boolean: trackRev = document_.TrackRevisions
  document_.TrackRevisions = False
  
  ' Î÷èùàåì âûäåëåíèå öâåòîì ññûëîê íà òåðìèíû
  Dim rFind As Word.Range: Set rFind = document_.Range
  Dim nStart&: nStart = -1
  With rFind.Find
    .Forward = True
    .Font.Hidden = False
    .Highlight = True
    .Format = True
    .MatchPhrase = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
  End With
  
  Do While rFind.Find.Execute
    If rFind.HighlightColorIndex = ERROR_HIGHLIGHT_COLOR Then
      rFind.HighlightColorIndex = wdNoHighlight
    End If
    
    Call rFind.Collapse(wdCollapseEnd)
    
    If nStart = rFind.Start Then  ' Ãàðàíòèðóåì, ÷òî íå çàöèêëèìñÿ
      Debug.Print "Î÷èñòêà òåêñòà çàöèêëèëàñü"
      Exit Do
    Else
      nStart = rFind.Start
    End If
  Loop
  
  Dim i&: i = 1
  Do While True
    If i > document_.Comments.Count Then _
      Exit Do
    
    If VBA.Left(document_.Comments(i).Range.Text, 2) = AUTO_COMMENT_PREFIX Then
      document_.Comments(i).Delete
    Else
      i = i + 1
    End If
  Loop
  
  document_.TrackRevisions = trackRev
End Function