Sub mark21 End Sub Sub cleanButton Dim description As String Dim statusIndicator as Object statusIndicator = ThisComponent.getCurrentController.statusIndicator description = "Вы уверены, что хотите выполнить чистку документа?" If NOT confirm(description) Then Exit Sub EndIf saveDocument statusIndicator.Start("Чистка документа начата, подождите",100) doNotTrack statusIndicator.Start("Заменяем шрифты в стилях",100) replaceStyleFonts statusIndicator.Start("Конвертируем символы в целевые шрифты",100) unicodeSymbolsConversion statusIndicator.Start("Чистим ручное форматирование",100) cleanFormatting statusIndicator.Start("Удаляем гиперссылки",100) removeHyperlinks statusIndicator.Start("Удаляем закладки",100) disposeAllBookmarks statusIndicator.Start("Настраиваем таблицы",100) fixTableWidth statusIndicator.Start("Настраиваем привязку изображений",100) fixDrawingAnchors statusIndicator.Start("Исправляем часто встречающиеся ошибки",100) fixFrequentMistakes statusIndicator.Start("Удаляем разрыв страницы, если он задан в начале документа",100) removeFirstElementPageBreak statusIndicator.Start("Удаляем пользовательские стили страниц",100) removeUserPageStyles statusIndicator.Start("Загружаем стили из шаблона",100) loadArticleStyles statusIndicator.end() saveAndreload() MsgBox "Чистка завершена." End Sub Private Sub removeFirstElementPageBreak 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,newFontName) ' Substitutes font names starts with oldFont value with newFont value Dim oDoc as Object Dim propertySetInfo As Object Dim oPositionOfMatch As Long oDoc = ThisComponent 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("[\u2100-\u214f\u0020-\u007f\u0080-\u00ff\u0400-\u04ff\u2000-\u206f\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) End Sub Private Sub unicodeConversionEverywhere(searchPattern,rAtts) 'in text setAttributesBySearchPattern(searchPattern,RAtts) End Sub 'Replaces manual formatting text with font into character style with assigned font Private Sub convertFontsToCharStyles Dim oDoc oDoc = Thiscomponent Dim srch(0) as new com.sun.star.beans.PropertyValue 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 oStyles = ThisComponent.StyleFamilies.getByName("PageStyles") Dim count As Long 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 NBSP As String Dim space As String NBSP = " " space = " " 'Не должно быть символов табуляции AskAndReplace("\t","") 'Не должно быть подряд больше одного пробела AskAndReplace("(?<=[:space:])[:space:]+","") 'Не должно быть ни одного пробела в начале абзацев AskAndReplace("^[:space:]+","") 'Не должно быть пробелов в конце абзацев AskAndReplace("[:space:]+$","") 'Не должно быть пустых абзацев AskAndReplace("^$","") 'Не должно быть пробелов перед знаками пунктуации .,;:?!)]}»¡¿”‘’ AskAndReplace("[:space:]+(?=[\.,;:?!\)\]\}»¡¿”‘’])","") 'Между словом том и цифрой должен быть неразрывный пробел, а не обычный AskAndReplace("(?<=\b[тТ](ом|\.))\ (?=[:digit:])",NBSP) 'Между словом серия и цифрой должен быть неразрывный пробел, а не обычный AskAndReplace("(?<=\b[сС](ерия|\.))\ +(?=[:digit:])",NBSP) 'Между словом часть и цифрой должен быть неразрывный пробел, а не обычный AskAndReplace("(?<=\b[чЧ](асть|\.))\ +(?=[:digit:])",NBSP) 'Между числом и "г." должен быть неразрывный пробел, а не обычный AskAndReplace("(?<=[0-9])[:space:]*г(?=\.)",NBSP & "г") 'Между инициалами и Фамилией должен быть неразрывный пробел, а не обычный AskAndReplace("(?<=[:upper:]\.[:space:][:upper:]\.)\ (?=[:upper:][:lower:]+)",NBSP) 'Между Фамилией и инициалами должен быть неразрывный пробел, а не обычный AskAndReplace("(?<=[:upper:][:lower:]{1,30})\ (?=[:upper:]\.[:space:][:upper:]\.)",NBSP) 'Не должно быть пробелов после скобок [({ и кавычек «„ AskAndReplace("(?<=[\(\[\{«„])[:space:]","") 'Между "и" и "т." должен быть неразрывный пробел, а не обычный AskAndReplace("(?<=\bи)\ (?=т\.)",NBSP) 'Между "т." и "е./н./д./п./к." должен быть неразрывный пробел, а не обычный AskAndReplace("(?<=\bт)\.\ ?(?=[ендпк]\.)","." & NBSP) 'Между буквами среднее тире должно обрамляться пробелами 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) AskAndReplace("[ий][\u0306]+","й") AskAndReplace("[ИЙ][\u0306]+","Й") AskAndReplace("[её][\u0308]+","ё") AskAndReplace("[ЕЁ][\u0308]+","Ё") End Sub Private Sub loadArticleStyles Dim dispatcher as object Dim fileePath As String Dim fileTest As Object Dim fileName As String Dim aArgs(0) As New com.sun.star.beans.PropertyValue fileName = "Статья.ott" filePath = getTemplatePath() & "/" & fileName fileTest = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") If NOT fileTest.exists(filePath) Then MsgBox "Файл стилей " & fileName & " не добавлен в Мои шаблоны. Не могу загрузить стили в текущий файл." Exit Sub 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$, oProps()) Dim i% Dim oFamilies Dim oStyle Dim oStyles 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, oReplaceString) 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 oStyles = oDoc.StyleFamilies.getByName("CharacterStyles") DocHasCharStyle() = oStyles.hasByName(sName) End Function Private Function getTemplatePath() as String Dim ath 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 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 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 disposePageBreaks 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 Dim oTextCursor As Object Dim oViewCursor As Object Dim replace As Boolean Dim attrName As string Dim attrValue As String 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()) dispatcher.executeDispatch(document, ".uno:Reload", "", 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("^$","") convertFormattingToText convertFontsToCharStyles replaceBaseWithStandard removeDirectFormatting convertFormattingFromText resetFootnotesStyle removeUnusedStyles End Sub Private Sub fixTableWidth() Dim table As Object Dim tables As Object tables = ThisComponent.TextTables Dim count As Long 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 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") 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 doNotTrack dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") document = ThisComponent.CurrentController.Frame dim trackProperties(0) as new com.sun.star.beans.PropertyValue trackProperties(0).Name = "TrackChanges" trackProperties(0).Value = false dispatcher.executeDispatch(document, ".uno:TrackChanges", "", 0, trackProperties()) dim args1(0) as new com.sun.star.beans.PropertyValue args1(0).Name = "ShowTrackedChanges" args1(0).Value = true dispatcher.executeDispatch(document, ".uno:ShowTrackedChanges", "", 0, args1()) End Sub Private Sub removeDirectFormatting Dim oDescriptor 'The search descriptor dim dispatcher as Object dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") dim document as Object document = ThisComponent.CurrentController.Frame Dim oViewCursor As Object 'View cursor 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 'The search descriptor dim dispatcher as Object dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") dim document as Object document = ThisComponent.CurrentController.Frame Dim oViewCursor As Object 'View cursor 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 'calls: RemoveUnusedStyles Dim sElements() as string, oFamilies, oFamily, sFamily$, sLabel, oDlg, i% 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) 'calls: getStyleNames Dim sUsed() as String, sMsg$,iAnswer%, bStop as boolean 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, styleNames, styleValues) leftEnclosure = compileLeftEnclosure(identifier) rightEnclosure = compileRightEnclosure(identifier) Dim oTextCursor As Object Dim startTextRange As Object Dim endTextRange As Object Dim foundString As String Dim SrchAttributes(Ubound(styleNames)) as new com.sun.star.beans.PropertyValue 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, styleNames, styleValues) Dim oTextCursor As Object Dim startTextRange As Object Dim endTextRange As Object Dim leftEnclosure As String Dim rightEnclosure As String 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) compileSearchString = "<"+identifier+">"+"(.*?)"+"</"+identifier+">" End Function Private Function compileLeftEnclosure(identifier) compileLeftEnclosure = "<"+identifier+">" End Function Private Function compileRightEnclosure(identifier) compileRightEnclosure = "</"+identifier+">" End Function Private Sub toTextBold styleNames = Array("CharWeight") styleValues = Array(com.sun.star.awt.FontWeight.BOLD) convertFormatToEnclosure(CHR(867), styleNames, styleValues) End Sub Private Sub fromTextBold styleNames = Array("CharWeight") styleValues = Array(com.sun.star.awt.FontWeight.BOLD) convertEnclosuresToFormat(CHR(867), styleNames, styleValues) End Sub Private Sub toTextItalic styleNames = Array("CharPosture") styleValues = Array(com.sun.star.awt.FontSlant.ITALIC) convertFormatToEnclosure(CHR(868), styleNames, styleValues) End Sub Private Sub fromTextItalic styleNames = Array("CharPosture") styleValues = Array(com.sun.star.awt.FontSlant.ITALIC) convertEnclosuresToFormat(CHR(868), styleNames, styleValues) End Sub Private Sub toTextStrikeout styleNames = Array("CharStrikeout") styleValues = Array(com.sun.star.awt.FontStrikeout.SINGLE) convertFormatToEnclosure(CHR(869), styleNames, styleValues) End Sub Private Sub fromTextStrikeout styleNames = Array("CharStrikeout") styleValues = Array(com.sun.star.awt.FontStrikeout.SINGLE) convertEnclosuresToFormat(CHR(869), styleNames, styleValues) End Sub Private Sub toTextUnderline styleNames = Array("CharUnderline") styleValues = Array(com.sun.star.awt.FontUnderline.SINGLE) convertFormatToEnclosure(CHR(870), styleNames, styleValues) End Sub Private Sub fromTextUnderline styleNames = Array("CharUnderline") styleValues = Array(com.sun.star.awt.FontUnderline.SINGLE) convertEnclosuresToFormat(CHR(870), styleNames, styleValues) End Sub Private Sub toTextSuperscript styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,14000) convertFormatToEnclosure(CHR(871), styleNames, styleValues) End Sub Private Sub fromTextSuperscript styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,14000) convertEnclosuresToFormat(CHR(871), styleNames, styleValues) End Sub Private Sub toTextSubscript styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,-14000) convertFormatToEnclosure(CHR(872), styleNames, styleValues) End Sub Private Sub fromTextSubscript styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,-14000) convertEnclosuresToFormat(CHR(872), styleNames, styleValues) End Sub Private Sub toTextSuperscriptOld styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,101) convertFormatToEnclosure(CHR(871), styleNames, styleValues) End Sub Private Sub fromTextSuperscriptOld styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,101) convertEnclosuresToFormat(CHR(871), styleNames, styleValues) End Sub Private Sub toTextSubscriptOld styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,-101) convertFormatToEnclosure(CHR(872), styleNames, styleValues) End Sub Private Sub fromTextSubscriptOld styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,-101) convertEnclosuresToFormat(CHR(872), styleNames, styleValues) End Sub Private Sub toTextSparce styleNames = Array("CharKerning") For i=70 To 70 styleValues = Array(i) convertFormatToEnclosure(CHR(873) & i, styleNames, styleValues) Next End Sub Private Sub fromTextSparce styleNames = Array("CharKerning") For i=70 To 70 styleValues = Array(i) convertEnclosuresToFormat(CHR(873) & i, styleNames, styleValues) Next 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 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 Function confirm(description) If MsgBox (description, 4) =6 Then confirm = true Else confirm = false EndIf End Function Private Sub ReplaceFormatting(SearchString,oReplaceString,SrchAttributes,ReplAttributes, searchStyles) Dim oReplace 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,i%,sNames$(),sName$,chkUse as Boolean, 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 'very simple routine appending some element to an array which can be undimensioned (LBound > UBound) Sub bas_PushArray(xArray(),vNextElement) Dim iUB%,iLB% 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 convertWLLatin2IPHAstra Dim newFontName 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 GlobalScope.BasicLibraries.LoadLibrary("Tools") Dim oProduct As Object oProduct=GetRegistryKeyContent("org.openoffice.Setup/Product") getVersion=oProduct.getByName("ooSetupVersion") End Function