Sub mark61 End Sub Sub cleanButton Dim config As Object config = initRedactionConfiguration() If ThisComponent.isReadonly Then MsgBox(getTranslation("documentIsReadOnly")) Exit Sub EndIf If config.getPropertyValue("complexity") = "user" then quietStartDialog() Else makerUpMenu() EndIf End Sub Private Sub makerUpMenu Dim dialog As Object DialogLibraries.LoadLibrary("Redaction") dialog = CreateUnoDialog(DialogLibraries.Redaction.CleaningDialog) dialog.getControl("fontsInStyles").Label = getTranslation("advancedMenuReplaceFontsInStyles") dialog.getControl("symbolsConversion").Label = getTranslation("advancedMenuSymbolsConversion") dialog.getControl("cleanFormatting").Label = getTranslation("advancedMenuCleanFormatting") dialog.getControl("replaceWhiteBackground").Label = getTranslation("advancedMenuReplaceWhiteBackground") dialog.getControl("removeUnusedStyles").Label = getTranslation("advancedMenuRemoveUnusedStyles") dialog.getControl("removeLinks").Label = getTranslation("advancedMenuRemoveLinks") dialog.getControl("removeBookmarks").Label = getTranslation("advancedMenuRemoveBookmarks") dialog.getControl("configTables").Label = getTranslation("advancedMenuConfigTables") dialog.getControl("configAnchors").Label = getTranslation("advancedMenuConfigAnchors") dialog.getControl("fixMistakes").Label = getTranslation("advancedMenuFixMistakes") dialog.getControl("removeInitPageBreak").Label = getTranslation("advancedMenuRemoveInitPageBreak") dialog.getControl("removePageStyles").Label = getTranslation("advancedMenuRemovePageStyles") dialog.getControl("loadStandardStyles").Label = getTranslation("advancedMenuLoadStandardStyles") dialog.getControl("removeManualPageBreaks").Label = getTranslation("advancedMenuRemoveManualPageBreaks") dialog.getControl("removeBasic").Label = getTranslation("advancedMenuRemoveBasic") dialog.getControl("Cancel").Label = getTranslation("buttonCancel") dialog.getControl("OK").Label = getTranslation("buttonOK") dialog.getControl("buttonLoad").Label = getTranslation("buttonLoad") dialog.Title = getTranslation("advancedMenuDialogTitle") dialog.setVisible(true) Select Case dialog.Execute() Case 1 cleanAccordingTo(dialog) Case 0 End Select dialog.dispose() Exit sub End Sub Private Sub cleanAccordingTo(dialog As Object) Dim statusIndicator as Object statusIndicator = ThisComponent.getCurrentController.statusIndicator dialog.setVisible(false) saveDocument statusIndicator.Start(getTranslation("statusStarted"),100) doNotTrack If dialog.getControl("loadStandardStyles").state = 1 Then statusIndicator.Start(getTranslation("resaving"),100) saveAsDocAndBackToODT EndIf If dialog.getControl("fontsInStyles").state = 1 Then statusIndicator.Start(getTranslation("statusReplaceFontsInStyles"),100) replaceStyleFonts EndIf If dialog.getControl("symbolsConversion").state = 1 Then statusIndicator.Start(getTranslation("statusConvertSymbolsInTargetFonts"),100) unicodeSymbolsConversion EndIf If dialog.getControl("cleanFormatting").state = 1 Then statusIndicator.Start(getTranslation("statusCleaningManualFormatting"),100) cleanFormatting EndIf If dialog.getControl("replaceWhiteBackground").state = 1 Then statusIndicator.Start(getTranslation("statusReplaceWhiteBackground"),100) replaceWhiteBackgroundWithTransparent EndIf If dialog.getControl("removeUnusedStyles").state = 1 Then statusIndicator.Start(getTranslation("statusRemovedUnusedStyles"),100) removeUnusedStyles EndIf If dialog.getControl("removeLinks").state = 1 Then statusIndicator.Start(getTranslation("statusRemoveLinks"),100) removeHyperlinks EndIf If dialog.getControl("removeBookmarks").state = 1 Then statusIndicator.Start(getTranslation("statusRemoveBookmarks"),100) disposeAllBookmarks EndIf If dialog.getControl("configTables").state = 1 Then statusIndicator.Start(getTranslation("statusConfigureTables"),100) fixTableWidth EndIf If dialog.getControl("configAnchors").state = 1 Then statusIndicator.Start(getTranslation("statusConfigureImagesAnchors"),100) fixDrawingAnchors EndIf If dialog.getControl("fixMistakes").state = 1 Then statusIndicator.Start(getTranslation("statusFixFrequentMistakes"),100) fixFrequentMistakes EndIf If dialog.getControl("removeInitPageBreak").state = 1 Then statusIndicator.Start(getTranslation("statusRemovePageBreakAtStart"),100) removeFirstElementPageBreak EndIf If dialog.getControl("removePageStyles").state = 1 Then statusIndicator.Start(getTranslation("statusRemoveCustomPageStyles"),100) removeUserPageStyles EndIf If dialog.getControl("loadStandardStyles").state = 1 Then statusIndicator.Start(getTranslation("statusLoadingStylesFromTemplate"),100) loadArticleStyles EndIf If dialog.getControl("removeManualPageBreaks").state = 1 Then removeManualPageBreaks EndIf If dialog.getControl("removeBasic").state = 1 Then removeLibs EndIf statusIndicator.end() saveAndreload() MsgBox getTranslation("cleaningFinished") End Sub Private Sub removeLibs Dim docBasic as Object docBasic = ThisComponent.BasicLibraries Dim libs() As String libs = docBasic.getElementNames() Dim libName As String Dim i As Integer For i = LBound(libs) To UBound(libs) libName = libs(i) docBasic.removeLibrary(libName) Next i End Sub Private Sub quietCleaning Dim description As String Dim statusIndicator As Object statusIndicator = ThisComponent.getCurrentController.statusIndicator saveDocument saveAsDocAndBackToODT statusIndicator.Start(getTranslation("statusStarted"),100) doNotTrack statusIndicator.Start(getTranslation("statusReplaceFontsInStyles"),100) replaceStyleFonts statusIndicator.Start(getTranslation("statusConvertSymbolsInTargetFonts"),100) unicodeSymbolsConversion statusIndicator.Start(getTranslation("statusCleaningManualFormatting"),100) cleanFormatting statusIndicator.Start(getTranslation("statusReplaceWhiteBackground"),100) replaceWhiteBackgroundWithTransparent statusIndicator.Start(getTranslation("statusRemovedUnusedStyles"),100) removeUnusedStyles statusIndicator.Start(getTranslation("statusRemoveLinks"),100) removeHyperlinks statusIndicator.Start(getTranslation("statusRemoveBookmarks"),100) disposeAllBookmarks statusIndicator.Start(getTranslation("statusConfigureTables"),100) fixTableWidth statusIndicator.Start(getTranslation("statusConfigureImagesAnchors"),100) fixDrawingAnchors statusIndicator.Start(getTranslation("statusFixFrequentMistakes"),100) fixFrequentMistakes statusIndicator.Start(getTranslation("statusRemovePageBreakAtStart"),100) removeFirstElementPageBreak statusIndicator.Start(getTranslation("statusRemoveCustomPageStyles"),100) removeUserPageStyles statusIndicator.Start(getTranslation("statusLoadingStylesFromTemplate"),100) loadArticleStyles removeLibs addTimeStampToProperties saveCleanedVersion("Standard cleaning") statusIndicator.end() saveAndreload() MsgBox getTranslation("cleaningFinished") End Sub Private Sub removeFirstElementPageBreak Dim enum1 As Object Dim enum1Element As Object enum1 = ThisComponent.Text.createEnumeration If enum1.hasMoreElements Then enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") OR enum1Element.supportsService("com.sun.star.text.TextTable") Then If enum1Element.BreakType <> com.sun.star.style.BreakType.NONE Then enum1Element.PageDescName = "" enum1Element.BreakType = com.sun.star.style.BreakType.NONE EndIf EndIf EndIf End Sub Private Sub replaceStyleFonts ' Globalscope.BasicLibraries.LoadLibrary( "MRILib" ) replaceFontsInStyles("IPH Lib Serif","IPH Astra Serif") replaceFontsInStyles("Liberation Serif","IPH Astra Serif") replaceFontsInStyles("PTSerif","IPH Astra Serif") replaceFontsInStyles("PT Serif","IPH Astra Serif") replaceFontsInStyles("ArabicD","IPH Astra Serif") replaceFontsInStyles("Palatino Linotype Greek","Tinos") End Sub Private Sub replaceFontsInStyles(oldFontStart As String,newFontName As String) Dim propertySetInfo As Object Dim oPositionOfMatch As Long Dim oFamilies As Object Dim sElements As Object Dim oFamily As Object Dim oStyle As Object Dim fontName As String oFamilies = Thiscomponent.StyleFamilies sElements() = oFamilies.getElementNames() For i = 0 to oFamilies.count -1 oFamily = oFamilies.getByName(sElements(i)) For j = 0 to oFamily.getCount -1 oStyle = oFamily.getByIndex(j) propertySetInfo = oStyle.getPropertySetInfo() If propertySetInfo.hasPropertyByName("CharFontName") Then fontName = oStyle.getPropertyValue("CharFontName") oPositionOfMatch = InStr(fontName, oldFontStart) If oPositionOfMatch = 1 Then oStyle.CharFontName = newFontName If propertySetInfo.hasPropertyByName("CharFontNameComplex") Then oStyle.CharFontNameComplex = newFontName EndIf If propertySetInfo.hasPropertyByName("CharFontNameAsian") Then oStyle.CharFontNameAsian = newFontName EndIf EndIf EndIf Next Next End Sub Private Sub unicodeSymbolsConversion convertWLLatin2IPHAstra Dim newFontName As String newFontName = "IPH Astra Serif" Dim RAtts(2) as new com.sun.star.beans.PropertyValue RAtts(0).Name = "CharFontName" RAtts(1).Name = "CharFontNameComplex" RAtts(2).Name = "CharFontNameAsian" 'Basic Astra RAtts(0).Value = newFontName RAtts(1).Value = newFontName RAtts(2).Value = newFontName 'Letterlike Symbols 2100—214F 'Extended latin-1 0080—00FF 'Cyrillic unicode block range \u0400-\u04FF 'Basic Latin \u0020-\u007E 'Combining diacritical marks 0301 0304 0323 032e 0331 035f 'General Punctuation \u2000-\u206f 'Latin Extended A \u0100-\u017f '\u02bb Modifier Letter Turned Comma is in IPH Astra ' unicodeConversionEverywhere("[\u0020-\u007F]+",RAtts) unicodeConversionEverywhere("[\u0020-\u007f\u0080-\u00ff\u0400-\u04ff\u2000-\u206f\u2100-\u214f\u0301\u0304\u0323\u032e\u0331\u0341\u035f\u02bb\u0100-\u017f]+",RAtts) 'Arabic Scheherazade 'Arabic Presentation Forms-A fb50-fdff 'Arabic Presentation Forms-B fe70-feff newFontName = "Scheherazade" RAtts(0).Value = newFontName RAtts(1).Value = newFontName RAtts(2).Value = newFontName unicodeConversionEverywhere("[\u0600-\u06ff\ufb50-\ufdff\ufe70-\ufeff]+",RAtts) 'Greek Tinos newFontName = "Tinos" RAtts(0).Value = newFontName RAtts(1).Value = newFontName RAtts(2).Value = newFontName 'Greek and Coptic 0370—03FF 'Greek extended 1F00—1FFF unicodeConversionEverywhere("[\u0370-\u03ff\u1f00-\u1fff]+",RAtts) 'DejaVu Sans Mathematical operators newFontName = "DejaVu Sans" RAtts(0).Value = newFontName RAtts(1).Value = newFontName RAtts(2).Value = newFontName '\u2200-\u22FF Mathematical operators unicodeConversionEverywhere("[\u2200-\u22ff]+",RAtts) newFontName = "Noto Serif CJK JP" RAtts(0).Value = newFontName RAtts(1).Value = newFontName RAtts(2).Value = newFontName '\u2200-\u22FF CJK Unified Ideographs '3000—303F Символы и пунктуация ККЯ unicodeConversionEverywhere("[\u302b\uff00-\uffef]+",RAtts) newFontName = "Noto Serif CJK SC" RAtts(0).Value = newFontName RAtts(1).Value = newFontName RAtts(2).Value = newFontName '\u2200-\u22FF CJK Unified Ideographs '\u4e00—\u9fff Унифицированные идеограммы ККЯ '\u3400-\u4db7\u4e00—\u9ff1 Найдены в Noto Sans CJK SC '\u3000-\u302a\u302c-\u303f В Noto Sans CJK SC unicodeConversionEverywhere("[\u3000-\u302a\u302c-\u303f\u3400-\u4db7\u4e00-\u9ff1]+",RAtts) End Sub Private Sub unicodeConversionEverywhere(searchPattern As String,rAtts) setAttributesBySearchPattern(searchPattern,RAtts) End Sub 'Replaces manual formatting text with font into character style with assigned font Private Sub convertFontsToCharStyles Dim oDoc As Object Dim SDesc As Object Dim founds As Object Dim curFont As String Dim srch(0) as new com.sun.star.beans.PropertyValue oDoc = Thiscomponent SDesc = Thiscomponent.createSearchDescriptor() SDesc.SearchAll = true SDesc.ValueSearch = false SDesc.SearchStyles = false SDesc.SearchRegularExpression = false SDesc.SearchString = "" srch(0).Name = "CharFontName" SDesc.SetSearchAttributes(srch()) founds = Thiscomponent.findFirst(SDesc) do while not isNull(founds) curFont = founds.CharFontName If IsEmpty(curFont) Then curFont = "IPH Astra Serif" EndIf If curFont <> "IPH Astra Serif" AND curFont <> "" Then If Not DocHasCharStyle(oDoc,curFont) Then Dim oProps(2) As New com.sun.star.beans.PropertyValue oProps(0).Name = "CharFontName" oProps(1).Name = "CharFontNameComplex" oProps(2).Name = "CharFontNameAsian" oProps(0).Value = curFont oProps(1).Value = curFont oProps(2).Value = curFont CreateCharacterStyle(curFont, oProps()) End If founds.CharStyleNames = Array(curFont) EndIf founds = Thiscomponent.findNext(founds.getend, SDesc) loop End Sub Private Sub removeUserPageStyles Dim oStyles As Object Dim oStyle As Object Dim count As Long Dim i As Long oStyles = ThisComponent.StyleFamilies.getByName("PageStyles") count = oStyles.count - 1 For i = 0 to count oStyle = oStyles.getByIndex(i) If oStyle.isUserDefined Then oStyles.removeByName(oStyle.getName) count = oStyles.count - 1 'restart if style removed as sorting is unreliable i = -1 EndIf Next i End Sub Private Sub fixFrequentMistakes Dim config As Object config = initRedactionConfiguration() Dim NBSP As String Dim space As String NBSP = " " space = " " 'Не должно быть символов табуляции AskAndReplace("\t","") 'Не должно быть подряд больше одного пробела AskAndReplace("(?<=[:space:])[:space:]+","") 'Не должно быть ни одного пробела в начале абзацев AskAndReplace("^[:space:]+","") 'Не должно быть пробелов в конце абзацев AskAndReplace("[:space:]+$","") 'Не должно быть пустых абзацев AskAndReplace("^$","") 'Не должно быть пробелов перед знаками пунктуации .,;:?!)]}»¡¿”‘’ AskAndReplace("[:space:]+(?=[\.,;:?!\)\]\}»¡¿”‘’])","") 'Не должно быть пробелов после скобок [({ и кавычек «„ AskAndReplace("(?<=[\(\[\{«„])[:space:]","") 'Между буквами среднее тире должно обрамляться пробелами AskAndReplace("(?<=[:alpha:])–(?=[:alpha:])",NBSP & "–" & NBSP) 'Между буквами дефис-минус, цифровое тире и длинное тире заменяется на среднее тире AskAndReplace("(?<=[:alpha:][:space:])[-‒—](?=[:space:][:alpha:])","–") 'Между двумя цифрами и тире между ними не долнжо быть пробелов. А также тире должно быть цифровым AskAndReplace("(?<=[:digit:])(?:[:space:])?[-‒–—](?:[:space:])?(?=[:digit:])","‒") 'Между двумя римскими цифрами и тире между ними не долнжо быть пробелов. А также тире должно быть средним AskAndReplace("(?<=[MDCLXVI])(?:[:space:])?[-‒–—](?:[:space:])?(?=[MDCLXVI])","–") 'Между буквой и угловой открывающейся скобкой должен быть пробел AskAndReplace("(?<=[:alpha:])<(?=…>)",space & "<") 'Между угловой закрывающейся скобкой и буквой должен быть пробел AskAndReplace("(?<=<…)>(?=[:alpha:])",">" & space) If config.getPropertyValue("fixes_russian_iph") = "true" Then 'между N. Y. не должно быть пробела AskAndReplace("(?<=N\.)[:space:](?=Y\.)","") 'Между словом том и цифрой должен быть неразрывный пробел, а не обычный AskAndReplace("(?<=\b[тТ](ом|\.))\ (?=[:digit:])",NBSP) 'Между словом серия и цифрой должен быть неразрывный пробел, а не обычный AskAndReplace("(?<=\b[сС](ерия|\.))\ +(?=[:digit:])",NBSP) 'Между словом часть и цифрой должен быть неразрывный пробел, а не обычный AskAndReplace("(?<=\b[чЧ](асть|\.))\ +(?=[:digit:])",NBSP) 'Между числом и "г." должен быть неразрывный пробел, а не обычный AskAndReplace("(?<=[0-9])[:space:]*г(?=\.)",NBSP & "г") 'Между инициалами и Фамилией должен быть неразрывный пробел, а не обычный 'А.[м/б пробел]А.Иванов -> А.[м/б пробел]А. Иванов AskAndReplace("(?<=[:upper:]\.[:space:]?[:upper:])\.[:space:]?(?=[:upper:][:lower:]{1,30})","." & NBSP) ' А.[пробел]А.Иванов -> А.А. Иванов AskAndReplace("(?<=[:upper:])\.[:space:](?=[:upper:]\.[:space:][:upper:][:lower:]{1,30})",".") 'Между Фамилией и инициалами должен быть неразрывный пробел, а не обычный 'Иванов А.[м/б пробел]А. -> Иванов А.А. AskAndReplace("(?<=[:upper:][:lower:]{1,30}[:space:][:upper:])\.[:space:]?(?=[:upper:]\.)",".") 'Между "и" и "т." должен быть неразрывный пробел, а не обычный AskAndReplace("(?<=\bи)\ (?=т\.)",NBSP) 'Между "т." и "е./н./д./п./к." не должно быть пробела AskAndReplace("(?<=\bт)\.[:space:]?(?=[ендпк]\.)",".") AskAndReplace("[ий][\u0306]+","й") AskAndReplace("[ИЙ][\u0306]+","Й") AskAndReplace("[её][\u0308]+","ё") AskAndReplace("[ЕЁ][\u0308]+","Ё") EndIf End Sub Private Sub loadArticleStyles Dim dispatcher As Object Dim filePath As String Dim fileTest As Object Dim fileName As String Dim aArgs(0) As New com.sun.star.beans.PropertyValue Dim config As Object config = initRedactionConfiguration() fileName = config.getPropertyValue("defaultTemplate") filePath = getTemplatePath() & "/" & fileName fileTest = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") If NOT fileTest.exists(filePath) Then noStylesFileDialog() fileName = config.getPropertyValue("defaultTemplate") filePath = getTemplatePath() & "/" & fileName If NOT fileTest.exists(filePath) Then 'MsgBox "Файл стилей " & fileName & " не добавлен в Мои шаблоны. Не могу загрузить стили в текущий файл." Exit Sub EndIf EndIf dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") aArgs(0).Name = "OverwriteStyles" aArgs(0).Value = True ThisComponent.StyleFamilies.loadStylesFromURL( filePath, aArgs() ) End Sub Private Sub CreateCharacterStyle(sStyleName As String, oProps()) Dim i As Integer Dim oFamilies As Object Dim oStyle As Object Dim oStyles As Object oFamilies = ThisComponent.StyleFamilies oStyles = oFamilies.getByName("CharacterStyles") If oStyles.HasByName(sStyleName) Then Exit Sub End If oStyle = ThisComponent.createInstance("com.sun.star.style.CharacterStyle") For i=LBound(oProps) To UBound(oProps) oStyle.setPropertyValue(oProps(i).Name, oProps(i).Value) Next oStyles.insertByName(sStyleName, oStyle) End Sub Private Function CreateProperty( Optional cName As String, Optional uValue ) As com.sun.star.beans.PropertyValue Dim oPropertyValue As New com.sun.star.beans.PropertyValue If Not IsMissing( cName ) Then oPropertyValue.Name = cName EndIf If Not IsMissing( uValue ) Then oPropertyValue.Value = uValue EndIf CreateProperty() = oPropertyValue End Function Private Sub AskAndReplace(SearchString As String, oReplaceString As String) Dim SrchAttributes(0) as new com.sun.star.beans.PropertyValue Dim ReplAttributes(0) as new com.sun.star.beans.PropertyValue ReplaceFormatting(SearchString,oReplaceString,SrchAttributes,ReplAttributes, true) End Sub Private Function DocHasCharStyle(oDoc, sName$) As Boolean Dim oStyles As Object oStyles = oDoc.StyleFamilies.getByName("CharacterStyles") DocHasCharStyle() = oStyles.hasByName(sName) End Function Private Function getTemplatePath() as String Dim path as String Dim settings As Object Dim configProvider As Object Dim params(0) As new com.sun.star.beans.PropertyValue Dim convService As Object configProvider = createUnoService( "com.sun.star.configuration.ConfigurationProvider" ) params(0).Name = "nodepath" params(0).Value = "/org.openoffice.Office.Paths/Paths" settings = configProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", params() ) path = settings.Template.WritePath convService = CreateUnoService("com.sun.star.util.PathSubstitution") path = convService.substituteVariables(path, true) path = ConvertToUrl(path) getTemplatePath = path End Function Private Sub removeHyperlinks() Dim aNote As Object Dim x As Long removeHLInText(ThisComponent.Text) For x = 0 to ThisComponent.FootNotes.Count -1 aNote = ThisComponent.FootNotes.getByIndex(x) removeHLInText(aNote.Text) Next For x = 0 to ThisComponent.EndNotes.Count -1 aNote = ThisComponent.EndNotes.getByIndex(x) removeHLInText(aNote.Text) Next End Sub Private Sub removeHLInText(textElement) Dim enum1Element As Object Dim enum1 As Object Dim i As Integer Dim cell As Object Dim cellNames() Dim cellText As Object enum1 = textElement.createEnumeration() While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") Then removeHLInPara(enum1Element) ElseIf enum1Element.supportsService("com.sun.star.text.TextTable") Then cellNames = enum1Element.cellNames For i = LBound(cellNames) To Ubound(cellNames) cell = enum1Element.getCellByName(cellNames(i)) cellText = cell.getText() removeHLInText(cellText) Next i Else EndIf Wend End Sub Private Sub removeHLInPara(para) Dim enum1Element As Object Dim enum1 As Object Dim elPropertySetInfo As Object Dim i As Integer enum1 = para.createEnumeration() While enum1.hasMoreElements enum1Element = enum1.nextElement elPropertySetInfo = enum1Element.getPropertySetInfo() If elPropertySetInfo.hasPropertyByName("HyperLinkURL") Then enum1Element.HyperLinkURL="" EndIf Wend End Sub Private Sub disposeAllBookmarks() Dim bookmarks As Object Dim elementName As String elementName = ThisComponent.Links.ElementNames(6) bookmarks = ThisComponent.Links.getByName(elementName) While bookmarks.hasElements() bookmark = bookmarks.getByName(bookmarks.ElementNames(0)) bookmark.dispose() Wend End Sub Private Sub removeManualPageBreaks Dim oTextCursor As Object Dim enum1 As Object Dim enum1Element As Object oTextCursor = ThisComponent.Text.CreateTextCursor() enum1 = ThisComponent.Text.createEnumeration While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") Then If enum1Element.BreakType <> com.sun.star.style.BreakType.NONE Then oTextCursor.goToRange(enum1Element.getAnchor(), false) If NOT IsEmpty(oTextCursor.PageDescName) Then oTextCursor.PageDescName = "" End If oTextCursor.BreakType = com.sun.star.style.BreakType.NONE End If ElseIf enum1Element.supportsService("com.sun.star.text.TextTable") Then If NOT IsEmpty(enum1Element.PageDescName) Then enum1Element.PageDescName = "" End If enum1Element.BreakType = com.sun.star.style.BreakType.NONE EndIf Wend End Sub Sub setAttributesBySearchPattern(searchPattern As String,ReplAttributes, Optional SrchAttributes) doNotTrack dim stringValue1 As String dim stringValue2 As String Dim oSearch As Object Dim oTextCursor As Object Dim oViewCursor As Object Dim replace As Boolean Dim attrName As string Dim attrValue As String Dim oFound As Object Dim i As Long Dim j As Long dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") oSearch = ThisComponent.createSearchDescriptor() oSearch.SearchString = searchPattern ' Mri oSearch oSearch.SearchRegularExpression=True oSearch.SearchAll = True If Not IsMissing (SrchAttributes) Then If Not IsEmpty(SrchAttributes(0).Value) Then oSearch.searchStyles = true oSearch.SetSearchAttributes(SrchAttributes()) End If EndIf oFound = ThisComponent.findFirst(oSearch) Do While Not IsNull(oFound) replace = true If Not IsMissing(SrchAttributes) Then For j = LBound(SrchAttributes) To Ubound(SrchAttributes) If oFound.getPropertySetInfo.hasPropertyByName(SrchAttributes(j).Name) Then stringValue1 = "" & oFound.getPropertyValue(SrchAttributes(j).Name) stringValue2 = "" & SrchAttributes(j).Value If stringValue1 <> stringValue2 Then replace = replace AND False EndIf Else replace = replace AND False EndIf Next j EndIf If replace then For i = LBound(ReplAttributes) To Ubound(ReplAttributes) 'If oFound.getPropertySetInfo.hasPropertyByName(ReplAttributes(i).Name) Then oFound.SetPropertyValue(ReplAttributes(i).Name, ReplAttributes(i).Value) 'EndIf Next i EndIf oFound = ThisComponent.findNext(oFound.End, oSearch) Loop End Sub Private Sub saveAndreload() Dim document As Object Dim dispatcher As Object document = ThisComponent.CurrentController.Frame dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") dispatcher.executeDispatch(document, ".uno:Save", "", 0, Array()) End Sub Private Sub saveDocument() Dim document As Object Dim dispatcher As Object document = ThisComponent.CurrentController.Frame dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") dispatcher.executeDispatch(document, ".uno:Save", "", 0, Array()) end Sub Private Sub cleanFormatting 'Не должно быть символов табуляции AskAndReplace("\t","") 'Не должно быть подряд больше одного пробела AskAndReplace("(?<=[:space:])[:space:]+","") 'Не должно быть ни одного пробела в начале абзацев AskAndReplace("^[:space:]+","") 'Не должно быть пустых абзацев AskAndReplace("^$","") convertFormattingToUserFields convertFontsToCharStyles() replaceBaseWithStandard() resetFootnotesStyle removeDirectFormatting() saveAndreload() convertUserFieldsToFormatting End Sub Private Sub fixTableWidth() Dim table As Object Dim tables As Object Dim count As Long Dim i As Long tables = ThisComponent.TextTables count = ThisComponent.TextTables.getCount() For i = 0 To count - 1 table = tables.getByIndex(i) If table.HoriOrient = 6 Then table.HoriOrient = 2 EndIf If table.RelativeWidth = 0 Then table.RelativeWidth = 100 EndIf Next End Sub Private Sub fixDrawingAnchors() Dim drawing As Object Dim drawings As Object drawings = ThisComponent.DrawPage Dim count As Long Dim i As Long count = drawings.getCount() For i = 0 To count - 1 drawing = drawings.getByIndex(i) If drawing.AnchorType= com.sun.star.text.TextContentAnchorType.AT_PAGE Then drawing.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PARAGRAPH EndIf Next End Sub Private Sub replaceBaseWithStandard replaceParaStyle("Базовый","Основной текст") replaceParaStyle("Default Style","Text Body") resetSearchSettings() End Sub Private Sub replaceParaStyle(oldStyleName,newStyleName) Dim document as Object Dim dispatcher as object document = ThisComponent.CurrentController.Frame dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") Dim args1(21) as new com.sun.star.beans.PropertyValue args1(0).Name = "SearchItem.StyleFamily" args1(0).Value = 2 args1(1).Name = "SearchItem.CellType" args1(1).Value = 0 args1(2).Name = "SearchItem.RowDirection" args1(2).Value = true args1(3).Name = "SearchItem.AllTables" args1(3).Value = false args1(4).Name = "SearchItem.SearchFiltered" args1(4).Value = false args1(5).Name = "SearchItem.Backward" args1(5).Value = false args1(6).Name = "SearchItem.Pattern" args1(6).Value = true args1(7).Name = "SearchItem.Content" args1(7).Value = false args1(8).Name = "SearchItem.AsianOptions" args1(8).Value = false args1(9).Name = "SearchItem.AlgorithmType" args1(9).Value = 0 args1(10).Name = "SearchItem.SearchFlags" args1(10).Value = 65536 args1(11).Name = "SearchItem.SearchString" args1(11).Value = oldStyleName args1(12).Name = "SearchItem.ReplaceString" args1(12).Value = newStyleName args1(13).Name = "SearchItem.Locale" args1(13).Value = 255 args1(14).Name = "SearchItem.ChangedChars" args1(14).Value = 2 args1(15).Name = "SearchItem.DeletedChars" args1(15).Value = 2 args1(16).Name = "SearchItem.InsertedChars" args1(16).Value = 2 args1(17).Name = "SearchItem.TransliterateFlags" args1(17).Value = 1280 args1(18).Name = "SearchItem.Command" args1(18).Value = 3 args1(19).Name = "SearchItem.SearchFormatted" args1(19).Value = false args1(20).Name = "SearchItem.AlgorithmType2" args1(20).Value = 1 args1(21).Name = "Quiet" args1(21).Value = true dispatcher.executeDispatch(document, ".uno:ExecuteSearch", "", 0, args1()) End Sub Private Sub resetSearchSettings() Dim document as Object Dim dispatcher as object document = ThisComponent.CurrentController.Frame dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") dim args3(21) as new com.sun.star.beans.PropertyValue args3(0).Name = "SearchItem.StyleFamily" args3(0).Value = 2 args3(1).Name = "SearchItem.CellType" args3(1).Value = 0 args3(2).Name = "SearchItem.RowDirection" args3(2).Value = true args3(3).Name = "SearchItem.AllTables" args3(3).Value = false args3(4).Name = "SearchItem.SearchFiltered" args3(4).Value = false args3(5).Name = "SearchItem.Backward" args3(5).Value = false args3(6).Name = "SearchItem.Pattern" args3(6).Value = false args3(7).Name = "SearchItem.Content" args3(7).Value = false args3(8).Name = "SearchItem.AsianOptions" args3(8).Value = false args3(9).Name = "SearchItem.AlgorithmType" args3(9).Value = 0 args3(10).Name = "SearchItem.SearchFlags" args3(10).Value = 65536 args3(11).Name = "SearchItem.SearchString" args3(11).Value = "" args3(12).Name = "SearchItem.ReplaceString" args3(12).Value = "" args3(13).Name = "SearchItem.Locale" args3(13).Value = 255 args3(14).Name = "SearchItem.ChangedChars" args3(14).Value = 2 args3(15).Name = "SearchItem.DeletedChars" args3(15).Value = 2 args3(16).Name = "SearchItem.InsertedChars" args3(16).Value = 2 args3(17).Name = "SearchItem.TransliterateFlags" args3(17).Value = 1280 args3(18).Name = "SearchItem.Command" args3(18).Value = 3 args3(19).Name = "SearchItem.SearchFormatted" args3(19).Value = false args3(20).Name = "SearchItem.AlgorithmType2" args3(20).Value = 1 args3(21).Name = "Quiet" args3(21).Value = true dispatcher.executeDispatch(document, ".uno:ExecuteSearch", "", 0, args3()) End Sub Private Sub doNotTrack Dim dispatcher As Object Dim document As Object Dim trackProperties(0) as new com.sun.star.beans.PropertyValue Dim args1(0) as new com.sun.star.beans.PropertyValue dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") document = ThisComponent.CurrentController.Frame trackProperties(0).Name = "TrackChanges" trackProperties(0).Value = false dispatcher.executeDispatch(document, ".uno:TrackChanges", "", 0, trackProperties()) args1(0).Name = "ShowTrackedChanges" args1(0).Value = true dispatcher.executeDispatch(document, ".uno:ShowTrackedChanges", "", 0, args1()) End Sub Private Sub removeDirectFormatting Dim oDescriptor As Object Dim dispatcher as Object Dim document as Object Dim x As Integer Dim endNotes As Object Dim aNote As Object Dim endNoteText As Object Dim oViewCursor As Object Dim oTextCursor As Object Dim footNotes As Object dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") document = ThisComponent.CurrentController.Frame oViewCursor = ThisComponent.CurrentController.getViewCursor() oViewCursor.jumpToFirstPage() oViewCursor.gotoStart(false) oViewCursor.gotoEnd(true) dispatcher.executeDispatch(document, ".uno:ResetAttributes", "", 0, Array()) footNotes = thisComponent.Footnotes For x = 0 to footNotes.Count -1 aNote = footNotes.getByIndex(x) footNoteText = aNote.getText() oTextcursor = footNoteText.createTextCursor() oViewCursor.gotoRange(oTextcursor.getStart(),false) oViewCursor.gotoEnd(true) dispatcher.executeDispatch(document, ".uno:ResetAttributes", "", 0, Array()) Next endNotes = thisComponent.Endnotes for x = 0 to endNotes.Count -1 aNote = endNotes.getByIndex(x) endNoteText = aNote.getText() oTextcursor = endNoteText.createTextCursor() oViewCursor.gotoRange(oTextcursor.getStart(),false) oViewCursor.gotoEnd(true) dispatcher.executeDispatch(document, ".uno:ResetAttributes", "", 0, Array()) next oViewCursor.gotoStart(false) End Sub Private Sub resetFootnotesStyle Dim oDescriptor As Object Dim dispatcher as Object Dim document As Object Dim oViewCursor As Object Dim allNotes As Object Dim x As Integer Dim aNote As Object Dim oEnum As Object Dim oCurPar As Object dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") document = ThisComponent.CurrentController.Frame oViewCursor = ThisComponent.CurrentController.getViewCursor() allNotes= thisComponent.FootNotes for x = 0 to allNotes.Count -1 aNote = allNotes.getByIndex(x) aNote.Anchor.CharStyleName="Footnote anchor" oEnum = aNote.Text.createEnumeration() Do While oEnum.hasMoreElements() oCurPar = oEnum.nextElement() oCurPar.ParaStyleName = "Footnote" Loop Next End Sub Private Sub removeUnusedStyles Dim sElements() as String Dim oFamilies As Object Dim oFamily As Object Dim i As Integer Dim oDoc as object oDoc = ThisComponent oFamilies = thiscomponent.StyleFamilies sElements() = oFamilies.getElementNames() For i = 0 to uBound(sElements()) -2 oFamily = oFamilies.getByName(sElements(i)) removeUnusedStyle(oFamily,sElements(i),True) Next End Sub Private Sub removeUnusedStyle(oFamily ,sFamily as string, bAsk as Boolean) Dim i As Integer Dim sUsed() as String sUsed() = getStyleNames(oFamily,bLocalized:=True,bUsed:=False,bUserDef:=true) If uBound(sUsed()) > -1 then For i = 0 to uBound(sUsed()) oFamily.removeByName(sUsed(i)) Next EndIf End Sub Private Sub convertFormatToEnclosure(identifier As String, styleNames, styleValues) Dim leftEnclosure As String Dim rightEnclosure As String Dim oTextCursor As Object Dim startTextRange As Object Dim endTextRange As Object Dim foundString As String Dim SDesc As Object Dim SrchAttributes(Ubound(styleNames)) as new com.sun.star.beans.PropertyValue Dim i As Integer Dim found As Object leftEnclosure = compileLeftEnclosure(identifier) rightEnclosure = compileRightEnclosure(identifier) For i = 0 To Ubound(styleNames) SrchAttributes(i).Name = styleNames(i) SrchAttributes(i).Value = styleValues(i) Next i SDesc = Thiscomponent.createSearchDescriptor() SDesc.SearchAll = true SDesc.SearchRegularExpression = true SDesc.SearchString = "" SDesc.searchStyles = false SDesc.SetSearchAttributes(SrchAttributes) found = Thiscomponent.findFirst(SDesc) Do While not isNull(found) oTextCursor = found.Text.createTextCursor() oTextCursor.goToRange(found.Start, false) oTextCursor.goToRange(found.End, true) For i = 0 To Ubound(styleNames) oTextCursor.setPropertyToDefault(styleNames(i)) Next i foundString = found.getString() If Len(foundString) <> 0 Then oTextCursor.collapseToEnd() oTextCursor.String = rightEnclosure endTextRange = oTextCursor.getEnd() oTextCursor.goToRange(found.start,false) oTextCursor.String = leftEnclosure EndIf found = Thiscomponent.findNext(found.End, SDesc) Loop End Sub Private Sub convertEnclosuresToFormat(identifier As String, styleNames, styleValues) Dim oTextCursor As Object Dim startTextRange As Object Dim endTextRange As Object Dim leftEnclosure As String Dim rightEnclosure As String Dim SDesc As Object Dim found As Object leftEnclosure = compileLeftEnclosure(identifier) rightEnclosure = compileRightEnclosure(identifier) SDesc = Thiscomponent.createSearchDescriptor() SDesc.SearchAll = true SDesc.SearchRegularExpression = true SDesc.SearchString = leftEnclosure + "([^" + identifier+ "]*)" + rightEnclosure found = Thiscomponent.findFirst(SDesc) Do While not isNull(found) oTextCursor = found.Text.createTextCursor() oTextCursor.goToRange(found.Start, false) oTextCursor.goToRange(found.End, true) oTextCursor.setPropertyValues(styleNames, styleValues) oTextCursor.collapseToEnd() oTextCursor.goLeft(Len(rightEnclosure), true) oTextCursor.String = "" endTextRange = oTextCursor.getEnd() oTextCursor.goToRange(found.start,false) oTextCursor.goRight(Len(leftEnclosure), true) oTextCursor.String = "" found = Thiscomponent.findNext(endTextRange, SDesc) Loop End Sub Private Function compileSearchString(identifier) As String compileSearchString = "<" & identifier & ">" & "(.*?)" & "</" & identifier & ">" End Function Private Function compileLeftEnclosure(identifier) As String compileLeftEnclosure = "<" & identifier & ">" End Function Private Function compileRightEnclosure(identifier) As String compileRightEnclosure = "</" & identifier & ">" End Function Private Sub toTextBold Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharWeight") styleValues = Array(com.sun.star.awt.FontWeight.BOLD) convertFormatToEnclosure(CHR(867), styleNames, styleValues) End Sub Private Sub fromTextBold Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharWeight") styleValues = Array(com.sun.star.awt.FontWeight.BOLD) convertEnclosuresToFormat(CHR(867), styleNames, styleValues) End Sub Private Sub toTextItalic Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharPosture") styleValues = Array(com.sun.star.awt.FontSlant.ITALIC) convertFormatToEnclosure(CHR(868), styleNames, styleValues) End Sub Private Sub fromTextItalic Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharPosture") styleValues = Array(com.sun.star.awt.FontSlant.ITALIC) convertEnclosuresToFormat(CHR(868), styleNames, styleValues) End Sub Private Sub toTextStrikeout Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharStrikeout") styleValues = Array(com.sun.star.awt.FontStrikeout.SINGLE) convertFormatToEnclosure(CHR(869), styleNames, styleValues) End Sub Private Sub fromTextStrikeout Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharStrikeout") styleValues = Array(com.sun.star.awt.FontStrikeout.SINGLE) convertEnclosuresToFormat(CHR(869), styleNames, styleValues) End Sub Private Sub toTextUnderline Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharUnderline") styleValues = Array(com.sun.star.awt.FontUnderline.SINGLE) convertFormatToEnclosure(CHR(870), styleNames, styleValues) End Sub Private Sub fromTextUnderline Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharUnderline") styleValues = Array(com.sun.star.awt.FontUnderline.SINGLE) convertEnclosuresToFormat(CHR(870), styleNames, styleValues) End Sub Private Sub toTextSuperscript Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,14000) convertFormatToEnclosure(CHR(871), styleNames, styleValues) End Sub Private Sub fromTextSuperscript Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,14000) convertEnclosuresToFormat(CHR(871), styleNames, styleValues) End Sub Private Sub toTextSubscript Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,-14000) convertFormatToEnclosure(CHR(872), styleNames, styleValues) End Sub Private Sub fromTextSubscript Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,-14000) convertEnclosuresToFormat(CHR(872), styleNames, styleValues) End Sub Private Sub toTextSuperscriptOld Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,101) convertFormatToEnclosure(CHR(871), styleNames, styleValues) End Sub Private Sub fromTextSuperscriptOld Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,101) convertEnclosuresToFormat(CHR(871), styleNames, styleValues) End Sub Private Sub toTextSubscriptOld Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,-101) convertFormatToEnclosure(CHR(872), styleNames, styleValues) End Sub Private Sub fromTextSubscriptOld Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,-101) convertEnclosuresToFormat(CHR(872), styleNames, styleValues) End Sub Private Sub toTextSparce Dim i As Integer Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharKerning") For i=70 To 70 styleValues = Array(i) convertFormatToEnclosure(CHR(873) & i, styleNames, styleValues) Next End Sub Private Sub fromTextSparce Dim i As Integer Dim styleNames As Variant Dim StyleValues As Variant styleNames = Array("CharKerning") For i=70 To 70 styleValues = Array(i) convertEnclosuresToFormat(CHR(873) & i, styleNames, styleValues) Next End Sub Private Function confirm(description) As Boolean If MsgBox (description, 4) =6 Then confirm = true Else confirm = false EndIf End Function Private Sub ReplaceFormatting(SearchString As String ,oReplaceString As String ,SrchAttributes,ReplAttributes, searchStyles) Dim oReplace As Object oReplace = ThisComponent.createReplaceDescriptor() oReplace.SearchString = SearchString oReplace.ReplaceString = oReplaceString oReplace.SearchRegularExpression=True oReplace.SearchCaseSensitive = True oReplace.searchAll=True If Not IsEmpty(SrchAttributes(0).Value) Then oReplace.SetSearchAttributes(SrchAttributes()) oReplace.searchStyles = searchStyles End If If Not IsEmpty(ReplAttributes(0).Value) Then oReplace.SetReplaceAttributes(ReplAttributes()) End If ThisComponent.replaceAll(oReplace) End Sub Private Function getStyleNames(oFamily,bLocalized as Boolean, optional bUsed, optional bUserDef) Dim oStyle As Object Dim i As Long Dim sNames() As Variant Dim sName As String Dim chkUse as Boolean Dim chkUDef as Boolean For i = 0 to oFamily.getCount -1 oStyle = oFamily.getByIndex(i) If bLocalized then sName = oStyle.DisplayName Else sName = oStyle.getName Endif If (vartype(bUsed) = 11)then chkUse = (bUsed EQV oStyle.isInUse) Else chkUse = True Endif If (vartype(bUserDef) = 11) then chkUDef = (bUserDef EQV oStyle.isUserDefined) Else chkUDef = True EndIf If sName = "Автор" Or sName = "Автор по-английски" Or sName = "Ключевые слова" Or sName = "Текст списка литературы" Or sName = "Эпиграф" or sName = "Цитирование" or sName = "Сведения об авторе" or sName = "Аннотация" Then chkUse = False Endif If chkUse AND chkUDef then bas_Pusharray sNames(),sName Endif Next getStyleNames = sNames() End Function Sub bas_PushArray(xArray(),vNextElement) Dim iUB As Long Dim iLB As Long iLB = lBound(xArray()) iUB = uBound(xArray()) If iLB > iUB then iUB = iLB redim xArray(iLB To iUB) Else iUB = iUB +1 redim preserve xArray(iLB To iUB) Endif xArray(iUB) = vNextElement End Sub Private Sub replaceWhiteBackgroundWithTransparent Dim description As String Dim searchPattern As String Dim SrchAttributes(1) as new com.sun.star.beans.PropertyValue Dim ReplAttributes(1) as new com.sun.star.beans.PropertyValue Dim statusIndicator As Object searchPattern = "" statusIndicator = ThisComponent.getCurrentController.statusIndicator statusIndicator.Start("Замена белого фона на прозрачный начата",100) SrchAttributes(0).Name = "CharBackTransparent" SrchAttributes(0).Value = False SrchAttributes(1).Name = "CharBackColor" SrchAttributes(1).Value = 16777215 ReplAttributes(0).Name = "CharBackTransparent" ReplAttributes(0).Value = True ReplAttributes(1).Name = "CharBackColor" ReplAttributes(1).Value = -1 setAttributesBySearchPattern(searchPattern,ReplAttributes,SrchAttributes) statusIndicator.end() End Sub Private Sub convertWLLatin2IPHAstra Dim newFontName As String Dim oSearchString As String Dim oReplaceString As String 'newFontName = "IPH Astra Serif" Dim SrchAttributes(0) as new com.sun.star.beans.PropertyValue Dim ReplAttributes(0) as new com.sun.star.beans.PropertyValue SrchAttributes(0).Name = "CharFontName" 'SrchAttributes(0).Value = "WL LatinAllIn1Goth" ReplAttributes(0).Name = "CharFontName" 'ReplAttributes(0).Value = newFontName SrchAttributes(0).Value = Empty ReplAttributes(0).Value = Empty 'Replace macron below oSearchString = "(.)\uF0D4" oReplaceString = "$1̱" 'from WL ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false) oSearchString = "(.)\u0331" 'from unicode to remove direct formatting ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false) 'Replace dot below oSearchString = "(.)\uF0D6" oReplaceString = "$1̣" 'from WL ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false) 'from unicode to remove direct formatting oSearchString = "(.)\u0323" ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false) 'replace macron oSearchString = "(.)\uF0F4" oReplaceString = "$1̄" 'from WL ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false) 'from unicode to remove direct formatting oSearchString = "(.)\u0304" ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false) 'replace accent oSearchString = "(.)\uF0F1" oReplaceString = "$1́" ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false) 'from unicode to remove direct formatting oSearchString = "(.)\u0341" ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false) replaceFontsInStyles( "WL LatinAllIn1Goth", newFontName) End Sub Function getVersion As String GlobalScope.BasicLibraries.LoadLibrary("Tools") Dim oProduct As Object oProduct=GetRegistryKeyContent("org.openoffice.Setup/Product") getVersion=oProduct.getByName("ooSetupVersion") End Function Private Sub convertFormatToUserFields(identifier As String, styleNames, styleValues) Dim leftField As String Dim rightField As String Dim i As Integer Dim found As Object leftField = "left" & identifier rightField = "right" & identifier Dim SrchAttributes(Ubound(styleNames)) as new com.sun.star.beans.PropertyValue For i = Lbound(styleNames) To Ubound(styleNames) SrchAttributes(i).Name = styleNames(i) Next i For i = Lbound(styleValues) To Ubound(styleValues) SrchAttributes(i).Value = styleValues(i) Next i SDesc = Thiscomponent.createSearchDescriptor() SDesc.SearchAll = true SDesc.SearchRegularExpression = true SDesc.SearchString = "" SDesc.searchStyles = true SDesc.SetSearchAttributes(SrchAttributes) found = Thiscomponent.findFirst(SDesc) i = 0 Do While not isNull(found) If Len(found.String) <> 0 AND NOT IsNull(found.Text) Then insertUserField(found.End,rightField & i,"") insertUserField(found.start,leftField & i,"") i = i + 1 EndIf found = Thiscomponent.findNext(found.End, SDesc) Loop End Sub Private Sub convertUserFieldsToFormat(identifier As String, styleNames , styleValues) Dim oTextCursor As Object Dim oMasters As Object Dim endTextRange As Object Dim leftFieldName As String Dim rightFieldName As String Dim leftFieldMaster As Object Dim rightFieldMaster As Object Dim leftField As Object Dim rightField As Object Dim leftAnchor As Object Dim rightAnchor As Object Dim i As Integer oMasters = ThisComponent.getTextFieldMasters() i = 0 Do leftFieldName = "com.sun.star.text.FieldMaster.User" & "." & "left" & identifier & i rightFieldName = "com.sun.star.text.FieldMaster.User" & "." & "right" & identifier & i If oMasters.hasByName(leftFieldName) AND oMasters.hasByName(rightFieldName) Then i=i+1 leftFieldMaster = oMasters.getByName(leftFieldName) leftField = leftFieldMaster.DependentTextFields(0) leftAnchor = leftField.getAnchor() rightFieldMaster = oMasters.getByName(rightFieldName) rightField = rightFieldMaster.DependentTextFields(0) rightAnchor = rightField.getAnchor() oTextCursor = leftAnchor.Text.createTextCursor() oTextCursor.goToRange(leftAnchor.Start, false) oTextCursor.goToRange(rightAnchor.End, true) oTextCursor.setPropertyValues(styleNames, styleValues) leftField.dispose() leftFieldMaster.dispose() rightField.dispose() rightFieldMaster.dispose() Else Exit sub EndIf Loop End Sub Private Sub formatToUserFieldsBold Dim styleValues(0) As Integer Dim styleNames(0) As String styleNames = Array("CharWeight") styleValues = Array(com.sun.star.awt.FontWeight.BOLD) convertFormatToUserFields("Bold", styleNames, styleValues) End Sub Private Sub userFieldsToFormatBold Dim styleValues(0) As Integer Dim styleNames(0) As String styleNames = Array("CharWeight") styleValues = Array(com.sun.star.awt.FontWeight.BOLD) convertUserFieldsToFormat("Bold", styleNames, styleValues) End Sub Private Sub formatToUserFieldsItalic Dim styleValues(0) As Integer Dim styleNames(0) As String styleNames = Array("CharPosture") styleValues = Array(com.sun.star.awt.FontSlant.ITALIC) convertFormatToUserFields("Italic", styleNames, styleValues) End Sub Private Sub userFieldsToFormatItalic Dim styleValues(0) As Integer Dim styleNames(0) As String styleNames = Array("CharPosture") styleValues = Array(com.sun.star.awt.FontSlant.ITALIC) convertUserFieldsToFormat("Italic", styleNames, styleValues) End Sub Private Sub formatToUserFieldsStrikeout Dim styleValues(0) As Integer Dim styleNames(0) As String styleNames = Array("CharStrikeout") styleValues = Array(com.sun.star.awt.FontStrikeout.SINGLE) convertFormatToUserFields("StrikeOut", styleNames, styleValues) End Sub Private Sub userFieldsToFormatStrikeout Dim styleValues(0) As Integer Dim styleNames(0) As String styleNames = Array("CharStrikeout") styleValues = Array(com.sun.star.awt.FontStrikeout.SINGLE) convertUserFieldsToFormat("StrikeOut", styleNames, styleValues) End Sub Private Sub formatToUserFieldsUnderline Dim styleValues(0) As Integer Dim styleNames(0) As String styleNames = Array("CharUnderline") styleValues = Array(com.sun.star.awt.FontUnderline.SINGLE) convertFormatToUserFields("UnderLine", styleNames, styleValues) End Sub Private Sub userFieldsToFormatUnderline Dim styleValues(0) As Integer Dim styleNames(0) As String styleNames = Array("CharUnderline") styleValues = Array(com.sun.star.awt.FontUnderline.SINGLE) convertUserFieldsToFormat("UnderLine", styleNames, styleValues) End Sub Private Sub formatToUserFieldsSuperscript Dim styleValues(1) As Integer Dim styleNames(1) As String styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,14000) convertFormatToUserFields("SuperScript", styleNames, styleValues) End Sub Private Sub userFieldsToFormatSuperscript Dim styleValues(1) As Integer Dim styleNames(1) As String styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,14000) convertUserFieldsToFormat("SuperScript", styleNames, styleValues) End Sub Private Sub formatToUserFieldsSubscript Dim styleValues(1) As Integer Dim styleNames(1) As String styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,-14000) convertFormatToUserFields("SubScript", styleNames, styleValues) End Sub Private Sub userFieldsToFormatSubscript Dim styleValues(1) As Integer Dim styleNames(1) As String styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,-14000) convertUserFieldsToFormat("SubScript", styleNames, styleValues) End Sub Private Sub formatToUserFieldsSuperscriptOld Dim styleValues(1) As Integer Dim styleNames(1) As String styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,101) convertFormatToUserFields("SuperScript", styleNames, styleValues) End Sub Private Sub userFieldsToFormatSuperscriptOld Dim styleValues(1) As Integer Dim styleNames(1) As String styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,101) convertUserFieldsToFormat("SuperScript", styleNames, styleValues) End Sub Private Sub formatToUserFieldsSubscriptOld Dim styleValues(1) As Integer Dim styleNames(1) As String styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,-101) convertFormatToUserFields("SubScript", styleNames, styleValues) End Sub Private Sub userFieldsToFormatSubscriptOld Dim styleValues(1) As Integer Dim styleNames(1) As String styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,-101) convertUserFieldsToFormat("SubScript", styleNames, styleValues) End Sub Private Sub formatToUserFieldsSparce Dim i As Integer Dim styleValues(0) As Integer Dim styleNames(0) As String styleNames = Array("CharKerning") i = 18 styleValues = Array(i) convertFormatToUserFields(i & "Kerning" , styleNames, styleValues) i = 35 styleValues = Array(i) convertFormatToUserFields(i & "Kerning" , styleNames, styleValues) i = 53 styleValues = Array(i) convertFormatToUserFields(i & "Kerning" , styleNames, styleValues) i = 70 styleValues = Array(i) convertFormatToUserFields(i & "Kerning" , styleNames, styleValues) End Sub Private Sub userFieldsToFormatSparce Dim i As Integer Dim styleValues(0) As Integer Dim styleNames(0) As String styleNames = Array("CharKerning") i = 18 styleValues = Array(i) convertUserFieldsToFormat(i & "Kerning", styleNames, styleValues) i = 35 styleValues = Array(i) convertUserFieldsToFormat(i & "Kerning", styleNames, styleValues) i = 53 styleValues = Array(i) convertUserFieldsToFormat(i & "Kerning", styleNames, styleValues) i = 70 styleValues = Array(i) convertUserFieldsToFormat(i & "Kerning", styleNames, styleValues) End Sub Private Sub convertFormattingToText Dim version As String Dim smallNum As String Dim bigNum As String version = Trim(getVersion()) bigNum = Left(version, 1) smallNum = Right(version, 1) toTextBold() toTextItalic() toTextStrikeout() toTextUnderline() If CInt(bigNum) < 6 OR (CInt(bigNum) = 6 AND CInt(smallNum < 3) ) Then toTextSuperscriptOld() toTextSubscriptOld() Else toTextSuperscript() toTextSubscript() EndIf toTextSparce() End Sub Private Sub convertFormattingToUserFields Dim version As String Dim smallNum As String Dim bigNum As String version = Trim(getVersion()) bigNum = Left(version, 1) smallNum = Right(version, 1) formatToUserFieldsBold formatToUserFieldsItalic formatToUserFieldsStrikeout formatToUserFieldsUnderline If CInt(bigNum) < 6 OR (CInt(bigNum) = 6 AND CInt(smallNum < 3) ) Then formatToUserFieldsSuperscriptOld formatToUserFieldsSubscriptOld Else formatToUserFieldsSuperscript formatToUserFieldsSubscript EndIf formatToUserFieldsSparce End Sub Private Sub convertFormattingFromText Dim version As String version = Trim(getVersion()) Dim smallNum As String Dim bigNum As String version = Trim(getVersion()) bigNum = Left(version, 1) smallNum = Right(version, 1) fromTextSparce() If CInt(bigNum) < 6 OR (CInt(bigNum) = 6 AND CInt(smallNum < 3) ) Then fromTextSuperscriptOld() fromTextSubscriptOld() Else fromTextSuperscript() fromTextSubscript() EndIf fromTextUnderline() fromTextStrikeout() fromTextItalic() fromTextBold() End Sub Private Sub convertUserFieldsToFormatting Dim version As String version = Trim(getVersion()) Dim smallNum As String Dim bigNum As String version = Trim(getVersion()) bigNum = Left(version, 1) smallNum = Right(version, 1) userFieldsToFormatSparce If CInt(bigNum) < 6 OR (CInt(bigNum) = 6 AND CInt(smallNum < 3) ) Then userFieldsToFormatSuperscriptOld userFieldsToFormatSubscriptOld Else userFieldsToFormatSuperscript userFieldsToFormatSubscript EndIf userFieldsToFormatUnderline userFieldsToFormatStrikeout userFieldsToFormatItalic userFieldsToFormatBold End Sub Private Function insertUserField(cursor As Object,fieldName As String,fieldValue As String) Dim oField As Object 'Field to insert Dim oFieldMaster As Object Dim oMasters As Object oField = ThisComponent.createInstance("com.sun.star.text.textfield.User") oMasters = ThisComponent.getTextFieldMasters() If oMasters.hasByName("com.sun.star.text.FieldMaster.User" & "." & fieldName) Then oFieldMaster = oMasters.getByName("com.sun.star.text.FieldMaster.User" & "." & fieldName) oFieldMaster.Name = fieldName oFieldMaster.Content = fieldValue Else oFieldMaster = ThisComponent.createInstance("com.sun.star.text.FieldMaster.User") oFieldMaster.Name = fieldName oFieldMaster.Content = fieldValue EndIf oField.attachTextFieldMaster(oFieldMaster) cursor.Text.insertTextContent(cursor, oField, False) oField.IsVisible = false End Function sub saveAsDocAndBackToODT dim document as object dim dispatcher as object Dim path As String Dim tmpName As String Dim oldName As String document = ThisComponent.CurrentController.Frame dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") oldName = ThisComponent.getURL() tmpName = oldName & "--tmp" & ".doc" dim args1(1) as new com.sun.star.beans.PropertyValue args1(0).Name = "URL" args1(0).Value = tmpName args1(1).Name = "FilterName" args1(1).Value = "MS Word 97" dispatcher.executeDispatch(document, ".uno:SaveAs", "", 0, args1()) dispatcher.executeDispatch(document, ".uno:Reload", "", 0, Array()) args1(0).Value = oldName args1(1).Value = "writer8" dispatcher.executeDispatch(document, ".uno:SaveAs", "", 0, args1()) dispatcher.executeDispatch(document, ".uno:Reload", "", 0, Array()) If FileExists(tmpName) Then Kill(tmpName) End If end Sub Sub addTimeStampToProperties Dim docProps As Object Dim userProps As Object Dim curTime As String On Error Goto exceptionHandlerProps curTime = Now() docProps = ThisComponent.getDocumentProperties() userProps = docProps.UserDefinedProperties() userProps.addProperty(curTime ,128,"Cleaned " & redactionExtensionVersion) exceptionHandlerProps: Resume Next End Sub sub saveCleanedVersion(comment) dim document as object dim dispatcher as object document = ThisComponent.CurrentController.Frame dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") dim args1(0) as new com.sun.star.beans.PropertyValue args1(0).Name = "VersionComment" args1(0).Value = comment dispatcher.executeDispatch(document, ".uno:Save", "", 0, args1()) end sub