commit 04b897656c69666349a5c336e1bd7d15acbd480d Author: IRBorisov <8611739+IRBorisov@users.noreply.github.com> Date: Fri Jun 7 20:48:48 2024 +0300 Initial commit diff --git a/VBAMake.txt b/VBAMake.txt new file mode 100644 index 0000000..333bde6 --- /dev/null +++ b/VBAMake.txt @@ -0,0 +1,41 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact_home, source_home + +id = WordHelper +name = WordHelper +description = Надстройка КОНЦЕПТ для Word +artifact_home = Addins +source_home = WordAI +install_home = \\fs1.concept.ru\projects\04 Направления деятельности\60 КИВТ\21 Надстройки\WORD + +%% +# === Build section === +# Available commands: +# build LOCAL_MANIFEST +# copy LOCAL_SOURCE -> [LOCAL_ARTIFACT] +# save_as LOCAL_ARTIFACT -> LOCAL_ARTIFACT +# run LOCAL_SOURCE.bat + +build script\manifest.txt +copy distr\Word.docx +copy distr\banned-words.txt + +%% +# === Install section == +# Available commands: +# install LOCAL_ARTIFACT -> [INSTALL_PATH] +# add_template LOCAL_ARTIFACT -> [LOCAL_TEMPLATE] +# run LOCAL_ARTIFACT.bat <- [PARAMETERS] +# run APPLICATION <- [PARAMETERS] + +install CONCEPT.dotm +install CONCEPT.dotm -> \\fs1.concept.ru\Exchange\ConceptDistr\data\Add-ins\Word\CONCEPT.dotm + +install Word.docx +install Word.docx -> \\fs1.concept.ru\projects\10 Автоматизация деятельности\02 Офисная автоматизация\!Надстройки\Word.docx + +install banned-words.txt +install banned-words.txt -> \\fs1.concept.ru\Exchange\ConceptDistr\models\banned-words.txt +install banned-words.txt -> \\fs1.concept.ru\projects\10 Автоматизация деятельности\!Concept\models\banned-words.txt \ No newline at end of file diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..0495c4a --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +1.2.3 diff --git a/distr/Word.docx b/distr/Word.docx new file mode 100644 index 0000000..282ce86 Binary files /dev/null and b/distr/Word.docx differ diff --git a/distr/banned-words.txt b/distr/banned-words.txt new file mode 100644 index 0000000..9b07355 --- /dev/null +++ b/distr/banned-words.txt @@ -0,0 +1,125 @@ +никогда +нигде +эффективность +эффективности +эффективностью +минимальный +минимального +минимальная +минимальной +минимальному +минимальным +минимальные +минимальными +минимальному +максимальный +максимальная +максимальные +максимальным +максимальному +максимальной +максимальными +минимизация +минимизации +минимизацией +глобальный +глобальная +глобальные +глобальным +глобальной +глобальными +глобальному +беспрецедентный +беспрецедентная +беспрецедентные +беспрецедентным +беспрецедентному +беспрецедентными +беспрецедентной +предельный +предельная +предельные +предельным +предельному +предельной +предельными +уникальный +уникальная +уникальные +уникальным +уникальными +уникальному +уникальной +реальный +реальная +реальные +реальным +реальными +реальному +реальной +всегда +подавляющий +подавляющего +подавляющим +подавляющему +подавляющем +подавляющая +подавляющей +подавляющие +подавляющим +подавляющих +было +был +была +были +эффективный +эффективная +эффективное +эффективные +эффективным +эффективной +эффективными +эффективных +эффективному +эффективном +неэффективный +неэффективная +неэффективное +неэффективные +неэффективным +неэффективной +неэффективными +неэффективных +неэффективному +неэффективном +минимально +максимально +эффективно +недавно +существует +существуют +существовать +текущий +текущая +текущие +текущему +текущей +текущим +текущими +текущих +постоянно +очевидно +просто +сразу +любой бред +любого бреда +любому бреду +любым бредом +любом бреде +какой-то +какая-то +какие-то +какому-то +какой-то +каким-то +какими-то \ No newline at end of file diff --git a/script/manifest.txt b/script/manifest.txt new file mode 100644 index 0000000..6af5e96 --- /dev/null +++ b/script/manifest.txt @@ -0,0 +1,87 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = CONCEPT.dotm +artifact = CONCEPT.dotm + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + +dev + DevTester.bas + +api + ex_WinAPI.bas + API_WordWrapper.cls + API_XLWrapper.cls + API_UserInteraction.cls + +word + ex_Word.bas + API_WordEditGuard.cls + +utility + ex_VBA.bas + ex_Version.bas + + API_DistrManifest.cls + API_Config.cls + API_JSON.cls + +ui + CSE_ProgressBar.frm + +%% +# === Source Code Section == +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SourceHome path + +src + DevHelper.bas + Declarations.bas + Main.bas + MainImpl.bas + z_UIMessages.bas + z_UIRibbon.bas + + RulesAccess.bas + DocumentEditor.cls + RulesProcessor.cls + BracketItem.cls + + LMUFunctions.bas + LinkFunctions.bas + LinkMappingUnit.cls + LMUItem.cls + + s_RulesProcessor.cls + +%% +# ===== UI Section ======= +# Pairs of path to UI elements, use " -> " delimiter +# First component is a path relative to SourceHome\ui folders +# Second component is internal path inside project file + +.rels -> _rels\.rels +customUI.xml -> customUI\customUI.xml +customizations.xml -> word\customizations.xml + +%% +# === References Section === +# List dependencies in one of the formats +# global : GLOBAL_NAME +# guid : {REGISTERED_GUID} +# file : PATH_TO_LIBRARY + +global : Shell32 +global : Scripting +global : Excel +global : MSForms +global : ADODB +global : IWshRuntimeLibrary \ No newline at end of file diff --git a/skeleton/CONCEPT.dotm b/skeleton/CONCEPT.dotm new file mode 100644 index 0000000..2b97637 Binary files /dev/null and b/skeleton/CONCEPT.dotm differ diff --git a/src/BracketItem.cls b/src/BracketItem.cls new file mode 100644 index 0000000..064b073 --- /dev/null +++ b/src/BracketItem.cls @@ -0,0 +1,14 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "BracketItem" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ====== ===== + +Public brType As BracketType ' : , , +Public brRange As Word.Range ' +Public brMark As Boolean ' diff --git a/src/Declarations.bas b/src/Declarations.bas new file mode 100644 index 0000000..4c41b3c --- /dev/null +++ b/src/Declarations.bas @@ -0,0 +1,36 @@ +Attribute VB_Name = "Declarations" +Option Explicit + +Public Const CONCEPT_SERVER_HOME = "\\fs1.concept.ru\projects\10 \!Concept\" +Public Const CONCEPT_LOCAL_HOME = ".concept\" +Public Const CONCEPT_BANNED_WORDS = "banned-words.txt" +Public Const CONCEPT_MASTER_CONFIG = "master-config.json" + +Public Const SERVER_PATH_HELP = "\\fs1.concept.ru\projects\10 \02 \!\Word.docx" +Public Const SERVER_MASTER_TEXT = "\\fs1.concept.ru\projects\10 \01 \-04 \ .xlsm" + +Public Const SERVER_ADDIN_EXCEL = "\\fs1.concept.ru\Data\Add-ins\Excel" + +Public Const ADDIN_NAME_CONCEPT = "CONCEPT.xlam" +Public Const ADDIN_NAME_REPORT = "ConceptReport.xlam" + +Public Const CELL_MASTER_PATH = "c_DocPath" + +Public Const PAR_SCALE_MAX = 0.25 +Public Const PAR_SCALE_STEP = 0.1 + +Public Enum BracketType + BT_PAP = 0 + BT_SQU = 1 + BT_FIG = 2 +End Enum + +Public Function GetBracketType(sChr$) As BracketType +' ----- ---------- + Dim rndB$: rndB = "[\(\)]" + 'Dim sqrB$: sqrB = "[" & "]" + Dim figB$: figB = "[\{\}]" + GetBracketType = BT_SQU + If sChr Like rndB Then GetBracketType = BT_PAP + If sChr Like figB Then GetBracketType = BT_FIG +End Function diff --git a/src/DevHelper.bas b/src/DevHelper.bas new file mode 100644 index 0000000..937379e --- /dev/null +++ b/src/DevHelper.bas @@ -0,0 +1,20 @@ +Attribute VB_Name = "DevHelper" +Option Explicit + +Public Function Dev_PrepareSkeleton() + ThisDocument.Range.Text = vbNullString +End Function + +Public Sub ADev_ManualRunTest() + Dim sSuite$: sSuite = "s_RulesProcessor" + Dim sTest$: sTest = "t_Quotes" + Dim sMsg$: sMsg = Dev_RunTestDebug(sSuite, sTest) + Debug.Print sMsg + Call MsgBox(sMsg) +End Sub + +Public Function Dev_GetTestSuite(sName$) As Object + Select Case sName + Case "s_RulesProcessor": Set Dev_GetTestSuite = New s_RulesProcessor + End Select +End Function diff --git a/src/DocumentEditor.cls b/src/DocumentEditor.cls new file mode 100644 index 0000000..218a29d --- /dev/null +++ b/src/DocumentEditor.cls @@ -0,0 +1,221 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DocumentEditor" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private Const ERROR_HIGHLIGHT_COLOR = wdViolet +Private Const COMMENT_PREFIX_BM = "zCOMMENT_TMP_" + +Private document_ As Word.Document +Private highlightErrors_ As Boolean +Private commentUnresolved_ As Boolean + +Private comments_ As Scripting.Dictionary + +Public Function Init(target As Word.Document, iConfig As API_Config) + Set document_ = target + Set comments_ = New Scripting.Dictionary + highlightErrors_ = iConfig.GetValue("HighlightErrors", False) + commentUnresolved_ = iConfig.GetValue("CommentUnresolved", True) +End Function + +Public Property Get Document() As Word.Document + Set Document = document_ +End Property + +Public Function MarkError(target As Word.Range, sComment$) +' + If highlightErrors_ Then _ + Call FormatRange(target) + If commentUnresolved_ Then _ + Call AddCommentToRange(target, sComment) +End Function + +Public Function FormatRange(target As Word.Range) +' + Dim tmpRevision As Boolean: tmpRevision = document_.TrackRevisions + document_.TrackRevisions = False + target.HighlightColorIndex = ERROR_HIGHLIGHT_COLOR + document_.TrackRevisions = tmpRevision +End Function + +Public Function AddBookmark(target As Word.Range, sPrefix$) As String + Dim nIndex&: nIndex = document_.Bookmarks.Count + 1 + Dim sBookmark$: sBookmark = sPrefix & nIndex + Do While document_.Bookmarks.Exists(sBookmark) + nIndex = nIndex - 1 + sBookmark = sPrefix & nIndex + Loop + + AddBookmark = sBookmark + If target.Bookmarks.Add(sBookmark, target) Is Nothing Then _ + Call Err.Raise(vbObjectError) +End Function + +Public Function AddCommentToRange(target As Word.Range, sComment$) +' (, ) + Dim sBookmark$: sBookmark = AddBookmark(target, COMMENT_PREFIX_BM) + If sBookmark = vbNullString Then _ + Exit Function + Call comments_.Add(sBookmark, sComment) +End Function + +Public Function AddGlobalComment(sComment$) +' + Dim iRange As Word.Range: Set iRange = document_.Paragraphs(1).Range + If iRange.Comments.Count = 0 Then _ + Call iRange.Comments.Add(iRange) + + Dim theBM As Word.Comment: Set theBM = iRange.Comments(1) + If theBM.Range.Text = vbNullString Then + theBM.Range.Text = sComment + Else + theBM.Range.Text = theBM.Range.Text & vbNewLine & sComment + End If +End Function + +Public Function SetupFindLiteral(sSearch$) As Word.Range + Dim rFind As Word.Range: Set rFind = document_.Range + rFind.Find.ClearFormatting + With rFind.Find + .Text = sSearch + .Format = True + .Font.Hidden = False + .MatchWildcards = False + .Forward = True + End With + Set SetupFindLiteral = rFind +End Function + +Public Function SetupFindWildcard(sSearch$) As Word.Range + Dim rFind As Word.Range: Set rFind = document_.Range + rFind.Find.ClearFormatting + With rFind.Find + .Text = sSearch + .Format = True + .Font.Hidden = False + .MatchWildcards = True + .Forward = True + End With + Set SetupFindWildcard = rFind +End Function + +Public Function ReplaceText(sFind$, sReplacement$, bApplyFix As Boolean, Optional sComment$ = vbNullString) As Long + ReplaceText = FindAndReplace(sFind, sReplacement, bApplyFix, sComment, _ + bCase:=False, bWildcard:=False, bWhole:=True) +End Function + +Public Function ReplaceWC(sFind$, sReplacement$, bApplyFix As Boolean, Optional sComment$ = vbNullString) As Long + ReplaceWC = FindAndReplace(sFind, sReplacement, bApplyFix, sComment, _ + bCase:=False, bWildcard:=True, bWhole:=False) +End Function + +Public Function FindAndReplace(sFind$, sReplacement$, _ + bApplyFix As Boolean, Optional sComment$ = vbNullString, _ + Optional bCase As Boolean = False, _ + Optional bWildcard As Boolean = False, _ + Optional bWhole As Boolean = True) As Long +' + Dim result&: result = 0 + Dim rFind As Word.Range: Set rFind = document_.Range + With rFind.Find + .Text = sFind + .Replacement.Text = IIf(bApplyFix, sReplacement, "") + .Format = True + .Font.Hidden = False + .MatchCase = bCase + .MatchWholeWord = bWhole + .MatchWildcards = bWildcard + .Forward = True + End With + + Do While rFind.Find.Execute(Replace:=1 * bApplyFix) + result = result + 1 + If Not bApplyFix Then _ + Call MarkError(rFind, sComment) + Call rFind.Collapse(wdCollapseEnd) + Loop + + FindAndReplace = result +End Function + +Public Function ReplaceCascade(sFind$, _ + findText2$, repText2$, bApplyFix As Boolean, _ + Optional sComment$ = vbNullString, _ + Optional bCase As Boolean = False, _ + Optional bWildcard As Boolean = False, _ + Optional bWhole As Boolean = False) As Long +' bWildcard +' , "\1" + Dim result&: result = 0 + If repText2 = vbNullString And bApplyFix Then + ReplaceCascade = result + Debug.Print " : " + Exit Function + End If + + Dim rFind As Word.Range: Set rFind = document_.Range + With rFind.Find + .Text = sFind + .MatchWildcards = True + .Forward = True + .Format = True + .Font.Hidden = False + + Do While .Execute + .Text = findText2 + .Replacement.Text = repText2 + .MatchCase = bCase + .MatchWholeWord = bWhole + .MatchWildcards = bWildcard + + If .Execute(Replace:=1 * bApplyFix) Then + result = result + 1 + If Not bApplyFix Then _ + Call MarkError(rFind, sComment) + End If + + .Text = sFind + .Replacement.Text = vbNullString + .MatchCase = False + .MatchWholeWord = False + .MatchWildcards = True + + Call rFind.Collapse(wdCollapseEnd) + Loop + End With + + ReplaceCascade = result +End Function + +Public Function FinalizeComments() +' ( ) + On Error Resume Next + If document_.Bookmarks.Count = 0 Then _ + Exit Function + + If CSE_ProgressBar.Visible Then _ + Call CSE_ProgressBar.Init("", sHeader:=" ...", minVal:=0, curVal:=1, maxVal:=comments_.Count) + + Dim target As Word.Range + Dim vBookmark As Variant + For Each vBookmark In comments_.Keys() + If Not document_.Bookmarks.Exists(CStr(vBookmark)) Then _ + GoTo NEXT_ITEM + Set target = document_.Bookmarks(vBookmark).Range + Call document_.Bookmarks(vBookmark).Delete + Call target.Comments.Add(target, comments_(vBookmark)) +NEXT_ITEM: + If CSE_ProgressBar.Visible Then _ + Call CSE_ProgressBar.IncrementA + Next + + Set comments_ = New Scripting.Dictionary +End Function + diff --git a/src/LMUFunctions.bas b/src/LMUFunctions.bas new file mode 100644 index 0000000..40bca6e --- /dev/null +++ b/src/LMUFunctions.bas @@ -0,0 +1,26 @@ +Attribute VB_Name = "LMUFunctions" +'===== ===== +Option Explicit +Option Private Module + +Public Type LMU_LinksInfo + lnkCount_ As Long + errCount_ As Long + modCount_ As Long +End Type + +Public Enum LMU_Return + RV_LINK_OK + RV_LINK_FIXED + RV_LINK_NOFIX + RV_NOTAFSO +End Enum + +Public Function GetLMU() As LinkMappingUnit + Static result As LinkMappingUnit ' + If result Is Nothing Then + ' + Set result = New LinkMappingUnit + End If + Set GetLMU = result +End Function diff --git a/src/LMUItem.cls b/src/LMUItem.cls new file mode 100644 index 0000000..36afba6 --- /dev/null +++ b/src/LMUItem.cls @@ -0,0 +1,20 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "LMUItem" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== ======= +Public repWhat As String +Public repList As Collection +Private i As Integer + +'---------- Event handlers and misc code ---------- +Private Sub Class_Initialize() +' Initializing the object + Set repList = New Collection + repWhat = vbNullString +End Sub diff --git a/src/LinkFunctions.bas b/src/LinkFunctions.bas new file mode 100644 index 0000000..de2bea7 --- /dev/null +++ b/src/LinkFunctions.bas @@ -0,0 +1,60 @@ +Attribute VB_Name = "LinkFunctions" +'============== =============== +Option Explicit +Option Private Module + +Public Function GetFullPath(ByVal addr$, docpath$) As String +' + If Left(addr, 1) = "." Or InStr(addr, "\") + InStr(addr, "/") = 0 Then + If Not docpath = vbNullString Then + addr = docpath & "\" & addr + Else + GetFullPath = addr + Exit Function + End If + End If + + Dim leftSide$ + Do While InStr(addr, "../") <> 0 + leftSide = Left(addr, InStr(addr, "../") - 1) + leftSide = Left(leftSide, InStrRev(leftSide, "\", Len(leftSide) - 1)) + addr = leftSide & Right(addr, Len(addr) - InStr(addr, "../") - 2) + Loop + + GetFullPath = Replace(addr, "/", "\") +End Function + +Public Function ConvertLinkToLocal(ByVal addr$) As String +' P:\ \\STRG1\... + ConvertLinkToLocal = addr + If Left(addr, 3) Like "P:\" Then _ + ConvertLinkToLocal = "\\STRG1\Projects\" & Right(addr, Len(addr) - 3) + If Left(addr, 3) Like "X:\" Then _ + ConvertLinkToLocal = "\\Server\Exchange\" & Right(addr, Len(addr) - 3) +End Function + +Public Function ConvertLinkToURL(ByVal addr$) As String +' \\STRG1\... P:\ \\server\... X:\ + ConvertLinkToURL = addr + If Left(addr, 17) Like "\\[Ss][Tt][Rr][Gg]1\[Pp]rojects\" Then _ + ConvertLinkToURL = "P:\" & Right(addr, Len(addr) - 17) + If Left(addr, 18) Like "\\[Ss][Ee][Rr][Vv][Ee][Rr]\[Ee]xchange\" Then _ + ConvertLinkToURL = "X:\" & Right(addr, Len(addr) - 18) +End Function + +Public Function SafeGetHLinkAddress(hLink As Hyperlink) As String +' . 4198 + On Error GoTo PICK_RANGE + SafeGetHLinkAddress = hLink.Address + + Exit Function +PICK_RANGE: + SafeGetHLinkAddress = hLink.Range.Text +End Function + +Public Function IsSamePath(ByVal hLinkText$, ByVal hLinkAddress$, docpath$) As Boolean + IsSamePath = False + hLinkText = UCase(ConvertLinkToURL(GetFullPath(hLinkText, docpath))) + hLinkAddress = UCase(ConvertLinkToURL(GetFullPath(hLinkAddress, docpath))) + If InStr(hLinkText, hLinkAddress) = 1 And Abs(Len(hLinkText) - Len(hLinkAddress)) <= 1 Then IsSamePath = True +End Function diff --git a/src/LinkMappingUnit.cls b/src/LinkMappingUnit.cls new file mode 100644 index 0000000..762ab2a --- /dev/null +++ b/src/LinkMappingUnit.cls @@ -0,0 +1,128 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "LinkMappingUnit" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' +Option Explicit + +Private m_ReplaceMap As Collection + +'---------- Public Interface ---------- +Public Function FixLink(ByRef adr$) As LMU_Return +' + Dim testAdr$ + If Not IsFSO(adr, "") Then + FixLink = RV_NOTAFSO + Exit Function + End If + + If IsValidAddress(adr) Then + testAdr = ConvertLinkToURL(adr) + If CheckFile(testAdr, testAdr) Then + FixLink = RV_LINK_OK + Exit Function + End If + End If + + testAdr = SwapStrgServer(adr) + If CheckFile(testAdr, testAdr) Then + FixLink = RV_LINK_FIXED + adr = ConvertLinkToLocal(testAdr) + Exit Function + End If + + Dim j&, k& + Dim rule As LMUItem + Dim result$ + For j = 1 To m_ReplaceMap.Count + Set rule = m_ReplaceMap.Item(j) + If InStr(adr, rule.repWhat) = 0 Then _ + GoTo NEXT_RULE + + For k = 1 To rule.repList.Count + result = Replace(testAdr, rule.repWhat, rule.repList(k)) + If CheckFile(result, "") Then + adr = ConvertLinkToLocal(result) + FixLink = RV_LINK_FIXED + Exit Function + End If + Next k +NEXT_RULE: + Next j + + FixLink = RV_LINK_NOFIX +End Function + +'---------- Event handlers and misc code ---------- +Private Sub Class_Initialize() + Set m_ReplaceMap = New Collection + Dim rule As LMUItem + Set rule = New LMUItem + rule.repWhat = "01 Income-" + rule.repList.Add ("00 \01 ") + Call m_ReplaceMap.Add(rule) + + Set rule = New LMUItem + rule.repWhat = "02 Outcome-" + rule.repList.Add ("00 \02 ") + Call m_ReplaceMap.Add(rule) + + Set rule = New LMUItem + rule.repWhat = "03 " + rule.repList.Add ("00 \03 ") + rule.repList.Add ("01 Income-") + rule.repList.Add ("02 Outcome-") + Call m_ReplaceMap.Add(rule) + + Set rule = New LMUItem + rule.repWhat = "031 " + rule.repList.Add ("00 \03 ") + rule.repList.Add ("03 ") + Call m_ReplaceMap.Add(rule) + + Set rule = New LMUItem + rule.repWhat = "05 \" + rule.repList.Add ("05 \04 ") + Call m_ReplaceMap.Add(rule) +End Sub + +Private Function IsValidAddress(ByVal addr$) As Boolean + IsValidAddress = True + If Left(addr, Len("\\server\Projects")) Like "\\[Ss][Ee][Rr][Vv][Ee][Rr]\[Pp]rojects" Then IsValidAddress = False + If Left(addr, Len("\\strg1\Exchange")) Like "\\[Ss][Tt][Rr][Gg]1\[Ee]xchange" Then IsValidAddress = False +End Function + +Private Function IsFSO(addr$, docpath$) As Boolean +' + addr = GetFullPath(addr, docpath) + If Left(addr, 3) Like "[PpXx]:\" Then IsFSO = True: Exit Function + If Left(addr, 16) Like "\\[Ss][Tt][Rr][Gg]1\[Pp]rojects" Then IsFSO = True: Exit Function + If Left(addr, 16) Like "\\[Ss][Tt][Rr][Gg]1\[Ee]xchange" Then IsFSO = True: Exit Function + If Left(addr, 17) Like "\\[Ss][Ee][Rr][Vv][Ee][Rr]\[Ee]xchange" Then IsFSO = True: Exit Function + If Left(addr, 17) Like "\\[Ss][Ee][Rr][Vv][Ee][Rr]\[Pp]rojects" Then IsFSO = True: Exit Function + + IsFSO = False +End Function + +Private Function CheckFile(ByVal addr$, currentPath$) As Boolean +' + If Left(addr, 1) = "." Or InStr(addr, "\") + InStr(addr, "/") = 0 Then _ + addr = currentPath & "\" & addr + + On Error Resume Next + CheckFile = Len(Dir(addr)) <> 0 Or Len(Dir(addr, vbDirectory)) <> 0 +End Function + +Private Function SwapStrgServer(ByVal addr$) + SwapStrgServer = addr + If Left(addr, Len("\\server\Projects")) Like "\\[Ss][Ee][Rr][Vv][Ee][Rr]\[Pp]rojects" Then _ + SwapStrgServer = "P:\" + Right(addr, Len(addr) - Len("\\server\Projects\")) + If Left(addr, Len("\\strg1\Exchange")) Like "\\[Ss][Tt][Rr][Gg]1\[Ee]xchange" Then _ + SwapStrgServer = "X:\" + Right(addr, Len(addr) - Len("\\strg1\Exchange\")) +End Function + diff --git a/src/Main.bas b/src/Main.bas new file mode 100644 index 0000000..d6d3667 --- /dev/null +++ b/src/Main.bas @@ -0,0 +1,354 @@ +Attribute VB_Name = "Main" +Option Explicit + +Public Sub CC_AddColumnBreak() + Dim selPar As Word.Range: Set selPar = ActiveDocument.ActiveWindow.Selection.Paragraphs.First.Range + Call selPar.Collapse(wdCollapseStart) + Call selPar.InsertBreak(wdColumnBreak) +End Sub + +Public Sub CC_NonBreakPar() + ActiveDocument.ActiveWindow.Selection.ParagraphFormat.KeepTogether = Not ActiveDocument.ActiveWindow.Selection.ParagraphFormat.KeepTogether +End Sub + +Public Sub CC_WithNext() + Selection.ParagraphFormat.KeepWithNext = Not Selection.ParagraphFormat.KeepWithNext +End Sub + +Public Sub CC_FieldLowerer() + Dim tmpRange As Word.Range: Set tmpRange = ActiveDocument.ActiveWindow.Selection.Range.Duplicate + tmpRange.Start = ActiveDocument.ActiveWindow.Selection.Words.First.Start + tmpRange.End = ActiveDocument.ActiveWindow.Selection.Words.Last.End + + On Error GoTo EXT_SUB + Dim execField As Word.Field + For Each execField In tmpRange.Fields + Call LowerReference(execField) + Next execField +EXT_SUB: +End Sub + +Public Sub CC_MakeUniqueBM() + Dim contextMap As Scripting.Dictionary: Set contextMap = RecreateBookmarks(ActiveDocument) + Call FixHyperlinksAfterBMReplace(ActiveDocument, contextMap) + Call UserInteraction.ShowMessage(IM_UNIQUE_BOOKMARKS_OK) +End Sub + +Public Sub CC_ConvertAllShapesToText() +' + Dim theDoc As Word.Document: Set theDoc = ActiveDocument + Dim tRange As Word.Range: Set tRange = theDoc.Range + + Dim nShape&: nShape = 1 + Dim theText$ + + Dim aShape As Word.Shape + Do While nShape <= theDoc.Shapes.Count ' + Set aShape = theDoc.Shapes(nShape) + If Not aShape.Anchor.InRange(tRange) Then _ + GoTo NEXT_SHAPE + If aShape.Type <> msoTextBox Then _ + GoTo NEXT_SHAPE + + theText = aShape.TextFrame.TextRange.Text + + aShape.TextFrame.TextRange.Copy + tRange.Paragraphs.Add + Call tRange.Paragraphs.Last.Range.Paste + +NEXT_SHAPE: + nShape = nShape + 1 + Loop + + Call UserInteraction.ShowMessage(IM_SHAPES_TO_TEXT_OK) +End Sub + +Public Sub CC_Convert1252_1251() +' + Dim theDoc As Word.Document: Set theDoc = ActiveDocument + theDoc.ActiveWindow.View.ReadingLayout = False + + Dim inputR As Word.Range: Set inputR = theDoc.Application.Selection.Range + + Dim wordUI As New API_WordWrapper: Call wordUI.SetDocument(theDoc) + Call wordUI.PauseUI + + Call CSE_ProgressBar.Init(" 1252 -> 1251", sHeader:=" ...", maxVal:=inputR.Characters.Count) + Call CSE_ProgressBar.ShowModeless + + Dim aChr As Word.Range: Set aChr = inputR.Characters.First + Do While aChr.End < inputR.End + Dim ChrW&: ChrW = VBA.AscW(aChr) + If ChrW < 256 And ChrW > 127 Then _ + aChr.Text = VBA.Chr(ChrW) + Set aChr = aChr.Next(wdCharacter, 1) + Call CSE_ProgressBar.IncrementA + Loop + + Call Unload(CSE_ProgressBar) + Call wordUI.ResumeUI + Call UserInteraction.ShowMessage(IM_CONVERT_CODEPAGE_OK) +End Sub + +Public Sub CC_ParFix() +' Modify spacing to make last line optimal length + Dim selRange As Word.Range: Set selRange = ActiveDocument.ActiveWindow.Selection.Range.Duplicate + Dim aPar As Word.Paragraph + For Each aPar In selRange.Paragraphs + Dim tRange As Word.Range: Set tRange = aPar.Range + If tRange.Tables.Count > 0 Then tRange.End = tRange.End - 1 + Call tRange.Select + Call TryFixingParagraph(tRange) + Next aPar +End Sub + +Public Sub CC_ExportComments() + ' Export comments in new document + Dim iSource As Word.Document: Set iSource = ActiveDocument + Dim iDestination As Word.Document: Set iDestination = Word.Application.Documents.Add + + Dim targetRange As Word.Range: Set targetRange = iDestination.Range + Dim aComment As Word.Comment + Dim nCount&: nCount = 0 + Dim nPage& + For Each aComment In iSource.Comments + nCount = nCount + 1 + Set targetRange = targetRange.Paragraphs.Add.Range + nPage = aComment.Reference.Information(wdActiveEndPageNumber) + targetRange.Text = Fmt(" {1}, {2}, {3}:" & vbNewLine & "{4}" & vbNewLine, nCount, nPage, aComment.Author, aComment.Range.Text) + Next aComment + + Call UserInteraction.ShowMessage(IM_COMMENT_EXPORT_OK, nCount) +End Sub + +Public Sub CC_LineUp() + Dim tRange As Word.Range: Set tRange = ActiveDocument.ActiveWindow.Selection.Paragraphs(1).Range + Dim iSpace As Double: iSpace = tRange.ParagraphFormat.SpaceBefore + tRange.ParagraphFormat.LineSpacing + tRange.ParagraphFormat.SpaceBefore = iSpace +End Sub + +Public Sub CC_LineUpA() + Dim tRange As Word.Range: Set tRange = ActiveDocument.ActiveWindow.Selection.Paragraphs(1).Range + Dim iSpace As Double: iSpace = tRange.ParagraphFormat.SpaceBefore - tRange.ParagraphFormat.LineSpacing + tRange.ParagraphFormat.SpaceBefore = IIf(iSpace >= 0, iSpace, 0) +End Sub + +Public Sub CC_LineDown() + Dim tRange As Word.Range: Set tRange = ActiveDocument.ActiveWindow.Selection.Paragraphs(1).Range + Dim iSpace As Double: iSpace = tRange.ParagraphFormat.SpaceAfter + tRange.ParagraphFormat.LineSpacing + tRange.ParagraphFormat.SpaceAfter = iSpace +End Sub + +Public Sub CC_LineDownA() + Dim tRange As Word.Range: Set tRange = ActiveDocument.ActiveWindow.Selection.Paragraphs(1).Range + Dim iSpace As Double: iSpace = tRange.ParagraphFormat.SpaceAfter - tRange.ParagraphFormat.LineSpacing + tRange.ParagraphFormat.SpaceAfter = IIf(iSpace >= 0, iSpace, 0) +End Sub + +Public Sub CC_CheckLinks() +' + Dim thisDoc As Word.Document: Set thisDoc = ActiveDocument + Dim linkCount&: linkCount = thisDoc.Hyperlinks.Count + If thisDoc.Hyperlinks.Count = 0 Then + Call UserInteraction.ShowMessage(EM_HYPERLINKS_MISSING) + Exit Sub + End If + + Dim result As LMU_LinksInfo: result = FixHyperlinksIn(ActiveDocument.Range) + Call UserInteraction.ShowMessage(IM_HYPERLINKS_FIX_OK, result.lnkCount_, result.errCount_, result.modCount_) +End Sub + +Public Sub CC_AddQuote() + ActiveDocument.ActiveWindow.Selection.Range.Text = Chr(171) & ActiveDocument.ActiveWindow.Selection.Text & Chr(187) +End Sub + +Public Sub CC_EditCut() +' + Dim aRange As Word.Range: Set aRange = ActiveDocument.ActiveWindow.Selection.Range + aRange.Start = aRange.Paragraphs.First.Range.Start + aRange.End = aRange.Paragraphs.Last.Range.End + + Call aRange.Cut + Call ActiveDocument.Paragraphs.Add + Call ActiveDocument.Paragraphs.Last.Range.Paste +End Sub + +Public Sub CC_EditCopy() +' + Dim aRange As Word.Range: Set aRange = ActiveDocument.ActiveWindow.Selection.Range + aRange.Start = aRange.Paragraphs.First.Range.Start + aRange.End = aRange.Paragraphs.Last.Range.End + + Call aRange.Copy + + Call ActiveDocument.Paragraphs.Add + Call ActiveDocument.Paragraphs.Last.Range.Paste + + aRange.HighlightColorIndex = wdYellow +End Sub + +Public Sub CC_CreateHLink() + Dim target As Word.Range: Set target = ActiveDocument.ActiveWindow.Selection.Range + + Dim bookmarkID$ + Dim aBM As Word.Bookmark + For Each aBM In target.Bookmarks + If aBM.Range.End = target.End And aBM.Range.Start = target.Start Then bookmarkID = aBM.Name + Next aBM + + If bookmarkID = vbNullString Then + On Error GoTo ERROR_MSG + bookmarkID = "AUTO_" & Format(Date, "yyyymmdd") & Replace(Time, ":", "") + Call target.Bookmarks.Add(bookmarkID) + End If + + Call AddToClipboard(target.Text) + DoEvents + Call AddToClipboard(ActiveDocument.FullName & "#" & bookmarkID) + Exit Sub + +ERROR_MSG: + Call UserInteraction.ShowMessage(EM_HYPERLINK_CREATION_FAIL) +End Sub + +Public Sub CC_RemoveExternalHyperlinks() + Dim target As Word.Range: Set target = ActiveDocument.ActiveWindow.Selection.Range.Duplicate + Dim aLink As Hyperlink + Dim nLink&: nLink = 1 + Dim delCount&: delCount = 0 + Do While target.Hyperlinks.Count >= nLink + Set aLink = target.Hyperlinks.Item(nLink) + If aLink.Address <> vbNullString Then + Call aLink.Range.Font.Reset + delCount = delCount + 1 + Call aLink.Delete + Else + nLink = nLink + 1 + End If + Loop + Call Word.Application.ScreenRefresh + Call UserInteraction.ShowMessage(IM_REMOVE_HYPERLINKS_OK, delCount) +End Sub + +Public Sub CC_RemoveAllHyperlinks() + Dim target As Word.Range: Set target = ActiveDocument.ActiveWindow.Selection.Range.Duplicate + Dim aLink As Hyperlink + Dim delCount&: delCount = target.Hyperlinks.Count + Do While target.Hyperlinks.Count > 0 + Set aLink = target.Hyperlinks.Item(1) + Call aLink.Range.Font.Reset + Call aLink.Delete + Loop + Call Word.Application.ScreenRefresh + Call UserInteraction.ShowMessage(IM_REMOVE_HYPERLINKS_OK, delCount) +End Sub + +Public Sub CC_RemoveImages() + Dim nDeleted&: nDeleted = RemoveImages(ActiveDocument.ActiveWindow.Selection.Range.Duplicate) + Call Word.Application.ScreenRefresh + Call UserInteraction.ShowMessage(IM_REMOVE_IMAGES_OK, nDeleted) +End Sub + +Public Sub CC_RemoveBookmarks() + Dim target As Word.Range: Set target = ActiveDocument.ActiveWindow.Selection.Range.Duplicate + Dim aBM As Word.Bookmark + Dim delCount&: delCount = target.Bookmarks.Count + Do While target.Bookmarks.Count > 0 + Set aBM = target.Bookmarks.Item(1) + Call aBM.Delete + Loop + Call Word.Application.ScreenRefresh + Call UserInteraction.ShowMessage(IM_REMOVE_BOOKMARKS_OK, delCount) +End Sub + +Public Sub CC_RemoveAccents() + Dim target As Word.Range: Set target = ActiveDocument.ActiveWindow.Selection.Range.Duplicate + If target.Start = target.End Then _ + Set target = ActiveDocument.Range + + Dim nCount&: nCount = RemoveAccentsIn(target) + Call Word.Application.ScreenRefresh + Call UserInteraction.ShowMessage(IM_REMOVE_ACCENTS_OK, nCount) +End Sub + +Public Sub CC_MasterText() + Dim sPath$: sPath = Word.ActiveDocument.FullName + If Word.ActiveDocument.Path = vbNullString Then + Call UserInteraction.ShowMessage(EM_DOCUMENT_NOT_SAVED) + Exit Sub + End If + + Dim xlWrap As New API_XLWrapper + Dim aDoc As Excel.Workbook: Set aDoc = xlWrap.OpenDocument(SERVER_MASTER_TEXT) + If aDoc Is Nothing Then _ + Exit Sub + + Call aDoc.Activate + aDoc.Names(CELL_MASTER_PATH).RefersToRange = sPath$ +End Sub + +Public Sub CC_UpdateConcept() + If Not UpdateConceptPowershell Then + Call UserInteraction.ShowMessage(EM_CORE_UPDATE_FAILED) + Exit Sub + End If + Call UserInteraction.ShowMessage(IM_CONCEPT_UPDATE_OK) +End Sub + +Public Sub CC_Checkup() + Call ExecuteAllRules(ActiveDocument, bApplyFix:=False) +End Sub + +Public Sub CC_FixErrors() + Call ExecuteAllRules(ActiveDocument, bApplyFix:=True) +End Sub + +Public Sub CC_MasterConfig() + Call OpenMasterConfig +End Sub + +Public Sub CC_IgnoreSelected() + ' + Dim target As Word.Range: Set target = ActiveDocument.Application.Selection.Range + If target.Start = target.End Then + Call UserInteraction.ShowMessage(EM_SELECTION_EMPTY) + Exit Sub + End If + + Dim iEditor As New API_WordEditGuard: Call iEditor.InitDoc(target.Document) + Dim sBookmark$: sBookmark = iEditor.BookmarkIgnored(target) + Call UserInteraction.ShowMessage(IM_BOOKMARK_IGNORED, sBookmark) +End Sub + +Public Sub CC_Help() + Dim wordWrap As New API_WordWrapper + Dim helpDoc As Word.Document: Set helpDoc = wordWrap.OpenDocument(SERVER_PATH_HELP, bReadOnly:=True) + If helpDoc Is Nothing Then _ + Exit Sub + + With helpDoc + .ActiveWindow.View.ReadingLayout = False + Call .Application.Activate + End With +End Sub + +' ============ +Private Function ExecuteAllRules(iDoc As Word.Document, Optional bApplyFix As Boolean = True) + Dim iConfig As API_Config: Set iConfig = LoadEditConfig + Dim iProcessor As New RulesProcessor: Call iProcessor.Init(iDoc, iConfig) + Dim iGuard As New API_WordEditGuard: Call iGuard.InitDoc(iDoc) + + Call iGuard.BeginEdit(iConfig.GetValue("TrackRevisions")) + + Call CSE_ProgressBar.Init(" ", sHeader:=" , ...", maxVal:=iProcessor.RuleCount, canInterrupt:=True) + Call CSE_ProgressBar.ShowModeless + + Call iProcessor.RunAll(CollectionToDictionary(iConfig.GetValue("ExcludeRules")), bApplyFix) + + Dim nMilliseconds&: nMilliseconds = Int(CSE_ProgressBar.Time) + CSE_ProgressBar.Description = " " + Call iGuard.EndEdit + + Call Unload(CSE_ProgressBar) + Call UserInteraction.ShowMessage(IM_RULES_COMPLETE, nMilliseconds, iProcessor.errors_, iProcessor.fixes_) +End Function diff --git a/src/MainImpl.bas b/src/MainImpl.bas new file mode 100644 index 0000000..335e7ad --- /dev/null +++ b/src/MainImpl.bas @@ -0,0 +1,247 @@ +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 = "cmd.exe /c " & """" & sInstall & """" & " < nul" + Dim iShell As New WshShell + iShell.CurrentDirectory = CP_TOOLS_SERVER + UpdateConceptPowershell = iShell.Run(sExec, waitOnReturn:=True) = 0 + 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 diff --git a/src/PublicSubs.bas b/src/PublicSubs.bas new file mode 100644 index 0000000..76d80f2 --- /dev/null +++ b/src/PublicSubs.bas @@ -0,0 +1,144 @@ +Attribute VB_Name = "PublicSubs" +Option Explicit + +Public Sub CCM_AddColumnBreak() + Dim selPar As Word.Range: Set selPar = ActiveDocument.ActiveWindow.Selection.Paragraphs.First.Range + Call selPar.Collapse(wdCollapseStart) + Call selPar.InsertBreak(wdColumnBreak) +End Sub + +Public Sub CCM_NonBreakPar() + ActiveDocument.ActiveWindow.Selection.ParagraphFormat.KeepTogether = Not ActiveDocument.ActiveWindow.Selection.ParagraphFormat.KeepTogether +End Sub + +Public Sub CCM_WithNext() + Selection.ParagraphFormat.KeepWithNext = Not Selection.ParagraphFormat.KeepWithNext +End Sub + +Public Sub CCM_FieldLowerer() + Dim tmpRange As Word.Range: Set tmpRange = ActiveDocument.ActiveWindow.Selection.Range.Duplicate + tmpRange.Start = ActiveDocument.ActiveWindow.Selection.Words.First.Start + tmpRange.End = ActiveDocument.ActiveWindow.Selection.Words.Last.End + + On Error GoTo EXT_SUB + Dim execField As Word.Field + For Each execField In tmpRange.Fields + Call bilCrossRef(execField) + Next execField +EXT_SUB: +End Sub + +Public Sub CCM_MakeUniqueBM() +' + Dim contextMap As New Collection + + Dim pref$: pref = "t" & Format(Date, "yyyymmdd") & Replace(Time, ":", "") + Dim i& + For i = ActiveDocument.Bookmarks.Count To 1 Step -1 ' + Dim aMark As Word.BookMark: Set aMark = ActiveDocument.Bookmarks(i) + Dim bmRange As Word.Range: Set bmRange = aMark.Range + Dim newName$: newName = pref & "_" & aMark.Name + + ' + If Len(newName) > 40 Then _ + GoTo NEXT_BM + + Call contextMap.Add(newName, aMark.Name) + Call bmRange.Bookmarks.Add(pref & "_" & aMark.Name) + Call aMark.Delete +NEXT_BM: + Next i + + ' + Dim newAddr$ + For i = ActiveDocument.Hyperlinks.Count To 1 Step -1 + Dim aLink As Word.Hyperlink: Set aLink = ActiveDocument.Hyperlinks(i) + Dim linkRange As Word.Range: Set linkRange = ActiveDocument.Range(aLink.Range.Start, aLink.Range.End) + If Not aLink.Address = "" Or aLink.SubAddress = "" Then _ + GoTo NEXT_LINK + If Not InCollection(aLink.SubAddress, contextMap) Then _ + GoTo NEXT_LINK + + newAddr = contextMap(aLink.SubAddress) + Call aLink.Delete + Call linkRange.Hyperlinks.Add(linkRange, "", newAddr) + +NEXT_LINK: + Next i +End Sub + +Public Sub CCM_ConvertAllShapesToText() +' + Dim theDoc As Word.Document: Set theDoc = ActiveDocument + Dim tRange As Word.Range: Set tRange = theDoc.Range + + Dim nShape&: nShape = 1 + Dim theText$ + + Dim aShape As Word.Shape + Do While nShape <= theDoc.Shapes.Count ' + Set aShape = theDoc.Shapes(nShape) + If Not aShape.Anchor.InRange(tRange) Then _ + GoTo NEXT_SHAPE + If aShape.Type <> msoTextBox Then _ + GoTo NEXT_SHAPE + + theText = aShape.TextFrame.TextRange.Text + + aShape.TextFrame.TextRange.Copy + tRange.Paragraphs.Add + Call tRange.Paragraphs.Last.Range.Paste + +NEXT_SHAPE: + nShape = nShape + 1 + Loop + + Call UserInteraction.ShowMessage(IM_SHAPES_TO_TEXT_OK) +End Sub + +Public Sub CC_Convert1252_1251() +' + Dim theDoc As Word.Document: Set theDoc = ActiveDocument + theDoc.ActiveWindow.View.ReadingLayout = False + + Dim inputR As Word.Range: Set inputR = theDoc.Application.Selection.Range + + Dim wordUI As New API_WordWrapper: Call wordUI.SetDocument(theDoc) + Call wordUI.PauseUI + + Call CSE_ProgressBar.Init(" 1252 -> 1251", sHeader:=" ...", maxVal:=inputR.Characters.Count) + Call CSE_ProgressBar.ShowModeless + + Dim aChr As Word.Range: Set aChr = inputR.Characters.First + Do While aChr.End < inputR.End + Dim chrW&: chrW = VBA.AscW(aChr) + If chrW < 256 And chrW > 127 Then _ + aChr.Text = VBA.Chr(chrW) + Set aChr = aChr.Next(wdCharacter, 1) + Call CSE_ProgressBar.IncrementA + Loop + + Call Unload(CSE_ProgressBar) + Call wordUI.ResumeUI + Call UserInteraction.ShowMessage(IM_CONVERT_CODEPAGE_OK) +End Sub + +' ============ +Private Function bilCrossRef(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 + diff --git a/src/RulesAccess.bas b/src/RulesAccess.bas new file mode 100644 index 0000000..7ae9353 --- /dev/null +++ b/src/RulesAccess.bas @@ -0,0 +1,137 @@ +Attribute VB_Name = "RulesAccess" +' Grant access to document processing rules +Option Explicit + +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 InitProcessor(sDocument$, sConfigJSON$) As Boolean + On Error GoTo RETURN_FALSE + Dim iWrap As New API_WordWrapper + If iWrap.OpenDocument(sDocument) Is Nothing Then _ + GoTo RETURN_FALSE + + Dim iConfig As New API_Config: Call iConfig.LoadFromJSON(sConfigJSON) + Call AccessProcessor.Init(iWrap.Document, iConfig) + InitProcessor = True + Exit Function + +RETURN_FALSE: + InitProcessor = False +End Function + +Public Function RunRule(sRuleID$, Optional bApplyFix As Boolean = True) As Long() + Dim iResult() As Long + ReDim iResult(0 To 2) + + Dim iProcessor As RulesProcessor: Set iProcessor = AccessProcessor + + On Error GoTo RETURN_ERROR + Call iProcessor.ResetCounters + Call iProcessor.RunRule(sRuleID, bApplyFix) + On Error GoTo 0 + + iResult(0) = 0 + iResult(1) = iProcessor.errors_ + iResult(2) = iProcessor.fixes_ + RunRule = iResult + Exit Function + +RETURN_ERROR: + iResult(0) = Err.Number + RunRule = iResult +End Function + +Public Function FinalizeRulesProcessing() + Call AccessProcessor.FinalizeProcessing +End Function + +Public Function EmptyEditConfig() As API_Config + Set EmptyEditConfig = New API_Config + With EmptyEditConfig + Call .SetValue("HighlightErrors", False) + Call .SetValue("CommentUnresolved", True) + Call .SetValue("TrackRevisions", False) + Call .SetValue("ExcludeRules", New Collection) + Call .SetValue("BannedWords", New Collection) + End With +End Function + +Public Function DefaultEditConfig() As API_Config + Set DefaultEditConfig = New API_Config + With DefaultEditConfig + Call .SetValue("HighlightErrors", False) + Call .SetValue("CommentUnresolved", True) + Call .SetValue("TrackRevisions", True) + Call .SetValue("ExcludeRules", New Collection) + Call .SetValue("BannedWords", LoadBannedWords) + End With +End Function + +Public Function LoadEditConfig() As API_Config + Dim iConfig As API_Config + Dim fso As New Scripting.FileSystemObject + Dim sFile$: sFile = VBA.Environ$("USERPROFILE") & "\" & CONCEPT_LOCAL_HOME & "\" & CONCEPT_MASTER_CONFIG + If fso.FileExists(sFile) Then + Set iConfig = New API_Config + Call iConfig.LoadFromFile(sFile) + Else + Set iConfig = DefaultEditConfig + Call iConfig.RemoveKey("BannedWords") + Call iConfig.SaveToFile(sFile) + End If + Call iConfig.SetValue("BannedWords", LoadBannedWords) + Set LoadEditConfig = iConfig +End Function + +Public Function OpenMasterConfig() + Dim fso As New Scripting.FileSystemObject + Dim sFile$: sFile = VBA.Environ$("USERPROFILE") & "\" & CONCEPT_LOCAL_HOME & "\" & CONCEPT_MASTER_CONFIG + If Not fso.FileExists(sFile) Then + Dim iConfig As API_Config: Set iConfig = DefaultEditConfig + Call iConfig.RemoveKey("BannedWords") + Call iConfig.SaveToFile(sFile) + End If + Dim oShell As New Shell32.Shell + Call oShell.Open(sFile) +End Function + +' ======= +Private Function LoadBannedWords() As Collection + Dim result As New Collection + Dim sLocal$: sLocal = VBA.Environ$("USERPROFILE") & "\" & CONCEPT_LOCAL_HOME & "\models\" & 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 = VBA.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 + +Private Function TryUpdateBannedWords() As Boolean + Dim sServer$: sServer = CONCEPT_SERVER_HOME & CONCEPT_BANNED_WORDS + Dim sLocal$: sLocal = VBA.Environ$("USERPROFILE") & "\" & CONCEPT_LOCAL_HOME & "\models\" & CONCEPT_BANNED_WORDS + TryUpdateBannedWords = CopyFileOrFolder(sSource:=sServer, sDestination:=sLocal) +End Function diff --git a/src/RulesProcessor.cls b/src/RulesProcessor.cls new file mode 100644 index 0000000..8e7b098 --- /dev/null +++ b/src/RulesProcessor.cls @@ -0,0 +1,1162 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "RulesProcessor" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private Const SYMBOL_QUOTE$ = """" +Private Const SYMBOL_LETTER$ = "a-zA-Z--߸" +Private Const SYMBOL_DIGIT$ = "0-9" + +Private Const MASK_LETTER$ = "[" & SYMBOL_LETTER & "]" +Private Const MASK_DIGIT$ = "[" & SYMBOL_DIGIT & "]" +Private Const MASK_ALPHANUM = "[" & SYMBOL_LETTER & SYMBOL_DIGIT & "]" +Private Const MASK_ROMAN_DIGIT$ = "[ivxlcdmIVXLCDM]" + +Private Const MASK_QUOTE$ = "[" & SYMBOL_QUOTE & "]" + +Private Const NEW_PARAGRAPH = -1 + +' +Private Const AR1019_LINES_PER_PAR = 10 + +Private Const TEXT_SPELLING_STATS = "{1}" & vbNewLine & " : {2}" & vbNewLine & " : {3}" + +Private editor_ As DocumentEditor +Private config_ As API_Config +Private applyFix_ As Boolean + +Public errors_ As Long +Public fixes_ As Long + +Private Sub Class_Initialize() + Call ResetCounters +End Sub + +Public Property Get RuleCount() As Long + RuleCount = 30 +End Property + +Public Function Init(iDoc As Word.Document, iConfig As API_Config) + Set editor_ = New DocumentEditor + Call editor_.Init(iDoc, iConfig) + Set config_ = iConfig + Call ResetCounters +End Function + +Public Function ResetCounters() + errors_ = 0 + fixes_ = 0 +End Function + +Public Function RunAll(iExclude As Scripting.Dictionary, bApplyFix As Boolean) + applyFix_ = bApplyFix + Call RunRulesInternal(iExclude) + Call FinalizeProcessing +End Function + +Public Function RunRule(sRuleID$, bApplyFix As Boolean) + Dim sFunction$: sFunction = "Rule" & VBA.Right(sRuleID, VBA.Len(sRuleID) - 2) + applyFix_ = bApplyFix + Call CallByName(Me, sFunction, VbMethod) +End Function + +Public Function FinalizeProcessing() + Call editor_.FinalizeComments +End Function + +Public Function Rule1001() + Const RULE_DESCRIPTION$ = "AR1001: / " + + Dim rFind As Word.Range: Set rFind = editor_.SetupFindLiteral("^p ") + Do While rFind.Find.Execute + Call rFind.MoveEndWhile(CSet:=" " & Chr(160), Count:=wdForward) + + If Not applyFix_ Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION$) + Else + rFind.Start = rFind.Start + 1 + rFind.Text = vbNullString + End If + + Call rFind.Collapse(wdCollapseEnd) + Call Increment(applyFix_) + Loop + + Set rFind = editor_.SetupFindLiteral(" ^p") + Do While rFind.Find.Execute + Call rFind.MoveStartWhile(CSet:=" " & Chr(160), Count:=wdBackward) + If Not applyFix_ Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION$) + Else + rFind.End = rFind.End - 1 + rFind.Text = vbNullString + End If + + Call rFind.Collapse(wdCollapseEnd) + Call Increment(applyFix_) + Loop + + Set rFind = editor_.SetupFindLiteral("^t^p") + Do While rFind.Find.Execute + Call rFind.MoveStartWhile(CSet:=" " & Chr(160) & vbTab, Count:=wdBackward) + If Not applyFix_ Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION$) + Else + rFind.End = rFind.End - 1 + rFind.Text = vbNullString + End If + + Call rFind.Collapse(wdCollapseEnd) + Call Increment(applyFix_) + Loop +End Function + +Public Function Rule1002() + Const RULE_DESCRIPTION$ = "AR1002: " + + Dim rFind As Word.Range: Set rFind = editor_.SetupFindLiteral(" ") + Do While rFind.Find.Execute + Call rFind.MoveEndWhile(CSet:=" ", Count:=wdForward) + If Not applyFix_ Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION) + Else + rFind.Start = rFind.Start + 1 + rFind.Text = vbNullString + End If + + Call rFind.Collapse(wdCollapseEnd) + Call Increment(applyFix_) + Loop +End Function + +Public Function Rule1003() + Const RULE_DESCRIPTION$ = "AR1003: " + + Dim rFind As Word.Range: Set rFind = editor_.SetupFindLiteral("^p^p") + Do While rFind.Find.Execute + If Not applyFix_ Or rFind.End - rFind.Start <> 2 Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION) + Call IncrementErrors + Else + Call rFind.MoveEndWhile(CSet:=vbNewLine, Count:=wdForward) + rFind.End = rFind.End - 1 ' Note: if Start is adjusted, then will have problems with end of document + rFind.Text = vbNullString + Call Increment(doBoth:=True) + End If + + Call rFind.Collapse(wdCollapseEnd) + Loop +End Function + +Public Function Rule1004() + Const RULE_DESCRIPTION$ = "AR1004: -" + + Dim result&: result = 0 + result = result + editor_.ReplaceText("+/-", "", applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceText("+ / -", "", applyFix_, RULE_DESCRIPTION) + Call Increment(applyFix_, result) +End Function + +Public Function Rule1005() + Const RULE_DESCRIPTION$ = "AR1005: " + + Call Increment(applyFix_, editor_.ReplaceCascade("[ ^0160][-^0150][ ^0160]", "[-^0150]", Chr(151), applyFix_, RULE_DESCRIPTION, bWildcard:=True)) +End Function + +Public Function Rule1006() + Const RULE_DESCRIPTION$ = "AR1006: " + + Dim result&: result = 0 + result = result + editor_.ReplaceCascade(MASK_LETTER & "^0151" & MASK_LETTER, "^0151", "-", applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade(MASK_LETTER & "^0150" & MASK_LETTER, "^0150", "-", applyFix_, RULE_DESCRIPTION) + Call Increment(applyFix_, result) +End Function + +Public Function Rule1007() + Const RULE_DESCRIPTION$ = "AR1007: " + + Dim result&: result = 0 + result = result + editor_.ReplaceCascade(". [0-9]", " ", Chr(160), applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade("<[]>. [0-9]", " ", Chr(160), applyFix_, RULE_DESCRIPTION) + Call Increment(applyFix_, result) +End Function + +Public Function Rule1013() + Const RULE_DESCRIPTION$ = "AR1013: " + + Dim rFind As Word.Range: Set rFind = editor_.SetupFindLiteral("=") + Do While rFind.Find.Execute(Replace:=False) + If rFind.OMaths.Count = 0 Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION) + Call IncrementErrors + End If + Call rFind.Collapse(wdCollapseEnd) + Loop +End Function + +Public Function Rule1014() + Const RULE_DESCRIPTION$ = "AR1014: " + + Dim result&: result = 0 + Dim sReplacement$: sReplacement = "^0160^0160" + + result = result + editor_.ReplaceWC(" [ ^0160]", sReplacement, applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceWC("[ ^0160] ", sReplacement, applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceWC("[ ^0160][ ^0160][""][""]", sReplacement, applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceWC("[ ^0160][ ^0160][""][""]", sReplacement, applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceWC("[ ^0160]" & MASK_QUOTE & "[ ^0160]" _ + & MASK_QUOTE & "" & MASK_QUOTE & MASK_QUOTE, sReplacement, applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceWC("[ ^0160]" & MASK_QUOTE & "[ ^0160]" _ + & MASK_QUOTE & "" & MASK_QUOTE & MASK_QUOTE, sReplacement, applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceWC("[ ^0160][ ^0160]һ", sReplacement, applyFix_, RULE_DESCRIPTION) + + Call Increment(applyFix_, result) +End Function + +Public Function Rule1016() + Const RULE_DESCRIPTION$ = "AR1016: . . " + +' TODO: Refactor + Dim newText$, leftC$, rightC$ + Dim leftWord As Word.Range, rightWord As Word.Range + Dim leftFlag As Boolean, rightFlag As Boolean + + Dim rFind As Word.Range + Set rFind = editor_.SetupFindWildcard("[-].[ ^0160][-].") + Do While rFind.Find.Execute + leftC = rFind.Previous(wdCharacter, 1).Text + rightC = rFind.Next(wdCharacter, 1).Text + + If leftC Like "[--0-9]" Then _ + GoTo FIND_NEXT + + ' + Set leftWord = rFind.Previous(wdWord, 1) + Set rightWord = rFind.Next(wdWord, 1) + Call rightWord.MoveEndWhile(CSet:=" ^t", Count:=wdBackward) ' + + leftFlag = False + rightFlag = False + If rightC Like "[-]" Then + If Not rFind.Next(wdCharacter, 2) Like "[-]" Then _ + GoTo FIND_NEXT + + Set rightWord = rFind.Next(wdCharacter, 3) + Do While rightWord.Text Like "[-]" + Set rightWord = rightWord.Next(wdCharacter, 1) ' + Loop + + rightFlag = True + rightWord.Start = rFind.End + 2 + rightWord.End = rightWord.End - 1 + Else + If Not leftC = Chr(160) And Not rightC = Chr(160) Then + leftFlag = RangeIsSurname(leftWord) + If rightC Like "[;,:?!.]" Then + rightFlag = False + Else + rightFlag = RangeIsSurname(rightWord) + End If + Else + If leftC = Chr(160) Then + Set leftWord = rFind.Previous(wdCharacter, 2) + Do While leftWord.Text Like "[-]" + Set leftWord = leftWord.Previous(wdCharacter, 1) ' + Loop + + leftFlag = leftWord.Start < rFind.Start - 2 And leftWord.Text Like "[-]" + leftWord.End = rFind.Start - 1 + End If + If rightC = Chr(160) And rFind.Next(wdCharacter, 2) Like "[-]" And _ + rFind.Next(wdCharacter, 3) Like "[-]" Then + Set rightWord = rFind.Next(wdCharacter, 4) + Do While rightWord.Text Like "[-]" + Set rightWord = rightWord.Next(wdCharacter, 1) ' + Loop + + ' + If rFind.Characters(3) = Chr(160) Then _ + GoTo FIND_NEXT + + rightFlag = True + rightWord.Start = rFind.End + 2 + rightWord.End = rightWord.End - 1 + End If + End If + End If + + If Not leftFlag And Not rightFlag Then _ + GoTo FIND_NEXT + + If Not applyFix_ Or (leftFlag And rightFlag) Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION) + Call IncrementErrors + GoTo FIND_NEXT + End If + + newText = rFind.Text + newText = Left(newText, 2) & Chr(160) & Right(newText, 2) & Chr(160) + If leftFlag Then ' .. + rFind.Start = leftWord.Start + + newText = newText & Trim(leftWord.Text) + rFind.Text = newText + Else ' .. + rFind.Start = rFind.Start + rFind.End = rightWord.End + + newText = newText & Trim(rightWord.Text) + End If + + If rFind.Fields.Count > 0 Then _ + GoTo FIND_NEXT + + rFind.Text = newText + Call Increment(doBoth:=True) + +FIND_NEXT: + Call rFind.Collapse(wdCollapseEnd) + Loop + + Set rFind = editor_.SetupFindWildcard("[-].[-].") + Do While rFind.Find.Execute + ' + leftC = rFind.Previous(wdCharacter, 1).Text + rightC = rFind.Next(wdCharacter, 1).Text + + If leftC Like "[--0-9]" Then _ + GoTo FIND_NEXT2 + + ' + Set leftWord = rFind.Previous(wdWord, 1) + Set rightWord = rFind.Next(wdWord, 1) + Call rightWord.MoveEndWhile(CSet:=" ^t", Count:=wdBackward) ' + + leftFlag = False + rightFlag = False + + If rightC Like "[-]" Then + If Not rFind.Next(wdCharacter, 2) Like "[-]" Then _ + GoTo FIND_NEXT2 + + Set rightWord = rFind.Next(wdCharacter, 3) + Do While rightWord.Text Like "[-]" + Set rightWord = rightWord.Next(wdCharacter, 1) ' + Loop + + rightFlag = True + rightWord.Start = rFind.End + rightWord.End = rightWord.End - 1 + Else + If Not leftC = Chr(160) And Not rightC = Chr(160) Then + leftFlag = RangeIsSurname(leftWord) + If rightC Like "[;,:?!.]" Then + rightFlag = False + Else + rightFlag = RangeIsSurname(rightWord) + End If + Else + If leftC = Chr(160) Then + Set leftWord = rFind.Previous(wdCharacter, 2) + Do While leftWord.Text Like "[-]" + Set leftWord = leftWord.Previous(wdCharacter, 1) ' + Loop + + leftFlag = leftWord.Start < rFind.Start - 2 And leftWord.Text Like "[-]" + leftWord.End = rFind.Start - 2 + End If + If rightC = Chr(160) And rFind.Next(wdCharacter, 2) Like "[-]" And _ + rFind.Next(wdCharacter, 3) Like "[-]" Then + Set rightWord = rFind.Next(wdCharacter, 4) + Do While rightWord.Text Like "[-]" + Set rightWord = rightWord.Next(wdCharacter, 1) ' + Loop + + rightFlag = True + rightWord.Start = rFind.End + 1 + rightWord.End = rightWord.End - 1 + End If + End If + End If + + If Not leftFlag And Not rightFlag Then _ + GoTo FIND_NEXT2 + + If Not applyFix_ Or (leftFlag And rightFlag) Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION) + Call IncrementErrors + GoTo FIND_NEXT2 + End If + + newText = rFind.Text + newText = Left(newText, 2) & Chr(160) & Right(newText, 2) & Chr(160) + If leftFlag Then ' .. + rFind.Start = leftWord.Start + + newText = newText & Trim(leftWord.Text) + rFind.Text = newText + Else ' .. + rFind.Start = rFind.Start + rFind.End = rightWord.End + + newText = newText & Trim(rightWord.Text) + End If + + If rFind.Fields.Count > 0 Then _ + GoTo FIND_NEXT2 + + rFind.Text = newText + Call Increment(doBoth:=True) + +FIND_NEXT2: + Call rFind.Collapse(wdCollapseEnd) + Loop +End Function + +Public Function Rule1017() + Const RULE_DESCRIPTION$ = "AR1017: " + + Dim rFind As Word.Range: Set rFind = editor_.SetupFindWildcard(MASK_QUOTE) + rFind.Find.Forward = False ' ! + Dim nLevel&: nLevel = 0 + Dim innerQuote As Boolean: innerQuote = False + Do While rFind.Find.Execute + Dim nextC$: nextC = rFind.Next(wdCharacter, 1).Text + Dim prevC$: prevC = rFind.Previous(wdCharacter, 1).Text + If nextC = "_" Or prevC = "_" Then _ + GoTo NEXT_FIND ' + + Dim quoteChar$ + If IsQuoteOpen(nextC, prevC, nLevel) Then + nLevel = nLevel - 1 + quoteChar = IIf(innerQuote, "", "") + innerQuote = False + If nextC Like "[]" Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION & vbNewLine & " ") + Call IncrementErrors + End If + Else + nLevel = nLevel + 1 + If innerQuote Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION & vbNewLine & " ") + Call IncrementErrors + End If + If nextC Like MASK_QUOTE Then + innerQuote = True + quoteChar = ChrW(8220) + Else + quoteChar = "" + End If + End If + + If nLevel < 0 Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION & vbNewLine & "- ") + Call IncrementErrors + nLevel = 0 + ElseIf nLevel > 3 Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION & vbNewLine & " > 3") + Call IncrementErrors + nLevel = nLevel - 1 + End If + + If rFind.Text <> quoteChar Then + If Not applyFix_ Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION & vbNewLine & " ") + Else + rFind.Text = quoteChar + End If + Call Increment(applyFix_) + End If +NEXT_FIND: + Loop + + If nLevel <> 0 Then + Call editor_.AddGlobalComment(RULE_DESCRIPTION & vbNewLine & " : " & nLevel) + Call IncrementErrors + End If +End Function + +Private Function IsQuoteOpen(sNextChar$, sPrevChar$, nLevel&) As Boolean + If sNextChar Like MASK_ALPHANUM Then + IsQuoteOpen = True + ElseIf sNextChar = Chr(13) Then + IsQuoteOpen = False + ElseIf sPrevChar = Chr(13) Then + IsQuoteOpen = True + ElseIf sPrevChar Like "[().;!\?" & Chr(133) & SYMBOL_DIGIT & SYMBOL_LETTER & SYMBOL_QUOTE & "]" Then + IsQuoteOpen = False + Else + IsQuoteOpen = nLevel > 0 + End If +End Function + +Public Function Rule1018() + Const RULE_DESCRIPTION$ = "AR1018: " + + Dim aCell As Word.Cell, aRow As Word.Row, aTable As Word.Table + Dim theWord As Word.Range + Dim tableRange As Word.Range + Dim prevWord$ + For Each aTable In editor_.Document.Tables + Set tableRange = aTable.Range + For Each aCell In tableRange.Cells + If aCell.Range.Words.Count <= 1 Then _ + GoTo NEXT_CELL + + Set theWord = aCell.Range.Words(aCell.Range.Words.Count - 1) + If theWord Is Nothing Then _ + GoTo NEXT_CELL + + Dim lastword$: lastword = theWord.Text + If Not lastword Like "*[\!\?;.," & Chr(13) & "]" Then _ + GoTo NEXT_CELL + + If lastword = "." Then + prevWord = theWord.Previous(wdWord, 1).Text + If prevWord = "" Or prevWord = "" Or prevWord = "" Or prevWord = "" _ + Or prevWord = "" Or prevWord = "" Or prevWord = "" Or prevWord = "" _ + Then GoTo NEXT_CELL + End If + + Call Increment(applyFix_) + Set theWord = theWord.Characters.Last + + If Not applyFix_ Then + Call editor_.MarkError(aCell.Range, RULE_DESCRIPTION) + GoTo NEXT_CELL + End If + + theWord.Text = vbNullString +NEXT_CELL: + Next aCell + Next aTable +End Function + +Public Function Rule1019() + Const RULE_DESCRIPTION$ = "AR1019: 10 " + + Dim tableOfCont As Word.Range + Dim checkToC As Boolean: checkToC = editor_.Document.TablesOfContents.Count > 0 + If checkToC Then + Set tableOfCont = editor_.Document.TablesOfContents(1).Range + Call tableOfCont.MoveEnd(wdParagraph, 1) + Else + Set tableOfCont = Nothing + End If + + Dim aPar As Word.Paragraph + Dim theRange As Word.Range + For Each aPar In editor_.Document.Paragraphs + Set theRange = aPar.Range + + If theRange.Font.Hidden Then _ + GoTo NEXT_PARAGRAPH + If theRange.Tables.Count > 0 Then _ + GoTo NEXT_PARAGRAPH + If checkToC Then _ + If theRange.InRange(tableOfCont) Then _ + GoTo NEXT_PARAGRAPH + + If theRange.Words.Count < 120 Then _ + GoTo NEXT_PARAGRAPH + If theRange.ComputeStatistics(wdStatisticLines) <= AR1019_LINES_PER_PAR Then _ + GoTo NEXT_PARAGRAPH + + Call editor_.MarkError(theRange, RULE_DESCRIPTION) + Call IncrementErrors +NEXT_PARAGRAPH: + Next aPar +End Function + +Public Function Rule1020() + Const RULE_DESCRIPTION$ = "AR1020: " + + Dim bannedList As Collection: Set bannedList = config_.GetValue("BannedWords") + Dim rFind As Word.Range + Dim sWord As Variant + For Each sWord In bannedList + Set rFind = editor_.Document.Range + With rFind.Find + .MatchWholeWord = True + .Text = CStr(sWord) + .Format = True + .Font.Hidden = False + End With + + Do While rFind.Find.Execute + Call editor_.MarkError(rFind, RULE_DESCRIPTION) + Call IncrementErrors + Call rFind.Collapse(wdCollapseEnd) + Loop + Next sWord +End Function + +Public Function Rule1021() + Const RULE_DESCRIPTION$ = "AR1021: " + + Dim theRange As Word.Range: Set theRange = editor_.Document.Paragraphs.Last.Range + Dim nextRange As Word.Range + + Dim level&, newLevel& + level = 0 + Do While Not theRange Is Nothing + Set nextRange = theRange.Previous(wdParagraph, 1) + + If theRange.Tables.Count > 0 Then _ + GoTo RESET_LEVEL + If Not theRange.ParagraphFormat.OutlineLevel = wdOutlineLevelBodyText Then _ + GoTo RESET_LEVEL + If theRange.Font.Hidden = True Then _ + GoTo RESET_LEVEL + If theRange.Tables.Count > 0 Then _ + GoTo RESET_LEVEL + + newLevel = theRange.ListFormat.ListLevelNumber + If theRange.ListFormat.ListValue = 0 And theRange.ListFormat.ListString = vbNullString Then _ + newLevel = 0 + + If level > newLevel And Not theRange.ParagraphFormat.KeepWithNext Then + If Not applyFix_ Then + Call editor_.MarkError(theRange, RULE_DESCRIPTION) + Else + theRange.ParagraphFormat.KeepWithNext = True + End If + Call Increment(applyFix_) + End If + + level = newLevel + GoTo SKIP_RESET +RESET_LEVEL: + level = 0 +SKIP_RESET: + Set theRange = nextRange + Loop +End Function + +Public Function Rule1022() + Const RULE_DESCRIPTION$ = "AR1022: " + + Dim numLists&: numLists = editor_.Document.ListParagraphs.Count + Dim lastChar$ + Dim theRange As Word.Range + Dim nextRange As Word.Range + Dim nItem& + For nItem = 1 To numLists Step 1 + ' + Set theRange = editor_.Document.ListParagraphs(nItem).Range + If Not theRange.ParagraphFormat.OutlineLevel = wdOutlineLevelBodyText Then _ + GoTo NEXT_LIST_ITEM + If theRange.Tables.Count > 0 Then _ + GoTo NEXT_LIST_ITEM + + Set nextRange = theRange.Next + Call theRange.MoveEndWhile(Chr(13) & Chr(7) & Chr(12) & Chr(14), wdBackward) + If theRange.Start = theRange.End Then _ + GoTo NEXT_LIST_ITEM + lastChar = theRange.Characters.Last + + If IsList(nextRange) Then + If lastChar Like "[.?!,:;]" Then _ + GoTo NEXT_LIST_ITEM + Call IncrementErrors + Call editor_.MarkError(theRange.Words.Last, RULE_DESCRIPTION & vbNewLine & " ") + GoTo NEXT_LIST_ITEM + End If + + If lastChar Like "[.?!]" Then _ + GoTo NEXT_LIST_ITEM + If lastChar Like "[;,]" And Left(nextRange.Text, 1) Like "[a-z-]" Then _ + GoTo NEXT_LIST_ITEM + + If applyFix_ Then + If lastChar Like "[;,]" Then + theRange.Characters.Last = "." + Else + Call theRange.InsertAfter(".") + End If + Else + Call editor_.MarkError(theRange, RULE_DESCRIPTION) + End If + Call Increment(applyFix_) +NEXT_LIST_ITEM: + Next nItem +End Function + +Public Function Rule1023() + Const RULE_DESCRIPTION$ = "AR1023: " + + Dim result&: result = 0 + result = result + editor_.ReplaceCascade("<[].^0032" & MASK_DIGIT, "^0032", "^0160", applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade("<[].^0032" & MASK_DIGIT, "^0032", "^0160", applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade("<[].^0032" & MASK_DIGIT, "^0032", "^0160", applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade("<[].^0032" & MASK_DIGIT, "^0032", "^0160", applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade("<[]." & MASK_DIGIT, ".", ".^0160", applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade("<[]." & MASK_DIGIT, ".", ".^0160", applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade("<[]." & MASK_DIGIT, ".", ".^0160", applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade("<[]." & MASK_DIGIT, ".", ".^0160", applyFix_, RULE_DESCRIPTION) + Call Increment(applyFix_, result) +End Function + +Public Function Rule1024() + Const RULE_DESCRIPTION$ = "AR1024: " +' TODO: refactor! + Dim brStack As New Collection + Dim stackItem As BracketItem + Dim openBr As Boolean + Dim brType As BracketType + + Dim i&, totalstack& + + Dim nStartPara&: nStartPara = NEW_PARAGRAPH + Dim firstPar As Word.Range + Dim firstWord$ + + Dim rFind As Word.Range + Set rFind = editor_.SetupFindWildcard("[\{\}\(\)\[\]]") + Do While rFind.Find.Execute + brType = GetBracketType(rFind.Text) 'get bracket type + + ' - ( ) + Set firstPar = rFind.Paragraphs.First.Range + If Not firstPar.Start = nStartPara Then + If firstPar.Words.Count < 2 Or brType <> BT_PAP Then _ + GoTo CONTINUE + If firstPar.Words(2).Start <> rFind.Start Then _ + GoTo CONTINUE + If Not rFind.Next(wdCharacter, 1) Like "[ " & Chr(9) & "]" Then _ + GoTo CONTINUE + + firstWord = firstPar.Words(1) + If firstWord Like MASK_ROMAN_DIGIT & "*" Or firstWord Like MASK_LETTER Or IsNumeric(firstWord) Then _ + GoTo NEXT_BRACKET + +CONTINUE: + If nStartPara = NEW_PARAGRAPH Then _ + GoTo SKIP_STACK_CLEAR + For i = 1 To brStack.Count + Call editor_.MarkError(brStack.Item(i).brRange, RULE_DESCRIPTION & vbNewLine & " ") + Call IncrementErrors + Next i + Set brStack = New Collection + nStartPara = NEW_PARAGRAPH + End If + +SKIP_STACK_CLEAR: + openBr = rFind.Text Like "[\(\{\[]" 'push + If openBr Then + Set stackItem = New BracketItem + Set stackItem.brRange = editor_.Document.Range(rFind.Start, rFind.End) + stackItem.brType = brType + stackItem.brMark = False + Call brStack.Add(stackItem) + + If nStartPara = -1 Then _ + nStartPara = rFind.Paragraphs.First.Range.Start + + GoTo NEXT_BRACKET + End If + + ' , + ' - ( ) + + totalstack = brStack.Count + If totalstack <> 0 Then + Do While Not brStack.Item(totalstack).brType = brType + brStack.Item(totalstack).brMark = True + totalstack = totalstack - 1 + If totalstack = 0 Then _ + Exit Do + Loop + End If + + ' ( ) + If totalstack = 0 Then + Call editor_.MarkError(rFind, RULE_DESCRIPTION & vbNewLine & " ") + Call IncrementErrors + GoTo NEXT_BRACKET + End If + + ' - + If brStack.Item(totalstack).brMark Then + Call editor_.MarkError(brStack.Item(totalstack).brRange, RULE_DESCRIPTION & vbNewLine & " ") + Call IncrementErrors + End If + + ' , ( ) + Call brStack.Remove(totalstack) +NEXT_BRACKET: + Loop + + ' + For i = 1 To brStack.Count + Call editor_.MarkError(brStack.Item(i).brRange, RULE_DESCRIPTION & vbNewLine & " ") + Call IncrementErrors + Next i +End Function + +Public Function Rule1025() + Const RULE_DESCRIPTION$ = "AR1025: " + + Dim theRange As Word.Range, prevRange As Word.Range + Dim firstPar As Word.Range: Set firstPar = editor_.Document.Paragraphs.First.Range + Dim theLvl&, prevLvl& + Dim para As Word.Paragraph + For Each para In editor_.Document.ListParagraphs + Set theRange = para.Range + theLvl = theRange.ListFormat.ListLevelNumber + If InStr(theRange, Chr(7)) Then _ + GoTo NEXT_PARA + + Set prevRange = theRange.Previous(wdParagraph) + On Error Resume Next + If Not theRange.ListFormat.ListString Like "*#*" Or IsRangeHeader(theRange) Then _ + GoTo NEXT_PARA + If prevRange Is Nothing Or IsRangeHeader(prevRange) Or _ + prevRange.ListFormat.List Is Nothing Or _ + theLvl > prevRange.ListFormat.ListLevelNumber Then + + If theRange.ListFormat.ListValue <> 1 Then + Call theRange.Collapse(wdCollapseStart) + Call editor_.MarkError(theRange, RULE_DESCRIPTION & vbNewLine & " ") + Call IncrementErrors + End If + End If + +NEXT_PARA: + Next para +End Function + +Public Function Rule1026() + Const RULE_DESCRIPTION$ = "AR1026: " + + Dim result&: result = 0 + result = result + editor_.ReplaceCascade("<[]." & "^0160" & ".", "." & "^0160" & ".", "" & "^0160" & "", applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade("<[]." & "^0032" & ".", "." & "^0032" & ".", "" & "^0160" & "", applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade("<[]..", "..", "" & "^0160" & "", applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade("<[].[].", ".", ".^0160", applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade("<[].^0032[].", "^0032", "^0160", applyFix_, RULE_DESCRIPTION) + Call Increment(applyFix_, result) +End Function + +Public Function Rule1027() + Const RULE_DESCRIPTION$ = "AR1027: " + + Dim tmpRef As Word.Field + Dim codeString$ + Dim startPos& + For Each tmpRef In editor_.Document.Fields + + If Not (tmpRef.Type = wdFieldRef And (tmpRef.result Like "[]*" Or tmpRef.result Like "[]*")) Then _ + GoTo SKIP_LOWERING + + If InStr(tmpRef.Code.Text, "\* Lower") = 0 Then + Call IncrementErrors + + If Not applyFix_ Then + Call editor_.MarkError(tmpRef.result, RULE_DESCRIPTION) + GoTo SKIP_LOWERING + End If + + codeString = tmpRef.Code.Text + startPos = InStr(codeString, "_Ref") + Do While Mid(codeString, startPos, 1) <> " " + startPos = startPos + 1 + Loop + codeString = VBA.Left(codeString, startPos) & "\* Lower " & VBA.Mid(codeString, startPos + 1) + tmpRef.Code.Text = codeString + tmpRef.Update + End If +SKIP_LOWERING: + Next tmpRef +End Function + +Public Function Rule1028() + Const RULE_DESCRIPTION$ = "AR1028: " + + Dim iFoot As Word.Footnote + Dim iEnd As Word.Endnote + Dim preRange As Word.Range + For Each iFoot In editor_.Document.Footnotes + Set preRange = iFoot.Reference.Previous(wdCharacter) + If Asc(preRange) = 32 Or Asc(preRange) = 160 Then + Call Increment(applyFix_) + If applyFix_ Then + Call preRange.MoveStartWhile(" " & Chr(160), wdBackward) + Call preRange.Delete + Else + Call editor_.MarkError(preRange, RULE_DESCRIPTION) + End If + End If + Next iFoot + + For Each iEnd In editor_.Document.Endnotes + Set preRange = iEnd.Reference.Previous(wdCharacter) + If Asc(preRange) = 32 Or Asc(preRange) = 160 Then + Call Increment(applyFix_) + If applyFix_ Then + Call preRange.MoveStartWhile(" " & Chr(160), wdBackward) + Call preRange.Delete + Else + Call editor_.MarkError(preRange, RULE_DESCRIPTION) + End If + End If + Next iEnd +End Function + +Public Function Rule1029() + Const RULE_DESCRIPTION$ = "AR1029: /" + + Dim result&: result = 0 + Dim badTail$: badTail = "[" & "^0160" & "^0032" & "]" + Dim repWith$: repWith = "^0160" & "()" + + result = result + editor_.ReplaceCascade("", "/" & badTail, repWith, applyFix_, RULE_DESCRIPTION, bWildcard:=True) + result = result + editor_.ReplaceCascade("<^0032/" & badTail & ">", " /" & badTail, repWith, applyFix_, RULE_DESCRIPTION, bWildcard:=True) + result = result + editor_.ReplaceCascade("", "/", repWith, applyFix_, RULE_DESCRIPTION) + result = result + editor_.ReplaceCascade("<^0032/>", " /", repWith, applyFix_, RULE_DESCRIPTION) + + Call Increment(applyFix_, result) +End Function + +Public Function Rule1098() + Const RULE_DESCRIPTION$ = "AR1098: Word" + + Dim nSpelling&: nSpelling = editor_.Document.Range.SpellingErrors.Count + Dim nGrammar&: nGrammar = editor_.Document.Range.GrammaticalErrors.Count + If nSpelling + nGrammar > 0 Then _ + Call editor_.AddGlobalComment(Fmt(TEXT_SPELLING_STATS, RULE_DESCRIPTION, nSpelling, nGrammar)) + + Call IncrementErrors(nSpelling + nGrammar) +End Function + +Public Function Rule1099() + Const RULE_DESCRIPTION$ = "AR1099: " + + Dim tmp As Boolean: tmp = editor_.Document.TrackRevisions + editor_.Document.TrackRevisions = False + + Dim aField As Word.Field + For Each aField In editor_.Document.Fields + If Not aField.Update Then + If Not aField.result.Font.Hidden Then + Call editor_.MarkError(aField.result, RULE_DESCRIPTION) + Call IncrementErrors + End If + End If + Next aField + + editor_.Document.TrackRevisions = tmp +End Function + +' =========== +Private Function Increment(doBoth As Boolean, Optional nInc& = 1) + errors_ = errors_ + nInc + If doBoth Then _ + fixes_ = fixes_ + nInc +End Function + +Private Function IncrementFixes(Optional nInc& = 1) + fixes_ = fixes_ + nInc +End Function + +Private Function IncrementErrors(Optional nInc& = 1) + errors_ = errors_ + nInc +End Function + +Private Function RangeIsSurname(subject As Word.Range) As Boolean + RangeIsSurname = False + + Dim sStr$: sStr = VBA.Trim(subject.Text) + If sStr Like "*[^0160.]" Then _ + Exit Function + If Not sStr Like "[-]*[-]" Then _ + Exit Function + + RangeIsSurname = True +End Function + +Private Function IsRangeHeader(theRange As Word.Range) As Boolean + If theRange Is Nothing Then + IsRangeHeader = False + Exit Function + End If + IsRangeHeader = theRange.ParagraphFormat.OutlineLevel <> wdOutlineLevelBodyText _ + Or theRange.Style Like "*[]*" +End Function + +Private Function IsList(aRange As Word.Range) As Boolean +' + If aRange Is Nothing Then + IsList = True + Exit Function + End If + IsList = aRange.ListFormat.ListValue = 0 And aRange.ListFormat.ListString = vbNullString And aRange.ListFormat.ListLevelNumber = 0 + IsList = Not IsList +End Function + +Private Function ReplaceAliasDig(targetText$, aText$) As Long +' + Dim replText$: replText = Chr(160) & targetText + Dim result& + result = editor_.ReplaceCascade("([0-9]{2;4})" & targetText, targetText, replText, applyFix_, aText) + result = result + editor_.ReplaceCascade("([0-9]{2;4}) " & targetText, " ", Chr(160), applyFix_, aText) + ReplaceAliasDig = result +End Function + +Private Function RunRulesInternal(iExclude As Scripting.Dictionary) + If Not iExclude.Exists("AR1001") Then Call Rule1001 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1002") Then Call Rule1002 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1003") Then Call Rule1003 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1004") Then Call Rule1004 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1005") Then Call Rule1005 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1006") Then Call Rule1006 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1007") Then Call Rule1007 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1008") Then Call Rule1008 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1009") Then Call Rule1009 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1010") Then Call Rule1010 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1011") Then Call Rule1011 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1012") Then Call Rule1012 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1013") Then Call Rule1013 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1014") Then Call Rule1014 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1016") Then Call Rule1016 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1017") Then Call Rule1017 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1018") Then Call Rule1018 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1019") Then Call Rule1019 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1020") Then Call Rule1020 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1021") Then Call Rule1021 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1022") Then Call Rule1022 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1023") Then Call Rule1023 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1024") Then Call Rule1024 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1025") Then Call Rule1025 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1026") Then Call Rule1026 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1027") Then Call Rule1027 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1028") Then Call Rule1028 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1029") Then Call Rule1029 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1098") Then Call Rule1098 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA + If Not iExclude.Exists("AR1099") Then Call Rule1099 + If CSE_ProgressBar.Visible Then Call CSE_ProgressBar.IncrementA +End Function diff --git a/src/s_RulesProcessor.cls b/src/s_RulesProcessor.cls new file mode 100644 index 0000000..9773d27 --- /dev/null +++ b/src/s_RulesProcessor.cls @@ -0,0 +1,209 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_RulesProcessor" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' TODO: test all missing rules + +Private processor_ As RulesProcessor +Private doc_ As Word.Document +Private ruleID_ As String + +Public Function Setup() + Set doc_ = ThisDocument + Set processor_ = New RulesProcessor + Call processor_.Init(doc_, EmptyEditConfig) +End Function + +Public Function Teardown() + Call doc_.Range.Delete +End Function + +Private Function TestText(sInitial$, sExpected$, Optional sMsg$ = vbNullString) + Dim nStart&: nStart = doc_.Range.End + Call doc_.Paragraphs.Add.Range.InsertAfter(sInitial) + + Call processor_.ResetCounters + Call processor_.RunRule(ruleID_, bApplyFix:=True) + + Dim iLastRange As Word.Range: Set iLastRange = doc_.Range.Duplicate + iLastRange.Start = nStart + iLastRange.End = iLastRange.End - 1 + Dim sTest$: sTest = iLastRange.Text + Call doc_.Range.Delete + + Call Dev_ExpectEQ(sExpected, sTest, sMsg) +End Function + +Private Function TestComment(sInitial$, sAnchor$, Optional sComment$ = vbNullString, Optional sClause$ = vbNullString) + If sClause <> "" Then _ + Call Dev_NewClause(sClause) + + Call doc_.Paragraphs.Add.Range.InsertAfter(sInitial) + + Call processor_.RunRule(ruleID_, bApplyFix:=True) + Call processor_.FinalizeProcessing + Call Dev_AssertEQ(1, doc_.Comments.Count, "Comments count") + + Dim iComment As Word.Comment: Set iComment = doc_.Comments(1) + + Dim sText$: sText = iComment.Range.Text + Call Dev_ExpectEQ(sAnchor, iComment.Scope, "Anchor text") + If sComment <> "" Then + Call Dev_ExpectLike(sText, "*" & sComment, "Comment text") + End If + + Call doc_.Range.Delete +End Function + +Public Function t_HiddenText() + On Error GoTo PROPAGATE_ERROR + ruleID_ = "AR1002" + + Dim sText$: sText = "Test1 Test2" + Dim nStart&: nStart = doc_.Range.End + Call doc_.Paragraphs.Add.Range.InsertAfter(sText) + Dim iLastRange As Word.Range: Set iLastRange = doc_.Range.Duplicate + iLastRange.Start = nStart + iLastRange.End = iLastRange.End - 1 + iLastRange.Font.Hidden = True + + Call processor_.RunRule(ruleID_, bApplyFix:=True) + + Set iLastRange = doc_.Range.Duplicate + iLastRange.Start = nStart + iLastRange.End = iLastRange.End - 1 + Dim sTest$: sTest = iLastRange.Text + + Call Dev_ExpectEQ(sText, sTest, "Do not apply rule to hidden text") + + iLastRange.Font.Hidden = False + Call processor_.RunRule(ruleID_, bApplyFix:=True) + + Set iLastRange = doc_.Range.Duplicate + iLastRange.Start = nStart + iLastRange.End = iLastRange.End - 1 + sTest = iLastRange.Text + Call Dev_ExpectNE(sText, sTest, "Apply valid rule to not hidden text") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ParagraphWhitespace() + On Error GoTo PROPAGATE_ERROR + ruleID_ = "AR1001" + + Call Dev_NewCase("Space in front") + Call TestText(" Test", "Test", "Single space") + Call TestText(" Test", "Test", "Multiple spaces") + Call TestText(Chr(160) & "Test", "Test", "Unbreakable space") + Call TestText(Chr(160) & " " & Chr(160) & "Test", "Test", "Mixed spaces") + Call TestText(vbTab & "Test", vbTab & "Test", "Ignore tabulator") + Call TestText(" " & vbTab & "Test", vbTab & "Test", "Mixed tabulator") + + Call Dev_NewCase("Space in back") + Call TestText("Test ", "Test", "Single space") + Call TestText("Test ", "Test", "Multiple spaces") + Call TestText("Test" & Chr(160), "Test", "Unbreakable space") + Call TestText("Test" & Chr(160) & " " & Chr(160), "Test", "Mixed spaces") + Call TestText("Test" & vbTab, "Test", "Tabulator") + Call TestText("Test" & vbTab & vbTab, "Test", "Multiple tabulator") + Call TestText("Test" & " " & vbTab, "Test", "Mixed tabulator") + + Call Dev_NewCase("Combo spaces") + Call TestText(" Test " & vbTab, "Test") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_DoubleSpace() + On Error GoTo PROPAGATE_ERROR + ruleID_ = "AR1002" + + Call TestText("Test1 test2", "Test1 test2", "Double space") + Call TestText("Test1 " & Chr(160) & "test2", "Test1 test2", "Double unbreakable space") + Call TestText("Test1 test2", "Test1 test2", "Triple space") + Call TestText("Test1" & vbTab & vbTab & "test2", "Test1" & vbTab & vbTab & "test2", "Double tab") + + Call Dev_NewCase("Quadruple space") + Call TestText("Test1 test2", "Test1 test2", "Replace text") + Call Dev_ExpectEQ(1, processor_.errors_, "Error count") + Call Dev_ExpectEQ(1, processor_.errors_, "Fixes count") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_DoubleEndline() + On Error GoTo PROPAGATE_ERROR + ruleID_ = "AR1003" + + Call TestText(vbNewLine & "Test", "Test", "Double endline") + Call TestText("Test" & vbNewLine, "Test", "End of document") + + Call Dev_NewCase("Triple endline") + Call TestText(vbNewLine & vbNewLine & "Test", "Test", "Replace text") + Call Dev_ExpectEQ(1, processor_.errors_, "Error count") + Call Dev_ExpectEQ(1, processor_.errors_, "Fixes count") + + Call Dev_NewCase("Quadruple endline") + Call TestText(vbNewLine & vbNewLine & vbNewLine & "Test", "Test", "Replace text") + Call Dev_ExpectEQ(1, processor_.errors_, "Error count") + Call Dev_ExpectEQ(1, processor_.errors_, "Fixes count") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_PlusMinus() + On Error GoTo PROPAGATE_ERROR + ruleID_ = "AR1004" + + Call TestText("1 +/- 1", "1 1", "Spaces") + Call TestText("1+/-1", "11", "No spaces") + Call TestText("1 + / - 1", "1 1", "Inner spaces") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Quotes() + On Error GoTo PROPAGATE_ERROR + ruleID_ = "AR1017" + + Call Dev_NewCase("Replace incorrect brackets") + Call TestText("Test", "Test") + Call TestText("""Test""", "Test") + Call TestText("Test", "Test") + Call TestText("Test", "Test") + Call TestText("""""", "") + Call TestText("", "") + + Call Dev_NewCase("Double brackets") + Call TestText(" һ", " ғ") + Call TestText(""" ҫ", " ғ") + Call TestText(" һ INC", " һ INC") + + Call Dev_NewCase("Invalid structure") + Call TestComment("Test", "", sClause:="Missing close bracket") + Call TestComment("Test 12", "", sClause:="Missing close bracket") + Call TestComment("Test", "", sClause:="Missing open bracket") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + diff --git a/src/z_UIMessages.bas b/src/z_UIMessages.bas new file mode 100644 index 0000000..1b88709 --- /dev/null +++ b/src/z_UIMessages.bas @@ -0,0 +1,92 @@ +Attribute VB_Name = "z_UIMessages" +' Messaging module +Option Private Module +Option Explicit + +Public Enum MsgCode + EM_HYPERLINK_CREATION_FAIL + EM_HYPERLINKS_MISSING + EM_DOCUMENT_NOT_SAVED + EM_CORE_UPDATE_FAILED + EM_SELECTION_EMPTY + EM_MISSING_FILE + + IM_REMOVE_HYPERLINKS_OK + IM_HYPERLINKS_FIX_OK + IM_REMOVE_BOOKMARKS_OK + IM_REMOVE_IMAGES_OK + IM_SHAPES_TO_TEXT_OK + IM_CONVERT_CODEPAGE_OK + IM_UNIQUE_BOOKMARKS_OK + IM_CONCEPT_UPDATE_OK + IM_BOOKMARK_IGNORED + IM_RULES_COMPLETE + IM_REMOVE_ACCENTS_OK + IM_COMMENT_EXPORT_OK +End Enum + +Private g_UI As API_UserInteraction + +Public Function UserInteraction() As API_UserInteraction + If g_UI Is Nothing Then _ + Set g_UI = New API_UserInteraction + Set UserInteraction = g_UI +End Function + +Public Function SetUserInteraction(newUI As API_UserInteraction) + Set g_UI = newUI +End Function + +Public Function UIShowMessage(theCode As MsgCode, ParamArray params() As Variant) + Dim unwrapped As Variant: unwrapped = params + unwrapped = FixForwardedParams(unwrapped) + + Select Case theCode + Case EM_HYPERLINK_CREATION_FAIL: Call MsgBox(" . ", vbExclamation) + Case EM_HYPERLINKS_MISSING: Call MsgBox(" ", vbInformation) + Case EM_DOCUMENT_NOT_SAVED: Call MsgBox(" " & vbNewLine & " ", vbCritical) + Case EM_SELECTION_EMPTY: Call MsgBox(" . ", vbExclamation) + Case EM_MISSING_FILE: Call MsgBox(Fmt(" : {1}", unwrapped), vbExclamation) + Case EM_CORE_UPDATE_FAILED: Call MsgBox(" ." & vbNewLine _ + & " VPN, (\\fs1.concept.ru)" & vbNewLine _ + & " Excel dll", vbExclamation) + + Case IM_REMOVE_HYPERLINKS_OK: Call MsgBox(Fmt(" : {1}", unwrapped), vbInformation) + Case IM_REMOVE_BOOKMARKS_OK: Call MsgBox(Fmt(" : {1}", unwrapped), vbInformation) + Case IM_REMOVE_IMAGES_OK: Call MsgBox(Fmt(" : {1}", unwrapped), vbInformation) + Case IM_SHAPES_TO_TEXT_OK: Call MsgBox(" ", vbInformation) + Case IM_CONVERT_CODEPAGE_OK: Call MsgBox(" ", vbInformation) + Case IM_UNIQUE_BOOKMARKS_OK: Call MsgBox(" ", vbInformation) + Case IM_REMOVE_ACCENTS_OK: Call MsgBox(Fmt(" : {1}", unwrapped), vbInformation) + Case IM_CONCEPT_UPDATE_OK: Call MsgBox(" ", vbInformation) + Case IM_COMMENT_EXPORT_OK: Call MsgBox(Fmt(" : {1}", unwrapped), vbInformation) + Case IM_BOOKMARK_IGNORED: + Call MsgBox(Fmt(" " & vbNewLine & _ + " {1}", unwrapped), vbInformation) + Case IM_HYPERLINKS_FIX_OK: + Call MsgBox(Fmt(" : {1}" & vbNewLine & _ + " : {2}" & vbNewLine & _ + ": {3}", unwrapped), vbInformation) + Case IM_RULES_COMPLETE + Call MsgBox(Fmt(" : {1} ms" & vbNewLine & vbNewLine & _ + " : {2}" & vbNewLine & _ + " : {3}", unwrapped), vbInformation) + + Case Else: Call MsgBox(" ", vbCritical) + End Select +End Function + +Public Function UIAskQuestion(theCode As MsgCode, ParamArray params() As Variant) As Boolean + Dim unwrapped As Variant: unwrapped = params + unwrapped = FixForwardedParams(unwrapped) + + Dim answer&: answer = vbNo + Select Case theCode +' Case QM_CODE_DELETE_CONFIRM +' answer = MsgBox("Are you sure you want to delete ALL macros from target file?", vbYesNo + vbQuestion) + + Case Else + Call MsgBox(" ", vbCritical) + End Select + UIAskQuestion = answer = vbYes +End Function diff --git a/src/z_UIRibbon.bas b/src/z_UIRibbon.bas new file mode 100644 index 0000000..433e720 --- /dev/null +++ b/src/z_UIRibbon.bas @@ -0,0 +1,30 @@ +Attribute VB_Name = "z_UIRibbon" +Option Explicit + +Sub CC_OnRibbonBtn(iControl As IRibbonControl) + Select Case iControl.ID + Case "CheckLinks": Call CC_CheckLinks + Case "AddQuote": Call CC_AddQuote + Case "EditCut": Call CC_EditCut + Case "EditCopy": Call CC_EditCopy + Case "CreateLink": Call CC_CreateHLink + + Case "FixParagraph": Call CC_ParFix + Case "ExportComments": Call CC_ExportComments + Case "RemoveExternalHyperlinks": Call CC_RemoveExternalHyperlinks + Case "RemoveAllHyperlinks": Call CC_RemoveAllHyperlinks + Case "RemoveImages": Call CC_RemoveImages + Case "RemoveBookmarks": Call CC_RemoveBookmarks + Case "RemoveAccents": Call CC_RemoveAccents + + Case "MasterText": Call CC_MasterText + Case "UpdateConcept": Call CC_UpdateConcept + + Case "Help": Call CC_Help + + Case "Checkup": Call CC_Checkup + Case "FixErrors": Call CC_FixErrors + Case "IgnoreSelected": Call CC_IgnoreSelected + Case "MasterConfig": Call CC_MasterConfig + End Select +End Sub diff --git a/ui/.rels b/ui/.rels new file mode 100644 index 0000000..2b00f63 --- /dev/null +++ b/ui/.rels @@ -0,0 +1,2 @@ + + \ No newline at end of file diff --git a/ui/customUI.xml b/ui/customUI.xml new file mode 100644 index 0000000..a58d24a --- /dev/null +++ b/ui/customUI.xml @@ -0,0 +1,101 @@ + + + + + + +