commit a729cc4b832649f6baa26abb1c6bafeb6a937a5c Author: IRBorisov <8611739+IRBorisov@users.noreply.github.com> Date: Fri Jun 7 20:49:50 2024 +0300 Initial commit diff --git a/VBAMake.txt b/VBAMake.txt new file mode 100644 index 0000000..280e1f9 --- /dev/null +++ b/VBAMake.txt @@ -0,0 +1,38 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact_home, source_home + +id = MasterText +name = Мастер Текстов +description = Автоматическое редактирование текстов +artifact_home = Мастер Текстов +source_home = MasterText +install_home = \\fs1.concept.ru\projects\10 Автоматизация деятельности\01 Высокие технологии\ВТ-04 Мастер текстов + +%% +# === Build section === +# Available commands: +# build LOCAL_MANIFEST +# copy LOCAL_SOURCE -> [LOCAL_ARTIFACT] +# save_as LOCAL_ARTIFACT -> LOCAL_ARTIFACT +# run LOCAL_SOURCE.bat + +build script\masterManifest.txt + +copy distr\!!Листовка.docx +copy distr\!Руководство пользователя.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 Мастер текстов.xlsm +install !!Листовка.docx +install !Руководство пользователя.docx +install banned-words.txt \ No newline at end of file diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..26aaba0 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +1.2.0 diff --git a/distr/!!Листовка.docx b/distr/!!Листовка.docx new file mode 100644 index 0000000..bba32a9 Binary files /dev/null and b/distr/!!Листовка.docx differ diff --git a/distr/!Руководство пользователя.docx b/distr/!Руководство пользователя.docx new file mode 100644 index 0000000..3273d9b Binary files /dev/null and b/distr/!Руководство пользователя.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/masterManifest.txt b/script/masterManifest.txt new file mode 100644 index 0000000..be3af72 --- /dev/null +++ b/script/masterManifest.txt @@ -0,0 +1,83 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = Мастер текстов.xlsm +artifact = Мастер текстов.xlsm + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + +api + ex_WinAPI.bas + API_UserInteraction.cls + API_WordWrapper.cls + API_XLWrapper.cls + +word + ex_Word.bas + API_WordEditGuard.cls + +utility + ex_VBA.bas + API_Timer.cls + API_Config.cls + API_JSON.cls + +ui + CSE_ProgressBar.frm + +dev + DevTester.bas + +%% +# === 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_UIRibbon.bas + z_UIMessages.bas + + SelectSourceDlg.frm + RulesDlg.frm + + UIState.cls + + DB_Rules.cls + IteratorRule.cls + + 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 + +%% +# === References Section === +# List dependencies in one of the formats +# global : GLOBAL_NAME +# guid : {REGISTERED_GUID} +# file : PATH_TO_LIBRARY + +global : VBScript_RegExp_55 +global : Scripting +global : Shell32 +global : Word +global : MSForms +global : ADODB \ No newline at end of file diff --git a/skeleton/Мастер текстов.xlsm b/skeleton/Мастер текстов.xlsm new file mode 100644 index 0000000..83e1791 Binary files /dev/null and b/skeleton/Мастер текстов.xlsm differ diff --git a/src/DB_Rules.cls b/src/DB_Rules.cls new file mode 100644 index 0000000..8f266b1 --- /dev/null +++ b/src/DB_Rules.cls @@ -0,0 +1,54 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DB_Rules" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private data_ As Excel.Worksheet + +Public Function Init(target As Excel.Worksheet) + Set data_ = target +End Function + +Public Function IBegin() As IteratorRule + Set IBegin = New IteratorRule + Call IBegin.Init(data_) +End Function + +Public Function ILast() As IteratorRule + Set ILast = New IteratorRule + Call ILast.Init(data_) + Call ILast.GoLast +End Function + +Public Function INew() As IteratorRule + Set INew = New IteratorRule + Call INew.Init(data_) + Call INew.GoLast + Call INew.Increment +End Function + +Public Function Count() As Long + Count = ILast.row_ - IBegin.row_ + 1 +End Function + +Public Function FindRule(sID$) As IteratorRule + Dim iRule As IteratorRule: Set iRule = IBegin + If iRule.GoToID(sID) Then _ + Set FindRule = iRule +End Function + +Public Function ClearStats() + Dim iRule As IteratorRule: Set iRule = IBegin + Do Until iRule.IsDone + iRule.ErrorsCount = 0 + iRule.FixesCount = 0 + iRule.TimeSpent = 0 + Call iRule.Increment + Loop +End Function diff --git a/src/Declarations.bas b/src/Declarations.bas new file mode 100644 index 0000000..11b7880 --- /dev/null +++ b/src/Declarations.bas @@ -0,0 +1,68 @@ +Attribute VB_Name = "Declarations" +Option Explicit + +Public Const FIRST_DATA_ROW = 2 + +Public Const STYLE_ERROR_COLOR = wdBrightGreen +Public Const STYLE_ERROR_PREFIX = "!ERROR_" + +Public Const FLAG_VALUE_ON = "" +Public Const FLAG_VALUE_OFF = "" + +Public Const APP_HELP = "\\fs1.concept.ru\projects\10 \01 \-04 \! .docx" + +Public Const CONCEPT_SERVER_HOME = "\\fs1.concept.ru\projects\10 \!Concept\models\" +Public Const CONCEPT_LOCAL_HOME = ".concept\models\" +Public Const CONCEPT_BANNED_WORDS = "banned-words.txt" + +' +Public Const SHEET_START = "Start" +Public Const SHEET_UI = "" +Public Const SHEET_RULES = "" + +' +Public Const CELL_PAGE_COUNT = "c_PageCount" +Public Const CELL_SINGLE_RULE = "c_TheOnlyRule" +Public Const CELL_FIXES_COUNT = "c_FixesCount" +Public Const CELL_ERROR_COUNT = "c_ErrCount" + +Public Const RULES_COUNT_NAME = "c_RuleCount" +Public Const RULES_GROUP_NAME = "r_RuleGroup" +Public Const CELL_TARGET_PATH = "c_DocPath" +Public Const STYLE_TEMPLATE_NAME = "c_StyleTemplate" + +Public Const EXCEPTION_COUNT_NAME = "c_ExceptionBMCount" +Public Const EXCEPTION_WORD_COUNT_NAME = "c_ExceptionWordCount" +Public Const STYLE_COUNT_NAME = "c_StyleCount" +Public Const STYLE_DELETE_NAME = "c_StyleDelete" +Public Const STYLE_RENAME_NAME = "c_StyleRename" + +Public Enum AddinErrors + ERR_CANNOT_INIT = vbObjectError + 1000 +End Enum + +' _R_ - Rules +Public Enum RuleStruct + [_First] = 1 + + S_R_ID = 1 + S_R_NAME = 2 + S_R_ENABLED = 3 + S_R_APPLY = 4 + S_R_GROUP = 5 + S_R_DESCRIPTION = 6 + S_R_ERRORS = 7 + S_R_FIXES = 8 + S_R_TIME = 9 + + [_Last] = 9 +End Enum + +' _P_ - parameters +Public Enum ParamsStruct + [_First] = 1 + + S_P_BANNED_WORDS = 1 + + [_Last] = 1 +End Enum diff --git a/src/DevHelper.bas b/src/DevHelper.bas new file mode 100644 index 0000000..f231b1d --- /dev/null +++ b/src/DevHelper.bas @@ -0,0 +1,21 @@ +Attribute VB_Name = "DevHelper" +Option Explicit + +Public Function Dev_PrepareSkeleton() + Call AccessRules.ClearStats + Call AccessUI.LogStylesData(0, 0, 0) +End Function + +Public Sub Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_WordDocument" + Dim sTest$: sTest = "t_AddCategory" + 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_WordDocument": Set Dev_GetTestSuite = New s_WordDocument + End Select +End Function diff --git a/src/IteratorRule.cls b/src/IteratorRule.cls new file mode 100644 index 0000000..b9ccd10 --- /dev/null +++ b/src/IteratorRule.cls @@ -0,0 +1,127 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "IteratorRule" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public row_ As Long +Private data_ As Excel.Worksheet + +Public Sub Init(target As Excel.Worksheet, Optional tRow& = FIRST_DATA_ROW) + Set data_ = target + row_ = tRow +End Sub + +Public Function Increment(Optional inc& = 1) + If row_ + inc > 0 Then _ + row_ = row_ + inc +End Function + +Public Function GoFirst() + row_ = FIRST_DATA_ROW +End Function + +Public Function GoLast() + row_ = data_.Columns(S_R_ID).Find(vbNullString, LookAt:=xlWhole).Row - 1 +End Function + +Public Function GoToID(sID$) As Boolean + Dim rFound As Excel.Range: Set rFound = data_.Columns(S_R_ID).Find(sID, LookAt:=xlWhole) + If rFound Is Nothing Then + GoToID = False + Else + GoToID = True + row_ = rFound.Row + End If +End Function + +Public Function IsDone() As Boolean + IsDone = data_.Cells(row_, S_R_ID) = vbNullString +End Function + +Public Function RemoveRow() + Call data_.Rows(row_).Delete +End Function + +'===== Propertiy Get ===== +Public Property Get RuleID() As String + RuleID = data_.Cells(row_, S_R_ID) +End Property + +Public Property Get RuleName() As String + RuleName = data_.Cells(row_, S_R_NAME) +End Property + +Public Property Get Enabled() As Boolean + Enabled = data_.Cells(row_, S_R_ENABLED) = FLAG_VALUE_ON +End Property + +Public Property Get ApplyFixes() As Boolean + ApplyFixes = data_.Cells(row_, S_R_APPLY) = FLAG_VALUE_ON +End Property + +Public Property Get GroupName() As String + GroupName = data_.Cells(row_, S_R_GROUP) +End Property + +Public Property Get Description() As String + Description = data_.Cells(row_, S_R_DESCRIPTION) +End Property + +Public Property Get ErrorsCount() As Long + ErrorsCount = data_.Cells(row_, S_R_ERRORS) +End Property + +Public Property Get FixesCount() As Long + FixesCount = data_.Cells(row_, S_R_FIXES) +End Property + +Public Property Get TimeSpent() As Double + TimeSpent = data_.Cells(row_, S_R_TIME) +End Property + +Public Property Get DescriptionLabel() As String + DescriptionLabel = Fmt("{1}: {2}", RuleID, RuleName) +End Property + +' ==== Property Let ==== +Public Property Let RuleID(newVal$) + data_.Cells(row_, S_R_ID) = newVal +End Property + +Public Property Let RuleName(newVal$) + data_.Cells(row_, S_R_NAME) = newVal +End Property + +Public Property Let Enabled(newVal As Boolean) + data_.Cells(row_, S_R_ENABLED) = IIf(newVal, FLAG_VALUE_ON, FLAG_VALUE_OFF) +End Property + +Public Property Let ApplyFixes(newVal As Boolean) + data_.Cells(row_, S_R_APPLY) = IIf(newVal, FLAG_VALUE_ON, FLAG_VALUE_OFF) +End Property + +Public Property Let GroupName(newVal$) + data_.Cells(row_, S_R_GROUP) = newVal +End Property + +Public Property Let Description(newVal$) + data_.Cells(row_, S_R_DESCRIPTION) = newVal +End Property + +Public Property Let ErrorsCount(newVal&) + data_.Cells(row_, S_R_ERRORS) = newVal +End Property + +Public Property Let FixesCount(newVal&) + data_.Cells(row_, S_R_FIXES) = newVal +End Property + +Public Property Let TimeSpent(newVal As Double) + data_.Cells(row_, S_R_TIME) = newVal +End Property diff --git a/src/Main.bas b/src/Main.bas new file mode 100644 index 0000000..7e394a4 --- /dev/null +++ b/src/Main.bas @@ -0,0 +1,264 @@ +Attribute VB_Name = "Main" +Option Explicit + +Public Sub RunInputFile() + Call AccessUI.InputTargetFile +End Sub + +Public Sub RunInputOpen() + Call AccessUI.ChooseTargetFileFromOpened +End Sub + +Public Sub RunOpenTarget() + Call ActivateCurrentDocument +End Sub + +Public Sub RunInputTemplate() + Call AccessUI.InputTemplate +End Sub + +Public Sub RunCheckup() + Call ExecuteAll(bApplyFix:=False) +End Sub + +Public Sub RunFixErrors() + Call ExecuteAll(bApplyFix:=True) +End Sub + +Public Sub RunRecovery() +' + Dim xlUI As New API_XLWrapper: Call xlUI.SetDocument(ThisWorkbook) + Call xlUI.ResumeUI +End Sub + +Public Sub ExecuteSingle(Optional bApplyFix As Boolean = True) +' + Dim target As API_WordEditGuard: Set target = PrepareTargetDocument + If target Is Nothing Then _ + Exit Sub + + AccessUI.PageCount = target.Document.ComputeStatistics(wdStatisticPages) + + Dim sRuleID$: sRuleID = AccessUI.SingleRuleID + Dim dbRules As DB_Rules: Set dbRules = AccessRules + Dim iRule As IteratorRule: Set iRule = dbRules.FindRule(sRuleID) + Dim iProcessor As RulesProcessor: Set iProcessor = AccessProcessor + + Dim xlUI As New API_XLWrapper: Call xlUI.SetDocument(ThisWorkbook) + Call xlUI.PauseUI + Call target.BeginEdit(AccessUI.RevisionEnabled) + + Call dbRules.ClearStats + + Call iProcessor.Init(target.Wrapper, AccessUI.ProduceRulesConfig) + Dim nMilliseconds& + nMilliseconds = RunRule(iProcessor, iRule, bApplyFix:=bApplyFix, DoDebug:=True) + + Call iProcessor.FinalizeProcessing + Call target.EndEdit + Call xlUI.ResumeUI + + If AccessUI.ShowDiff Then _ + Call target.SaveAndShowDiff + + Call Application.ActiveWorkbook.Activate + Call UserInteraction.ShowMessage(IM_RULES_COMPLETE, nMilliseconds, AccessUI.ErrorsCount, AccessUI.FixesCount) +End Sub + +Public Sub RunFixStyles() +' + Dim target As API_WordEditGuard: Set target = PrepareTargetDocument + If target Is Nothing Then _ + Exit Sub + + Dim wordWrap As New API_WordWrapper + Dim templateDoc As Word.Document: Set templateDoc = wordWrap.OpenDocument(AccessUI.TemplatePath) + If templateDoc Is Nothing Then _ + Exit Sub + + Call target.Document.ActiveWindow.Activate + + Call CSE_ProgressBar.Init(" ", _ + sHeader:=" ", _ + maxVal:=target.Document.Styles.Count) + Call CSE_ProgressBar.ShowModeless + + Call ProcessStyles(target.Document, templateDoc) + + Call templateDoc.Close(SaveChanges:=False) + Call Unload(CSE_ProgressBar) + Call UserInteraction.ShowMessage(IM_STYLES_FIXED) +End Sub + +Public Sub RunFixManualFormat() +' + Dim target As API_WordEditGuard: Set target = PrepareTargetDocument + If target Is Nothing Then _ + Exit Sub + Dim iDoc As Word.Document: Set iDoc = target.Document + + Call target.BeginEdit(AccessUI.RevisionEnabled) + + Call CSE_ProgressBar.Init(" ", _ + sHeader:=" ", _ + maxVal:=iDoc.Range.End) + Call CSE_ProgressBar.ShowModeless + + Call SelectVisibleText(iDoc) + + With iDoc + .Range.NoProofing = False + .Application.Selection.ClearCharacterDirectFormatting + .Application.Selection.ClearParagraphDirectFormatting + .Range.NoProofing = True + Call .Paragraphs(1).Range.Select + End With + + Call target.EndEdit + Call Unload(CSE_ProgressBar) + + Call MsgBox(" ") +End Sub + +Public Sub RunChooseRules() + Dim dbRules As DB_Rules: Set dbRules = AccessRules + + Call RulesDlg.Init(dbRules) + Call RulesDlg.Show + If RulesDlg.isCanceled_ Then _ + Exit Sub + Dim iSelected As Scripting.Dictionary: Set iSelected = RulesDlg.GetSelectedIDList() + Call Unload(RulesDlg) + + Dim iRule As IteratorRule: Set iRule = dbRules.IBegin + Do Until iRule.IsDone + iRule.Enabled = iSelected.Exists(iRule.RuleID) + Call iRule.Increment + Loop +End Sub + +Public Sub OpenBannedWords() + Dim fso As New Scripting.FileSystemObject + Dim sFile$: sFile = CONCEPT_SERVER_HOME & CONCEPT_BANNED_WORDS + If Not fso.FileExists(sFile) Then + Call UserInteraction.ShowMessage(EM_MISSING_FILE, sFile) + Exit Sub + End If + Dim oShell As New Shell32.Shell + Call oShell.Open(sFile) +End Sub + +Public Sub UpdateBannedWords() + If TryUpdateBannedWords Then + Call UserInteraction.ShowMessage(IM_UPDATE_BANNED_SUCCESS) + Else + Call UserInteraction.ShowMessage(IM_UPDATE_BANNED_FAIL) + End If +End Sub + +Public Sub ClearWordFormat() +' / + Dim target As API_WordEditGuard: Set target = PrepareTargetDocument + If target Is Nothing Then _ + Exit Sub + + Call target.BeginEdit(AccessUI.RevisionEnabled) + Call target.EndEdit + + Call UserInteraction.ShowMessage(IM_FORMAT_CLEARED) +End Sub + +Public Sub ChangeEncoding() + Call ChangeCharset(AccessUI.TargetPath, Range("c_CodeInput"), Range("c_CodeOutput")) + Call MsgBox(" ", vbInformation) +End Sub + +Public Sub RunHelp() + Dim iWord As New API_WordWrapper + Dim iHelp As Word.Document: Set iHelp = iWord.OpenDocument(APP_HELP, bReadOnly:=True) + If iHelp Is Nothing Then _ + Exit Sub + + With iHelp + .ActiveWindow.View.ReadingLayout = False + Call .Application.Activate + End With +End Sub + +' ========== +Private Function PrepareTargetDocument() As API_WordEditGuard + Dim applWord As API_WordWrapper: Set applWord = OpenTargetDocument + If applWord Is Nothing Then _ + Exit Function + + If applWord.Document.ReadOnly Then ' ReadOnly + Call UserInteraction.ShowMessage(EM_DOC_READONLY) + Call applWord.Document.ActiveWindow.Activate + Exit Function + End If + + If applWord.Document.Comments.Count > 0 Then + If Not UserInteraction.AskQuestion(QM_WARN_COMMENTS) Then _ + Exit Function + Call applWord.Document.DeleteAllComments + End If + + If Not applWord.Document.Saved Then + If UserInteraction.AskQuestion(QM_SAVE_DOC) Then _ + Call applWord.Document.Save + End If + + Set PrepareTargetDocument = New API_WordEditGuard + Call PrepareTargetDocument.Init(applWord) +End Function + +Private Function ExecuteAll(Optional bApplyFix As Boolean = True) +' + Dim target As API_WordEditGuard: Set target = PrepareTargetDocument + If target Is Nothing Then _ + Exit Function + + AccessUI.PageCount = target.Document.ComputeStatistics(wdStatisticPages) + Dim dbRules As DB_Rules: Set dbRules = AccessRules + + Dim xlUI As New API_XLWrapper: Call xlUI.SetDocument(ThisWorkbook) + Call xlUI.PauseUI + Call target.BeginEdit(AccessUI.RevisionEnabled) + + Call AccessRules.ClearStats + + Call CSE_ProgressBar.Init(" ", sHeader:=" , ...", maxVal:=dbRules.Count, canInterrupt:=True) + Call CSE_ProgressBar.ShowModeless + + Dim iProcessor As RulesProcessor: Set iProcessor = AccessProcessor() + Call iProcessor.Init(target.Wrapper, AccessUI.ProduceRulesConfig) + + Dim wasInterrupted As Boolean: wasInterrupted = False + Dim nMilliseconds&: nMilliseconds = 0 + Dim bFixFlag As Boolean + Dim iRule As IteratorRule: Set iRule = dbRules.IBegin + Do Until iRule.IsDone + If CSE_ProgressBar.Interrupted Then + wasInterrupted = True + Exit Do + End If + + If iRule.Enabled Then + CSE_ProgressBar.Description = iRule.DescriptionLabel + bFixFlag = bApplyFix And iRule.ApplyFixes + nMilliseconds = nMilliseconds + RunRule(iProcessor, iRule, bFixFlag, AccessUI.DoDebug) + End If + + Call CSE_ProgressBar.IncrementA + Call iRule.Increment + Loop + + CSE_ProgressBar.Description = " " + Call iProcessor.FinalizeProcessing + + Call Unload(CSE_ProgressBar) + Call target.EndEdit + Call xlUI.ResumeUI + + Call UserInteraction.ShowMessage(IM_RULES_COMPLETE, nMilliseconds, AccessUI.ErrorsCount, AccessUI.FixesCount) +End Function diff --git a/src/MainImpl.bas b/src/MainImpl.bas new file mode 100644 index 0000000..49e71c8 --- /dev/null +++ b/src/MainImpl.bas @@ -0,0 +1,186 @@ +Attribute VB_Name = "MainImpl" +Option Private Module +Option Explicit + +Public Function AccessRules() As DB_Rules + Static s_Rules As DB_Rules + If s_Rules Is Nothing Then + Set s_Rules = New DB_Rules + Call s_Rules.Init(ThisWorkbook.Worksheets(SHEET_RULES)) + End If + + Set AccessRules = s_Rules +End Function + +Public Function AccessProcessor() As RulesProcessor + Static s_Processor As RulesProcessor + If s_Processor Is Nothing Then _ + Set s_Processor = New RulesProcessor + Set AccessProcessor = s_Processor +End Function + +Public Function LoadBannedWords() As Collection + Dim result As New Collection + Dim sLocal$: sLocal = VBA.Environ$("USERPROFILE") & "\" & CONCEPT_LOCAL_HOME & CONCEPT_BANNED_WORDS + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sLocal) Then + If Not TryUpdateBannedWords() Then + Call UserInteraction.ShowMessage(EM_MISSING_FILE, sLocal) + GoTo RETURN_EMPTY + End If + End If + + Dim adoStream As New ADODB.Stream + adoStream.Charset = "utf-8" + Call adoStream.Open + Call adoStream.LoadFromFile(sLocal) + Dim sLines() As String: sLines = Split(adoStream.ReadText, vbCrLf) + Call adoStream.Close + + Dim nLine& + For nLine = LBound(sLines, 1) To UBound(sLines, 1) Step 1 + Dim sText$: sText = sLines(nLine) + If sText <> vbNullString Then _ + Call result.Add(sText) + Next nLine + +RETURN_EMPTY: + Set LoadBannedWords = result +End Function + +Public Function TryUpdateBannedWords() As Boolean + Dim sServer$: sServer = CONCEPT_SERVER_HOME & CONCEPT_BANNED_WORDS + Dim sLocal$: sLocal = VBA.Environ$("USERPROFILE") & "\" & CONCEPT_LOCAL_HOME & CONCEPT_BANNED_WORDS + TryUpdateBannedWords = CopyFileOrFolder(sSource:=sServer, sDestination:=sLocal) +End Function + +Public Function OpenTargetDocument() As API_WordWrapper + Dim sFileName$: sFileName = AccessUI.TargetPath + If sFileName = "" Then + Call UserInteraction.ShowMessage(EM_PATH_EMPTY) + Exit Function + End If + + Dim iWrapper As New API_WordWrapper + If Not iWrapper.OpenDocument(sFileName) Is Nothing Then _ + Set OpenTargetDocument = iWrapper +End Function + +Public Function ActivateCurrentDocument() + Dim appWord As API_WordWrapper: Set appWord = OpenTargetDocument + If appWord Is Nothing Then _ + Exit Function + Call appWord.Document.ActiveWindow.Activate +End Function + +Public Function RunRule(iProcessor As RulesProcessor, iRule As IteratorRule, bApplyFix As Boolean, Optional DoDebug As Boolean = False) As Double + Dim aTimer As New API_Timer: Call aTimer.Start + + If Not DoDebug Then _ + On Error GoTo SHOW_FAILURE + Call iProcessor.RunRule(iRule.RuleID, bApplyFix) + If Not DoDebug Then _ + On Error GoTo 0 + GoTo LOG_RESULT + +SHOW_FAILURE: + Call UserInteraction.ShowMessage(EM_RULE_FAILED, iRule.RuleID) + +LOG_RESULT: + iRule.TimeSpent = aTimer.TimeElapsed + iRule.ErrorsCount = iProcessor.errors_ + iRule.FixesCount = iProcessor.fixes_ + RunRule = iRule.TimeSpent +End Function + +Public Function ProcessStyles(target As Word.Document, templateDoc As Word.Document) + Dim nCount&: nCount = target.Styles.Count + Dim nRenamed&: nRenamed = 0 + Dim nRemoved&: nRemoved = 0 + Dim aStyle As Word.Style + For Each aStyle In target.Styles + Dim sName$: sName = aStyle.NameLocal + If sName = "" Then + GoTo NEXT_STYLE + ElseIf aStyle.BuiltIn Then + nCount = nCount - 1 + GoTo NEXT_STYLE + ElseIf WordStyleExists(templateDoc, sName) Then + GoTo NEXT_STYLE + ElseIf AccessUI.StylesDeleteUnused And Not WordStyleIsUsed(target, aStyle) Then + Call aStyle.Delete + nRemoved = nRemoved + 1 + GoTo NEXT_STYLE + End If + + If AccessUI.StylesRename And Not sName Like STYLE_ERROR_PREFIX & "*" Then + sName = STYLE_ERROR_PREFIX & sName + aStyle.NameLocal = sName + aStyle.Priority = 1 + nRenamed = nRenamed + 1 + End If + If AccessUI.StylesFormat Then + aStyle.Font.ColorIndex = STYLE_ERROR_COLOR + End If + +NEXT_STYLE: + Call CSE_ProgressBar.IncrementA + Next aStyle + + Call AccessUI.LogStylesData(nCount, nRenamed, nRemoved) +End Function + +Public Function ChangeCharset(sFile$, chSetInput$, chSetOutput$) + Dim adoStream As New ADODB.Stream + With adoStream + .Charset = chSetInput + Call .Open + Call .LoadFromFile(sFile) + .Position = 0 + End With + + Dim adoStreamOut As New ADODB.Stream + With adoStreamOut + .Charset = chSetOutput + Call .Open + Call .WriteText(adoStream.ReadText) + Call .SaveToFile(sFile, adSaveCreateOverWrite) + Call .Close + End With + + Call adoStream.Close + Set adoStream = Nothing + Set adoStreamOut = Nothing +End Function + +Public Function SelectVisibleText(target As Word.Document) +' + Call target.DeleteAllEditableRanges(wdEditorEveryone) + + Dim rFind As Word.Range: Set rFind = target.Range + Dim nStart&: nStart = -1 + With rFind.Find + .Font.Hidden = False + .Format = True + .Text = "<*^0013" + .MatchWildcards = True + Do While .Execute + Call rFind.Editors.Add(wdEditorEveryone) + + If CSE_ProgressBar.Visible Then _ + Call CSE_ProgressBar.SetA(rFind.End) + + If nStart = rFind.Start Then ' , + Debug.Print " " + Exit Do + Else + nStart = rFind.Start + End If + + Call rFind.Collapse(wdCollapseEnd) + Loop + End With + + Call target.SelectAllEditableRanges(wdEditorEveryone) + Call target.DeleteAllEditableRanges(wdEditorEveryone) +End Function diff --git a/src/RulesDlg.frm b/src/RulesDlg.frm new file mode 100644 index 0000000..d05bf3c --- /dev/null +++ b/src/RulesDlg.frm @@ -0,0 +1,79 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} RulesDlg + Caption = " " + ClientHeight = 9270.001 + ClientLeft = 45 + ClientTop = 375 + ClientWidth = 14325 + OleObjectBlob = "RulesDlg.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "RulesDlg" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Private ids_ As Collection + +Public isCanceled_ As Boolean + +Private Sub UserForm_Initialize() + isCanceled_ = True + Call PositionInMiddle(Me) +End Sub + +Public Function Init(iData As DB_Rules) + Call RulesLB.Clear + + Set ids_ = New Collection + + Dim iRule As IteratorRule: Set iRule = iData.IBegin + Dim sItem$, sID$ + Do Until iRule.IsDone + sID = iRule.RuleID + sItem = iRule.DescriptionLabel + Call ids_.Add(sID) + Call RulesLB.AddItem(sItem) + If iRule.Enabled Then _ + RulesLB.Selected(RulesLB.ListCount - 1) = True + + Call iRule.Increment + Loop +End Function + +Public Function GetSelectedIDList() As Scripting.Dictionary + Dim result As New Scripting.Dictionary + Dim levelID$ + Dim i& + For i = 0 To RulesLB.ListCount - 1 Step 1 + If RulesLB.Selected(i) Then _ + Call result.Add(ids_.Item(i + 1), i + 1) + Next i + Set GetSelectedIDList = result +End Function + +Private Sub ClearListBtn_Click() + Dim nItem& + For nItem = 1 To RulesLB.ListCount + RulesLB.Selected(nItem - 1) = False + Next +End Sub + +Private Sub SelectAllBtn_Click() + Dim nItem& + For nItem = 1 To RulesLB.ListCount + RulesLB.Selected(nItem - 1) = True + Next +End Sub + +Private Sub OkBtn_Click() + isCanceled_ = False + Call Me.Hide +End Sub + +Private Sub CancelBtn_Click() + isCanceled_ = True + Call Me.Hide +End Sub diff --git a/src/RulesDlg.frx b/src/RulesDlg.frx new file mode 100644 index 0000000..aca62fa Binary files /dev/null and b/src/RulesDlg.frx differ diff --git a/src/RulesProcessor.cls b/src/RulesProcessor.cls new file mode 100644 index 0000000..0f8b3d0 --- /dev/null +++ b/src/RulesProcessor.cls @@ -0,0 +1,36 @@ +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 word_ As API_WordWrapper + +Public errors_ As Long +Public fixes_ As Long + +Public Function Init(iWord As API_WordWrapper, iConfig As API_Config) + Set word_ = iWord + Dim sConfig$: sConfig = iConfig.SaveToJSON + Dim sFile$: sFile = iWord.Document.FullName + If Not word_.Run("RulesAccess.InitProcessor", sFile, sConfig) Then _ + Call Err.Raise(ERR_CANNOT_INIT) +End Function + +Public Function RunRule(sRuleID$, Optional bApplyFix As Boolean = True) + Dim vResult As Variant + vResult = word_.Run("RulesAccess.RunRule", sRuleID, bApplyFix) + If vResult(0) <> 0 Then _ + Call Err.Raise(vResult(0)) + errors_ = vResult(1) + fixes_ = vResult(2) +End Function + +Public Function FinalizeProcessing() + Call word_.Run("RulesAccess.FinalizeRulesProcessing") +End Function diff --git a/src/SelectSourceDlg.frm b/src/SelectSourceDlg.frm new file mode 100644 index 0000000..d7a8194 --- /dev/null +++ b/src/SelectSourceDlg.frm @@ -0,0 +1,93 @@ +VERSION 5.00 +Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} SelectSourceDlg + Caption = " Word" + ClientHeight = 4965 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 4560 + OleObjectBlob = "SelectSourceDlg.frx":0000 + StartUpPosition = 1 'CenterOwner +End +Attribute VB_Name = "SelectSourceDlg" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Public bCanceled As Boolean +Private m_ExcelDB As Excel.Workbook + +Private Sub UserForm_Initialize() + bCanceled = True + + Dim TopOffset& + Dim LeftOffset& + + TopOffset = (Application.UsableHeight / 2) - (Me.Height / 2) + LeftOffset = (Application.UsableWidth / 2) - (Me.Width / 2) + + Me.StartUpPosition = 0 + Me.Top = Application.Top + TopOffset + Me.Left = Application.Left + LeftOffset +End Sub + +Public Function SetSelect(sRes$) + Dim nCount& + Dim i& + nCount = ListBox1.ListCount + For i = 0 To nCount - 1 + ListBox1.Selected(i) = ListBox1.List(i) = sRes + Next i +End Function + +Public Function GetSelectedText() As String + Dim i& + For i = 0 To ListBox1.ListCount - 1 + If ListBox1.Selected(i) = True Then + GetSelectedText = ListBox1.List(i) + Exit Function + End If + Next i +End Function + +Public Function GetSelectedID() As Long + Dim i& + For i = 0 To ListBox1.ListCount - 1 + If ListBox1.Selected(i) = True Then + GetSelectedID = i + 1 + Exit Function + End If + Next i +End Function + + +Public Function Init(nameList As Collection) + bCanceled = True + + ListBox1.Clear + Dim i& + Dim aText$ + For i = 1 To nameList.Count + aText = nameList.Item(i) + Call ListBox1.AddItem(aText) + Next i +End Function + +Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) + Call OkBtn_Click +End Sub + +Private Sub SelectSource_Activate() + bCanceled = True +End Sub + +Private Sub OkBtn_Click() + bCanceled = False + Me.Hide +End Sub + +Private Sub CancelBtn_Click() + bCanceled = True + Me.Hide +End Sub diff --git a/src/SelectSourceDlg.frx b/src/SelectSourceDlg.frx new file mode 100644 index 0000000..72a2998 Binary files /dev/null and b/src/SelectSourceDlg.frx differ diff --git a/src/UIState.cls b/src/UIState.cls new file mode 100644 index 0000000..4552fb0 --- /dev/null +++ b/src/UIState.cls @@ -0,0 +1,148 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "UIState" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private controlData_ As Excel.Worksheet + +Private Sub Class_Initialize() + Set controlData_ = ThisWorkbook.Sheets(SHEET_UI) +End Sub + +Public Function InputTargetFile() + Call UpdateFileInCell(ThisWorkbook.Names(CELL_TARGET_PATH).RefersToRange) +End Function + +Public Function InputTemplate() + Call UpdateFileInCell(ThisWorkbook.Names(STYLE_TEMPLATE_NAME).RefersToRange) +End Function + +Public Function ProduceRulesConfig() As API_Config + Dim result As New API_Config + Call result.SetValue("HighlightErrors", HighlightErrors) + Call result.SetValue("CommentUnresolved", CommentUnresolved) + Call result.SetValue("BannedWords", LoadBannedWords) + Set ProduceRulesConfig = result +End Function + +Public Function ChooseTargetFileFromOpened() + ' + On Error GoTo NO_APPLICATION + Dim wordAppl As Word.Application: Set wordAppl = GetObject(, "Word.Application") + + Dim fileList As New Collection + Dim nameList As New Collection + Dim i& + For i = 1 To wordAppl.Documents.Count + Call fileList.Add(wordAppl.Documents.Item(i).FullName) + Call nameList.Add(wordAppl.Documents.Item(i).Name) + Next + + Call SelectSourceDlg.Init(nameList) + SelectSourceDlg.Show + If SelectSourceDlg.bCanceled Then _ + Exit Function + + ThisWorkbook.Names(CELL_TARGET_PATH).RefersToRange = fileList(SelectSourceDlg.GetSelectedID) + + Exit Function + +NO_APPLICATION: + Call UserInteraction.ShowMessage(EM_NO_OPEN_DOCS) +End Function + +Public Function LogStylesData(nCount&, renames&, deletes&) +' + ThisWorkbook.Sheets(SHEET_UI).Range(STYLE_COUNT_NAME) = nCount + ThisWorkbook.Sheets(SHEET_UI).Range(STYLE_DELETE_NAME) = deletes + ThisWorkbook.Sheets(SHEET_UI).Range(STYLE_RENAME_NAME) = renames +End Function + +' ========= Get ======== +Public Property Get PageCount() As Long + PageCount = ThisWorkbook.Names(CELL_PAGE_COUNT).RefersToRange +End Property + +Public Property Get SingleRuleID() As String + SingleRuleID = ThisWorkbook.Names(CELL_SINGLE_RULE).RefersToRange +End Property + +Public Property Get ShowDiff() As Boolean +' " " + ShowDiff = ThisWorkbook.Sheets(SHEET_UI).OptionDiff.Value +End Property + +Public Property Get RevisionEnabled() As Boolean +' " " + RevisionEnabled = ThisWorkbook.Sheets(SHEET_UI).OptionRevision.Value +End Property + +Public Property Get CommentUnresolved() As Boolean +' " " + CommentUnresolved = ThisWorkbook.Sheets(SHEET_UI).DoAddComment.Value +End Property + +Public Property Get HighlightErrors() As Boolean +' " " + HighlightErrors = ThisWorkbook.Sheets(SHEET_UI).DoHighlightCB.Value +End Property + +Public Property Get DoDebug() As Boolean + DoDebug = ThisWorkbook.Sheets(SHEET_UI).TurnOnDebug.Value +End Property + +Public Property Get StylesDeleteUnused() As Boolean + StylesDeleteUnused = ThisWorkbook.Sheets(SHEET_UI).DoDeleteUnused.Value +End Property + +Public Property Get StylesRename() As Boolean + StylesRename = ThisWorkbook.Sheets(SHEET_UI).DoRenameStyles.Value +End Property + +Public Property Get StylesFormat() As Boolean + StylesFormat = ThisWorkbook.Sheets(SHEET_UI).DoFormatStyles.Value +End Property + +Public Property Get ErrorsCount() As Long + Dim iCell As Excel.Range: Set iCell = ThisWorkbook.Names(CELL_ERROR_COUNT).RefersToRange + Call iCell.Calculate + ErrorsCount = iCell +End Property + +Public Property Get FixesCount() As Long + Dim iCell As Excel.Range: Set iCell = ThisWorkbook.Names(CELL_FIXES_COUNT).RefersToRange + Call iCell.Calculate + FixesCount = iCell +End Property + +Public Property Get TargetPath() As String + TargetPath = ThisWorkbook.Names(CELL_TARGET_PATH).RefersToRange +End Property + +Public Property Get TemplatePath() As String + Dim result$ + result = ThisWorkbook.Sheets(SHEET_UI).Range(STYLE_TEMPLATE_NAME) + If VBA.Left(result, 9) Like "%APPDATA%" Then + result = Environ("appdata") & VBA.Right(result, VBA.Len(result) - 9) + End If + TemplatePath = result +End Property + +' ========= Let ======== +Public Property Let PageCount(newVal&) + ThisWorkbook.Names(CELL_PAGE_COUNT).RefersToRange = newVal +End Property + +' ====== +Private Function UpdateFileInCell(aCell As Excel.Range) + Dim result$: result = UserInteraction.PromptFile(aCell.Text) + If Not result = "" Then + aCell = result + End If +End Function diff --git a/src/z_UIMessages.bas b/src/z_UIMessages.bas new file mode 100644 index 0000000..55da7ec --- /dev/null +++ b/src/z_UIMessages.bas @@ -0,0 +1,96 @@ +Attribute VB_Name = "z_UIMessages" +' +Option Private Module +Option Explicit + +'# +Public Enum MsgCode + MSG_OK = 0 + + EM_DOC_READONLY + EM_RULE_FAILED + EM_NO_OPEN_DOCS + EM_PATH_EMPTY + EM_MISSING_FILE + + IM_RULES_COMPLETE + IM_STYLES_FIXED + IM_FORMAT_CLEARED + IM_UPDATE_BANNED_FAIL + IM_UPDATE_BANNED_SUCCESS + + QM_SAVE_DOC + QM_WARN_COMMENTS +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 ProcessErrorMessages(expectedErrors As Scripting.Dictionary) + If Err.Number = 0 Then _ + Exit Function + + Call Unload(CSE_ProgressBar) + If Not expectedErrors.Exists(Err.Number) Then _ + Call Err.Raise(Err.Number) + + Select Case Err.Number +' Case EM_LINK_NO_FILE: Call UserInteraction.ShowMessage(Err.Number, Err.Source) + End Select +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_DOC_READONLY + Call MsgBox(" !" & vbNewLine & ", ", vbExclamation) + Case EM_RULE_FAILED + Call MsgBox(Fmt(" {1} ! , ", unwrapped), vbExclamation) + Case EM_NO_OPEN_DOCS: Call MsgBox(" Word", vbExclamation) + Case EM_PATH_EMPTY: Call MsgBox(" !", vbExclamation) + Case EM_MISSING_FILE: Call MsgBox(Fmt(" : {1}", unwrapped), vbExclamation) + + Case IM_RULES_COMPLETE + Call MsgBox(Fmt(" : {1} ms" & vbNewLine & vbNewLine & _ + " : {2}" & vbNewLine & _ + " : {3}", unwrapped), vbInformation) + Case IM_STYLES_FIXED: Call MsgBox(" !", vbInformation) + Case IM_FORMAT_CLEARED: Call MsgBox(" ", vbInformation) + Case IM_UPDATE_BANNED_SUCCESS: Call MsgBox(" ", vbInformation) + Case IM_UPDATE_BANNED_FAIL: Call MsgBox(" . \\fs1.concept.ru", 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 As Long: answer = vbNo + Select Case theCode + Case QM_SAVE_DOC + answer = MsgBox("!! ." & vbNewLine _ + & " ?", vbYesNo + vbQuestion) + + Case QM_WARN_COMMENTS + answer = MsgBox("!! . ." & vbNewLine _ + & " , ?", 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..fa99638 --- /dev/null +++ b/src/z_UIRibbon.bas @@ -0,0 +1,30 @@ +Attribute VB_Name = "z_UIRibbon" +Option Private Module +Option Explicit + +Public Function AccessUI() As UIState + Static s_State As UIState + If s_State Is Nothing Then _ + Set s_State = New UIState + Set AccessUI = s_State +End Function + +Public Sub OnRibbonBtn(iControl As IRibbonControl) + Select Case iControl.ID + Case "InputFile": Call RunInputFile + Case "InputOpen": Call RunInputOpen + Case "OpenTarget": Call RunOpenTarget + Case "InputTemplate": Call RunInputTemplate + + Case "Checkup": Call RunCheckup + Case "FixErrors": Call RunFixErrors + Case "FixStyles": Call RunFixStyles + Case "FixManualFormat": Call RunFixManualFormat + + Case "ChooseRules": Call RunChooseRules + Case "AskHelp": Call RunHelp + + Case "Recovery": Call RunRecovery + + End Select +End Sub diff --git a/ui/.rels b/ui/.rels new file mode 100644 index 0000000..3107a8e --- /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..0725dae --- /dev/null +++ b/ui/customUI.xml @@ -0,0 +1,75 @@ + + + + + + +