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) cleanFormatting disposePageBreaks disposeAllLinks disposeAllBookmarks fixTableWidth fixDrawingAnchors loadArticleStyles statusIndicator.end() saveAndreload() 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 disposeAllLinks() Dim SrchAttributes(0) as new com.sun.star.beans.PropertyValue SrchAttributes(0).Name = "CharStyleName" SrchAttributes(0).Value = "Internet Link" Dim ReplAttributes(2) as new com.sun.star.beans.PropertyValue ReplAttributes(0).Name = "HyperlinkTarget" ReplAttributes(0).Value = "" ReplAttributes(1).Name = "HyperLinkURL" ReplAttributes(1).Value = "" ReplAttributes(2).Name = "CharStyleName" ReplAttributes(2).Value = ThisComponent.getStyleFamilies().getByIndex(0).ElementNames(0) setAttributesBySearchPattern(searchPattern,SrchAttributes,ReplAttributes) 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 Private Sub setAttributesBySearchPattern(searchPattern As String, SrchAttributes, ReplAttributes) Dim oSearch Dim oTextCursor As Object Dim oViewCursor As Object Dim lineIndent Dim foundPatterns() As Object document = ThisComponent.CurrentController.Frame dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") oSearch = ThisComponent.createSearchDescriptor() oSearch.SearchString = searchPattern oSearch.SearchRegularExpression=True oSearch.SearchAll = True oSearch.searchStyles = true If Not IsEmpty(SrchAttributes(0).Value) Then oSearch.SetSearchAttributes(SrchAttributes()) End If oFound = ThisComponent.findFirst(oSearch) Do While Not IsNull(oFound) For i = LBound(ReplAttributes) To Ubound(ReplAttributes) ' Globalscope.BasicLibraries.LoadLibrary( "MRILib" ) ' Mri oFound If oFound.getPropertySetInfo.hasPropertyByName(ReplAttributes(i).Name) Then oFound.SetPropertyValue(ReplAttributes(i).Name,ReplAttributes(i).Value) EndIf Next i 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("^$","") replaceBaseWithStandard convertFormattingToText manualFontsToCharStyle 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 Sub manualFontsToCharStyle 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 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) End If founds = Thiscomponent.findNext(founds.getend, SDesc) loop 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