WordAI/src/MainImpl.bas

Attribute VB_Name = "MainImpl"
Option Explicit

Public Function RemoveImages(target As Word.Range) As Long
  Dim iShp As Word.InlineShape
  Dim nDeleted&: nDeleted = target.InlineShapes.Count
  Do While target.InlineShapes.Count > 0
    Set iShp = target.InlineShapes.Item(1)
    Dim pasteRange As Word.Range: Set pasteRange = iShp.Range.Duplicate
    Call pasteRange.Collapse(wdCollapseStart)
    Call iShp.Delete
    pasteRange.Text = "[<5B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>]"
    pasteRange.Font.Bold = True
  Loop
  RemoveImages = nDeleted
End Function

Public Function RecreateBookmarks(target As Word.Document) As Scripting.Dictionary
  Dim contextMap As New Scripting.Dictionary
  Dim pref$: pref = "t" & VBA.Format(Date, "yyyymmdd") & VBA.Replace(VBA.Time, ":", "")
  Dim nBookmark&
  For nBookmark = target.Bookmarks.Count To 1 Step -1 ' Note: reverse order for recreation
    Dim aMark As Word.Bookmark: Set aMark = target.Bookmarks(nBookmark)
    Dim bmRange As Word.Range: Set bmRange = aMark.Range
    Dim sNewName$: sNewName = pref & "_" & aMark.Name
    If VBA.Len(sNewName) > 40 Then _
      GoTo NEXT_BM
    
    Call contextMap.Add(aMark.Name, sNewName)
    Call bmRange.Bookmarks.Add(pref & "_" & aMark.Name)
    Call aMark.Delete
NEXT_BM:
  Next nBookmark
  
  Set RecreateBookmarks = contextMap
End Function

Public Function FixHyperlinksAfterBMReplace(target As Word.Document, iContext As Scripting.Dictionary)
  Dim newAddr$
  Dim nLink&
  For nLink = target.Hyperlinks.Count To 1 Step -1
    Dim aLink As Word.Hyperlink: Set aLink = target.Hyperlinks(nLink)
    Dim linkRange As Word.Range: Set linkRange = target.Range(aLink.Range.Start, aLink.Range.End)
    Dim sSub$: sSub = aLink.SubAddress
    If Not aLink.Address = vbNullString Or sSub = vbNullString Then _
      GoTo NEXT_LINK
    If Not iContext.Exists(sSub) Then _
      GoTo NEXT_LINK
    
    newAddr = iContext(sSub)
    Call aLink.Delete
    Call linkRange.Hyperlinks.Add(linkRange, "", newAddr)
 
NEXT_LINK:
  Next nLink
End Function

Public Function FixHyperlinksIn(target As Word.Range) As LMU_LinksInfo
  FixHyperlinksIn.lnkCount_ = target.Hyperlinks.Count

  Call CSE_ProgressBar.Init("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>", sHeader:="<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>...", _
                              maxVal:=FixHyperlinksIn.lnkCount_)
  Call CSE_ProgressBar.ShowModeless
  
  FixHyperlinksIn.modCount_ = 0
  FixHyperlinksIn.errCount_ = 0
  
  Dim aLink As Hyperlink
  For Each aLink In target.Hyperlinks
    Dim linkAdr$: linkAdr = GetFullPath(SafeGetHLinkAddress(aLink), target.Document.Path)
    If linkAdr = vbNullString Then _
      GoTo NEXT_LINK
    
    Select Case LinkCheckResult(linkAdr)
    Case RV_LINK_FIXED:
      FixHyperlinksIn.modCount_ = FixHyperlinksIn.modCount_ + 1
      Dim linkRange As Word.Range: Set linkRange = aLink.Range
      If linkRange.Font.ColorIndex = wdRed Then _
        linkRange.Font.ColorIndex = wdAuto
      If linkRange.HighlightColorIndex = wdTurquoise Then _
        linkRange.HighlightColorIndex = wdAuto
      
      If IsSamePath(linkRange.Text, SafeGetHLinkAddress(aLink), target.Document.Path) Then
        If Left(linkRange.Text, 2) = "\\" Then
          linkRange.Text = ConvertLinkToLocal(linkAdr)
        Else
          linkRange.Text = ConvertLinkToURL(linkAdr)
        End If
      End If
      
      linkRange.Text = linkRange.Text
      Call ActiveDocument.Hyperlinks.Add(linkRange, linkAdr)
    
    Case RV_LINK_NOFIX:
      FixHyperlinksIn.errCount_ = FixHyperlinksIn.errCount_ + 1
      If aLink.Range.HighlightColorIndex <> wdTurquoise Then
        aLink.Range.HighlightColorIndex = wdTurquoise
      End If
    End Select
    
NEXT_LINK:
    Call CSE_ProgressBar.IncrementA
  Next aLink
  
  Call Unload(CSE_ProgressBar)
