MasterText/src/MainImpl.bas

Attribute VB_Name = "MainImpl"
Option Private Module
Option Explicit

Public Function AccessRules() As DB_Rules
  Static s_Rules As DB_Rules
  If s_Rules Is Nothing Then
    Set s_Rules = New DB_Rules
    Call s_Rules.Init(ThisWorkbook.Worksheets(SHEET_RULES))
  End If
  
  Set AccessRules = s_Rules
End Function

Public Function AccessProcessor() As RulesProcessor
  Static s_Processor As RulesProcessor
  If s_Processor Is Nothing Then _
    Set s_Processor = New RulesProcessor
  Set AccessProcessor = s_Processor
End Function

Public Function LoadBannedWords() As Collection
  Dim result As New Collection
  Dim sLocal$: sLocal = VBA.Environ$("USERPROFILE") & "\" & CONCEPT_LOCAL_HOME & CONCEPT_BANNED_WORDS
  Dim fso As New Scripting.FileSystemObject
  If Not fso.FileExists(sLocal) Then
    If Not TryUpdateBannedWords() Then
      Call UserInteraction.ShowMessage(EM_MISSING_FILE, sLocal)
      GoTo RETURN_EMPTY
    End If
  End If

  Dim adoStream As New ADODB.Stream
  adoStream.Charset = "utf-8"
  Call adoStream.Open
  Call adoStream.LoadFromFile(sLocal)
  Dim sLines() As String: sLines = Split(adoStream.ReadText, vbCrLf)
  Call adoStream.Close
  
  Dim nLine&
  For nLine = LBound(sLines, 1) To UBound(sLines, 1) Step 1
    Dim sText$: sText = sLines(nLine)
    If sText <> vbNullString Then _
      Call result.Add(sText)
  Next nLine
  
RETURN_EMPTY:
  Set LoadBannedWords = result
End Function

Public Function TryUpdateBannedWords() As Boolean
  Dim sServer$: sServer = CONCEPT_SERVER_HOME & CONCEPT_BANNED_WORDS
  Dim sLocal$: sLocal = VBA.Environ$("USERPROFILE") & "\" & CONCEPT_LOCAL_HOME & CONCEPT_BANNED_WORDS
  TryUpdateBannedWords = CopyFileOrFolder(sSource:=sServer, sDestination:=sLocal)
End Function

Public Function OpenTargetDocument() As API_WordWrapper
  Dim sFileName$: sFileName = AccessUI.TargetPath
  If sFileName = "" Then
    Call UserInteraction.ShowMessage(EM_PATH_EMPTY)
    Exit Function
  End If

  Dim iWrapper As New API_WordWrapper
  If Not iWrapper.OpenDocument(sFileName) Is Nothing Then _
    Set OpenTargetDocument = iWrapper
End Function

Public Function ActivateCurrentDocument()
  Dim appWord As API_WordWrapper: Set appWord = OpenTargetDocument
  If appWord Is Nothing Then _
    Exit Function
  Call appWord.Document.ActiveWindow.Activate
End Function

Public Function RunRule(iProcessor As RulesProcessor, iRule As IteratorRule, bApplyFix As Boolean, Optional DoDebug As Boolean = False) As Double
  Dim aTimer As New API_Timer: Call aTimer.Start
  
  If Not DoDebug Then _
    On Error GoTo SHOW_FAILURE
  Call iProcessor.RunRule(iRule.RuleID, bApplyFix)
  If Not DoDebug Then _
    On Error GoTo 0
  GoTo LOG_RESULT

SHOW_FAILURE:
  Call UserInteraction.ShowMessage(EM_RULE_FAILED, iRule.RuleID)
  
LOG_RESULT:
  iRule.TimeSpent = aTimer.TimeElapsed
  iRule.ErrorsCount = iProcessor.errors_
  iRule.FixesCount = iProcessor.fixes_
  RunRule = iRule.TimeSpent
End Function

Public Function ProcessStyles(target As Word.Document, templateDoc As Word.Document)
  Dim nCount&: nCount = target.Styles.Count
  Dim nRenamed&: nRenamed = 0
  Dim nRemoved&: nRemoved = 0
  Dim aStyle As Word.Style
  For Each aStyle In target.Styles
    Dim sName$: sName = aStyle.NameLocal
    If sName = "" Then
      GoTo NEXT_STYLE
    ElseIf aStyle.BuiltIn Then
      nCount = nCount - 1
      GoTo NEXT_STYLE
    ElseIf WordStyleExists(templateDoc, sName) Then
      GoTo NEXT_STYLE
    ElseIf AccessUI.StylesDeleteUnused And Not WordStyleIsUsed(target, aStyle) Then
      Call aStyle.Delete
      nRemoved = nRemoved + 1
      GoTo NEXT_STYLE
    End If
    
    If AccessUI.StylesRename And Not sName Like STYLE_ERROR_PREFIX & "*" Then
      sName = STYLE_ERROR_PREFIX & sName
      aStyle.NameLocal = sName
      aStyle.Priority = 1
      nRenamed = nRenamed + 1
    End If
    If AccessUI.StylesFormat Then
      aStyle.Font.ColorIndex = STYLE_ERROR_COLOR
    End If

NEXT_STYLE:
    Call CSE_ProgressBar.IncrementA
  Next aStyle
  
  Call AccessUI.LogStylesData(nCount, nRenamed, nRemoved)
End Function

Public Function ChangeCharset(sFile$, chSetInput$, chSetOutput$)
  Dim adoStream  As New ADODB.Stream
  With adoStream
    .Charset = chSetInput
    Call .Open
    Call .LoadFromFile(sFile)
    .Position = 0
  End With
  
  Dim adoStreamOut As New ADODB.Stream
  With adoStreamOut
    .Charset = chSetOutput
    Call .Open
    Call .WriteText(adoStream.ReadText)
    Call .SaveToFile(sFile, adSaveCreateOverWrite)
    Call .Close
  End With

  Call adoStream.Close
  Set adoStream = Nothing
  Set adoStreamOut = Nothing
End Function

Public Function SelectVisibleText(target As Word.Document)
' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
  Call target.DeleteAllEditableRanges(wdEditorEveryone)
  
  Dim rFind As Word.Range:  Set rFind = target.Range
  Dim nStart&:  nStart = -1
  With rFind.Find
    .Font.Hidden = False
    .Format = True
    .Text = "<*^0013"
    .MatchWildcards = True
    Do While .Execute
      Call rFind.Editors.Add(wdEditorEveryone)
      
      If CSE_ProgressBar.Visible Then _
        Call CSE_ProgressBar.SetA(rFind.End)

      If nStart = rFind.Start Then  ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
        Debug.Print "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>"
        Exit Do
      Else
        nStart = rFind.Start
      End If
      
      Call rFind.Collapse(wdCollapseEnd)
    Loop
  End With
  
  Call target.SelectAllEditableRanges(wdEditorEveryone)
  Call target.DeleteAllEditableRanges(wdEditorEveryone)
End Function