Sub mark3 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 doNotTrack statusIndicator.Start("Чистка документа начата, подождите",30) unicodeSymbolsConversion cleanFormatting removeHyperlinks disposeAllBookmarks fixTableWidth fixDrawingAnchors fixFrequentMistakes removeFirstElementPageBreak removeUserPageStyles loadArticleStyles statusIndicator.end() saveAndreload() 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 unicodeSymbolsConversion 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 'Cyrillic unicode block range \u0400-\u04FF 'Basic Latin \u0020-\u007E 'Combining diacritical marks 0301 0304 0323 032e 0331 035f 'General Punctuation \u2000-\u206f unicodeConversionEverywhere("[\u0400-\u04FF,\u0020-\u007E,\u2000-\u206f,\u0301,\u0304,\u0323,\u032e,\u0331,\u035f]+",RAtts) 'Arabic Scheherazade newFontName = "Scheherazade" RAtts(0).Value = newFontName RAtts(1).Value = newFontName RAtts(2).Value = newFontName unicodeConversionEverywhere("[\u0600-\u06FF]+",RAtts) 'Greek Tinos newFontName = "Tinos" RAtts(0).Value = newFontName RAtts(1).Value = newFontName RAtts(2).Value = newFontName 'Greek and Coptic unicodeConversionEverywhere("[\u0370-\u03FF]+",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 oProps() = Array(CreateProperty("CharFontName", 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) 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 statusIndicator as Object Dim aNote As Object statusIndicator = ThisComponent.getCurrentController.StatusIndicator statusIndicator.Start("Удаление гиперссылок, подождите",10) 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 statusIndicator.end() 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 lineIndent Dim replace As Boolean dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") oSearch = ThisComponent.createSearchDescriptor() oSearch.SearchString = searchPattern 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() ' Globalscope.BasicLibraries.LoadLibrary( "MRILib" ) ' Mri oViewCursor 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,101) convertFormatToEnclosure(CHR(871), styleNames, styleValues) End Sub Private Sub fromTextSuperscript styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,101) convertEnclosuresToFormat(CHR(871), styleNames, styleValues) End Sub Private Sub toTextSubscript styleNames = Array("CharEscapementHeight","CharEscapement") styleValues = Array(58,-101) convertFormatToEnclosure(CHR(872), styleNames, styleValues) End Sub Private Sub fromTextSubscript 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 toTextBold toTextItalic toTextStrikeout toTextUnderline toTextSuperscript toTextSubscript toTextSparce End Sub Private Sub convertFormattingFromText fromTextSparce fromTextSuperscript fromTextSubscript 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