End Function

Public Function TryFixingParagraph(ByRef target As Word.Range)
  Dim nLine&: nLine = target.ComputeStatistics(wdStatisticLines)
  Dim newLine&
  Dim oldSpace As Double: oldSpace = target.Font.Spacing
  Dim dSpace As Double: dSpace = oldSpace

  Do While dSpace >= -PAR_SCALE_MAX
    On Error GoTo ERR_H
    target.Font.Spacing = dSpace
    GoTo ERR_NEXT
ERR_H:
    oldSpace = 0
    dSpace = 0
    target.Font.Spacing = dSpace
ERR_NEXT:

    newLine = target.ComputeStatistics(wdStatisticLines)
    If newLine < nLine Then _
      Exit Function
    
    dSpace = dSpace - PAR_SCALE_STEP
  Loop
  
  target.Font.Spacing = oldSpace
  
  Dim colWid As Double, finC As Double
  Dim finRng As Word.Range, curSel As Word.Range
  
  Set curSel = target.Application.Selection.Range.Duplicate
  
  Set finRng = target.Duplicate
  Call finRng.MoveEnd(wdCharacter, -1)
  Call finRng.Collapse(wdCollapseEnd)
  Call finRng.Select
  
  ' <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
  On Error GoTo RET_SEL
  colWid = target.PageSetup.TextColumns(1).Width
  On Error GoTo 0
  
  Do While dSpace <= PAR_SCALE_MAX
    On Error GoTo ERR_V
    target.Font.Spacing = dSpace
    GoTo ERR_NEW
ERR_V:
    oldSpace = 0
    dSpace = 0
    target.Font.Spacing = dSpace
ERR_NEW:

    newLine = target.ComputeStatistics(wdStatisticLines)
    If newLine < nLine Then _
      GoTo RET_SEL
    If newLine > nLine Then _
      Exit Do
    
    finC = target.Application.Selection.Information(wdHorizontalPositionRelativeToTextBoundary)
    If finC / colWid >= 0.5 Then _
      GoTo RET_SEL
    
    dSpace = dSpace + PAR_SCALE_STEP
  Loop
  
  target.Font.Spacing = oldSpace
  
RET_SEL:
  Call curSel.Select
End Function
 
Public Function LowerReference(execField As Word.Field)
  If execField.Type <> wdFieldRef Then _
    Exit Function
    
  With execField
    Dim codeStr$: codeStr = .Code
    Dim fSlash&: fSlash = InStr(codeStr, "\")
    fSlash = IIf(fSlash = 0, Len(codeStr), fSlash)
    codeStr = Left(codeStr, fSlash - 1) & "\* Lower \h }"
    
    .Code.Text = codeStr
    .Update
    
    .result.Italic = True
    .result.Bold = True
  End With
End Function

Public Function RemoveAccentsIn(target As Word.Range) As Long
  Dim nCount&: nCount = 0
  Dim aWord As Word.Range
  For Each aWord In target.Words
    Dim sInitial$: sInitial = aWord.Text
    Dim sFixed$: sFixed = VBA.Replace(sInitial, ChrW(769), "")
    If VBA.Len(sInitial) > VBA.Len(sFixed) Then
      nCount = nCount + VBA.Len(sInitial) - VBA.Len(sFixed)
      aWord = sFixed
    End If
  Next aWord
  RemoveAccentsIn = nCount
End Function

Public Function UpdateConceptPowershell() As Boolean
  UpdateConceptPowershell = False
  
  Dim fso As New Scripting.FileSystemObject
  Dim sInstall$: sInstall = CP_TOOLS_SERVER & "\" & CONCEPT_INSTALLER
  If Not fso.FileExists(sInstall) Then _
    Exit Function
  
  On Error GoTo RETURN_FALSE
  Dim sExec$: sExec = "explorer.exe " & CP_TOOLS_SERVER
  Dim iShell As New WshShell
  Call iShell.Run(sExec, waitOnReturn:=True)
  UpdateConceptPowershell = True
  Exit Function

RETURN_FALSE:
  On Error GoTo 0
End Function

' =============
Private Function LinkCheckResult(ByRef rawLnk$) As LMU_Return
'<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> (<28> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>)
  Dim rulemap As LinkMappingUnit: Set rulemap = GetLMU
  Dim sResult$: sResult = rawLnk
  LinkCheckResult = rulemap.FixLink(sResult)
  If LinkCheckResult = RV_LINK_FIXED Then _
    rawLnk = sResult
End Function

Private Function TryProcessAddin(sLocal$, sServer$) As Boolean
  TryProcessAddin = False
  
  Dim fso As New Scripting.FileSystemObject
  If Not fso.FileExists(sServer) Then _
    Exit Function
  
  Call fso.CopyFile(sServer, sLocal)
  TryProcessAddin = True
End Function