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 statusIndicator.end() saveAndreload() 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 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() 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