248 lines
7.3 KiB
QBasic
248 lines
7.3 KiB
QBasic
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 = "[èçîáðàæåíèå óäàëåíî]"
|
|
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("Ïðåîáðàçîâàíèå ãèïåðññûëîê", sHeader:="Îáðàáîòêà...", _
|
|
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
|
|
|
|
' Äëÿ ñëó÷àåâ, êîãäà òåêñò â òàáëèöå
|
|
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
|
|
'Ñîñòîÿíèå ññûëîê (ñ ïîäìåíîé ñòðîêîâîé ïåðåìåííîé)
|
|
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
|