cleanandvalidate/Redaction/Clean.xba
2020-03-05 18:25:42 +01:00

1090 lines
No EOL
40 KiB
XML
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Clean" script:language="StarBasic">Sub mark21
End Sub
Sub cleanButton
Dim description As String
Dim statusIndicator as Object
statusIndicator = ThisComponent.getCurrentController.statusIndicator
description = &quot;Вы уверены, что хотите выполнить чистку документа?&quot;
If NOT confirm(description) Then
Exit Sub
EndIf
saveDocument
statusIndicator.Start(&quot;Чистка документа начата, подождите&quot;,100)
doNotTrack
statusIndicator.Start(&quot;Заменяем шрифты в стилях&quot;,100)
replaceStyleFonts
statusIndicator.Start(&quot;Конвертируем символы в целевые шрифты&quot;,100)
unicodeSymbolsConversion
statusIndicator.Start(&quot;Чистим ручное форматирование&quot;,100)
cleanFormatting
statusIndicator.Start(&quot;Удаляем гиперссылки&quot;,100)
removeHyperlinks
statusIndicator.Start(&quot;Удаляем закладки&quot;,100)
disposeAllBookmarks
statusIndicator.Start(&quot;Настраиваем таблицы&quot;,100)
fixTableWidth
statusIndicator.Start(&quot;Настраиваем привязку изображений&quot;,100)
fixDrawingAnchors
statusIndicator.Start(&quot;Исправляем часто встречающиеся ошибки&quot;,100)
fixFrequentMistakes
statusIndicator.Start(&quot;Удаляем разрыв страницы, если он задан в начале документа&quot;,100)
removeFirstElementPageBreak
statusIndicator.Start(&quot;Удаляем пользовательские стили страниц&quot;,100)
removeUserPageStyles
statusIndicator.Start(&quot;Загружаем стили из шаблона&quot;,100)
loadArticleStyles
statusIndicator.end()
saveAndreload()
MsgBox &quot;Чистка завершена.&quot;
End Sub
Private Sub removeFirstElementPageBreak
enum1 = ThisComponent.Text.createEnumeration
If enum1.hasMoreElements Then
enum1Element = enum1.nextElement
If enum1Element.supportsService(&quot;com.sun.star.text.Paragraph&quot;) OR enum1Element.supportsService(&quot;com.sun.star.text.TextTable&quot;) Then
If enum1Element.BreakType &lt;&gt; com.sun.star.style.BreakType.NONE Then
enum1Element.PageDescName = &quot;&quot;
enum1Element.BreakType = com.sun.star.style.BreakType.NONE
EndIf
EndIf
EndIf
End Sub
Private Sub replaceStyleFonts
&apos; Globalscope.BasicLibraries.LoadLibrary( &quot;MRILib&quot; )
replaceFontsInStyles(&quot;IPH Lib Serif&quot;,&quot;IPH Astra Serif&quot;)
replaceFontsInStyles(&quot;Liberation Serif&quot;,&quot;IPH Astra Serif&quot;)
replaceFontsInStyles(&quot;PTSerif&quot;,&quot;IPH Astra Serif&quot;)
replaceFontsInStyles(&quot;PT Serif&quot;,&quot;IPH Astra Serif&quot;)
replaceFontsInStyles(&quot;ArabicD&quot;,&quot;IPH Astra Serif&quot;)
replaceFontsInStyles(&quot;Palatino Linotype Greek&quot;,&quot;Tinos&quot;)
End Sub
Private Sub replaceFontsInStyles(oldFontStart,newFontName)
&apos; 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(&quot;CharFontName&quot;) Then
fontName = oStyle.getPropertyValue(&quot;CharFontName&quot;)
oPositionOfMatch = InStr(fontName, oldFontStart)
If oPositionOfMatch = 1 Then
oStyle.CharFontName = newFontName
If propertySetInfo.hasPropertyByName(&quot;CharFontNameComplex&quot;) Then
oStyle.CharFontNameComplex = newFontName
ENdIf
If propertySetInfo.hasPropertyByName(&quot;CharFontNameAsian&quot;) Then
oStyle.CharFontNameAsian = newFontName
ENdIf
EndIf
EndIf
Next
Next
End Sub
Private Sub unicodeSymbolsConversion
convertWLLatin2IPHAstra
Dim newFontName As String
newFontName = &quot;IPH Astra Serif&quot;
Dim RAtts(2) as new com.sun.star.beans.PropertyValue
RAtts(0).Name = &quot;CharFontName&quot;
RAtts(1).Name = &quot;CharFontNameComplex&quot;
RAtts(2).Name = &quot;CharFontNameAsian&quot;
&apos;Basic Astra
RAtts(0).Value = newFontName
RAtts(1).Value = newFontName
RAtts(2).Value = newFontName
&apos;Letterlike Symbols 2100—214F
&apos;Extended latin-1 0080—00FF
&apos;Cyrillic unicode block range \u0400-\u04FF
&apos;Basic Latin \u0020-\u007E
&apos;Combining diacritical marks 0301 0304 0323 032e 0331 035f
&apos;General Punctuation \u2000-\u206f
&apos;Latin Extended A \u0100-\u017f
&apos;\u02bb Modifier Letter Turned Comma is in IPH Astra
&apos; unicodeConversionEverywhere(&quot;[\u0020-\u007F]+&quot;,RAtts)
unicodeConversionEverywhere(&quot;[\u2100-\u214f\u0020-\u007f\u0080-\u00ff\u0400-\u04ff\u2000-\u206f\u0301\u0304\u0323\u032e\u0331\u0341\u035f\u02bb\u0100-\u017f]+&quot;,RAtts)
&apos;Arabic Scheherazade
&apos;Arabic Presentation Forms-A fb50-fdff
&apos;Arabic Presentation Forms-B fe70-feff
newFontName = &quot;Scheherazade&quot;
RAtts(0).Value = newFontName
RAtts(1).Value = newFontName
RAtts(2).Value = newFontName
unicodeConversionEverywhere(&quot;[\u0600-\u06ff\ufb50-\ufdff\ufe70-\ufeff]+&quot;,RAtts)
&apos;Greek Tinos
newFontName = &quot;Tinos&quot;
RAtts(0).Value = newFontName
RAtts(1).Value = newFontName
RAtts(2).Value = newFontName
&apos;Greek and Coptic 0370—03FF
&apos;Greek extended 1F00—1FFF
unicodeConversionEverywhere(&quot;[\u0370-\u03ff\u1f00-\u1fff]+&quot;,RAtts)
&apos;DejaVu Sans Mathematical operators
newFontName = &quot;DejaVu Sans&quot;
RAtts(0).Value = newFontName
RAtts(1).Value = newFontName
RAtts(2).Value = newFontName
&apos;\u2200-\u22FF Mathematical operators
unicodeConversionEverywhere(&quot;[\u2200-\u22ff]+&quot;,RAtts)
End Sub
Private Sub unicodeConversionEverywhere(searchPattern,rAtts)
&apos;in text
setAttributesBySearchPattern(searchPattern,RAtts)
End Sub
&apos;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 = &quot;&quot;
srch(0).Name = &quot;CharFontName&quot;
SDesc.SetSearchAttributes(srch())
founds = Thiscomponent.findFirst(SDesc)
do while not isNull(founds)
curFont = founds.CharFontName
If IsEmpty(curFont) Then
curFont = &quot;IPH Astra Serif&quot;
EndIf
If curFont &lt;&gt; &quot;IPH Astra Serif&quot; AND curFont &lt;&gt; &quot;&quot; Then
If Not DocHasCharStyle(oDoc,curFont) Then
Dim oProps(2) As New com.sun.star.beans.PropertyValue
oProps(0).Name = &quot;CharFontName&quot;
oProps(1).Name = &quot;CharFontNameComplex&quot;
oProps(2).Name = &quot;CharFontNameAsian&quot;
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(&quot;PageStyles&quot;)
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
&apos;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 = &quot; &quot;
space = &quot; &quot;
&apos;Не должно быть символов табуляции
AskAndReplace(&quot;\t&quot;,&quot;&quot;)
&apos;Не должно быть подряд больше одного пробела
AskAndReplace(&quot;(?&lt;=[:space:])[:space:]+&quot;,&quot;&quot;)
&apos;Не должно быть ни одного пробела в начале абзацев
AskAndReplace(&quot;^[:space:]+&quot;,&quot;&quot;)
&apos;Не должно быть пробелов в конце абзацев
AskAndReplace(&quot;[:space:]+$&quot;,&quot;&quot;)
&apos;Не должно быть пустых абзацев
AskAndReplace(&quot;^$&quot;,&quot;&quot;)
&apos;Не должно быть пробелов перед знаками пунктуации .,;:?!)]}»¡¿”‘’
AskAndReplace(&quot;[:space:]+(?=[\.,;:?!\)\]\}»¡¿”‘’])&quot;,&quot;&quot;)
&apos;Между словом том и цифрой должен быть неразрывный пробел, а не обычный
AskAndReplace(&quot;(?&lt;=\b[тТ](ом|\.))\ (?=[:digit:])&quot;,NBSP)
&apos;Между словом серия и цифрой должен быть неразрывный пробел, а не обычный
AskAndReplace(&quot;(?&lt;=\b[сС](ерия|\.))\ +(?=[:digit:])&quot;,NBSP)
&apos;Между словом часть и цифрой должен быть неразрывный пробел, а не обычный
AskAndReplace(&quot;(?&lt;=\b[чЧ](асть|\.))\ +(?=[:digit:])&quot;,NBSP)
&apos;Между числом и &quot;г.&quot; должен быть неразрывный пробел, а не обычный
AskAndReplace(&quot;(?&lt;=[0-9])[:space:]*г(?=\.)&quot;,NBSP &amp; &quot;г&quot;)
&apos;Между инициалами и Фамилией должен быть неразрывный пробел, а не обычный
AskAndReplace(&quot;(?&lt;=[:upper:]\.[:space:][:upper:]\.)\ (?=[:upper:][:lower:]+)&quot;,NBSP)
&apos;Между Фамилией и инициалами должен быть неразрывный пробел, а не обычный
AskAndReplace(&quot;(?&lt;=[:upper:][:lower:]{1,30})\ (?=[:upper:]\.[:space:][:upper:]\.)&quot;,NBSP)
&apos;Не должно быть пробелов после скобок [({ и кавычек «„
AskAndReplace(&quot;(?&lt;=[\(\[\{«„])[:space:]&quot;,&quot;&quot;)
&apos;Между &quot;и&quot; и &quot;т.&quot; должен быть неразрывный пробел, а не обычный
AskAndReplace(&quot;(?&lt;=\bи)\ (?=т\.)&quot;,NBSP)
&apos;Между &quot;т.&quot; и &quot;е./н./д./п./к.&quot; должен быть неразрывный пробел, а не обычный
AskAndReplace(&quot;(?&lt;=\bт)\.\ ?(?=[ендпк]\.)&quot;,&quot;.&quot; &amp; NBSP)
&apos;Между буквами среднее тире должно обрамляться пробелами
AskAndReplace(&quot;(?&lt;=[:alpha:])(?=[:alpha:])&quot;,NBSP &amp; &quot;&quot; &amp; NBSP)
&apos;Между буквами дефис-минус, цифровое тире и длинное тире заменяется на среднее тире
AskAndReplace(&quot;(?&lt;=[:alpha:][:space:])[-‒—](?=[:space:][:alpha:])&quot;,&quot;&quot;)
&apos;Между двумя цифрами и тире между ними не долнжо быть пробелов. А также тире должно быть цифровым
AskAndReplace(&quot;(?&lt;=[:digit:])(?:[:space:])?[-‒–—](?:[:space:])?(?=[:digit:])&quot;,&quot;&quot;)
&apos;Между двумя римскими цифрами и тире между ними не долнжо быть пробелов. А также тире должно быть средним
AskAndReplace(&quot;(?&lt;=[MDCLXVI])(?:[:space:])?[-‒–—](?:[:space:])?(?=[MDCLXVI])&quot;,&quot;&quot;)
&apos;Между буквой и угловой открывающейся скобкой должен быть пробел
AskAndReplace(&quot;(?&lt;=[:alpha:])&lt;(?=…&gt;)&quot;,space &amp; &quot;&lt;&quot;)
&apos;Между угловой закрывающейся скобкой и буквой должен быть пробел
AskAndReplace(&quot;(?&lt;=&lt;…)&gt;(?=[:alpha:])&quot;,&quot;&gt;&quot; &amp; space)
AskAndReplace(&quot;[ий][\u0306]+&quot;,&quot;й&quot;)
AskAndReplace(&quot;[ИЙ][\u0306]+&quot;,&quot;Й&quot;)
AskAndReplace(&quot;[её][\u0308]+&quot;,&quot;ё&quot;)
AskAndReplace(&quot;[ЕЁ][\u0308]+&quot;,&quot;Ё&quot;)
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 = &quot;Статья.ott&quot;
filePath = getTemplatePath() &amp; &quot;/&quot; &amp; fileName
fileTest = CreateUnoService(&quot;com.sun.star.ucb.SimpleFileAccess&quot;)
If NOT fileTest.exists(filePath) Then
MsgBox &quot;Файл стилей &quot; &amp; fileName &amp; &quot; не добавлен в Мои шаблоны. Не могу загрузить стили в текущий файл.&quot;
Exit Sub
EndIf
dispatcher = createUnoService(&quot;com.sun.star.frame.DispatchHelper&quot;)
aArgs(0).Name = &quot;OverwriteStyles&quot;
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(&quot;CharacterStyles&quot;)
If oStyles.HasByName(sStyleName) Then
Exit Sub
End If
oStyle = ThisComponent.createInstance(&quot;com.sun.star.style.CharacterStyle&quot;)
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(&quot;CharacterStyles&quot;)
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( &quot;com.sun.star.configuration.ConfigurationProvider&quot; )
params(0).Name = &quot;nodepath&quot;
params(0).Value = &quot;/org.openoffice.Office.Paths/Paths&quot;
settings = configProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationAccess&quot;, params() )
path = settings.Template.WritePath
convService = CreateUnoService(&quot;com.sun.star.util.PathSubstitution&quot;)
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(&quot;com.sun.star.text.Paragraph&quot;) Then
removeHLInPara(enum1Element)
ElseIf enum1Element.supportsService(&quot;com.sun.star.text.TextTable&quot;) 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(&quot;HyperLinkURL&quot;) Then
enum1Element.HyperLinkURL=&quot;&quot;
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(&quot;com.sun.star.text.Paragraph&quot;) Then
If enum1Element.BreakType &lt;&gt; com.sun.star.style.BreakType.NONE Then
oTextCursor.goToRange(enum1Element.getAnchor(), false)
If NOT IsEmpty(oTextCursor.PageDescName) Then
oTextCursor.PageDescName = &quot;&quot;
End If
oTextCursor.BreakType = com.sun.star.style.BreakType.NONE
End If
ElseIf enum1Element.supportsService(&quot;com.sun.star.text.TextTable&quot;) Then
If NOT IsEmpty(enum1Element.PageDescName) Then
enum1Element.PageDescName = &quot;&quot;
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(&quot;com.sun.star.frame.DispatchHelper&quot;)
oSearch = ThisComponent.createSearchDescriptor()
oSearch.SearchString = searchPattern
&apos; 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 = &quot;&quot; &amp; oFound.getPropertyValue(SrchAttributes(j).Name)
stringValue2 = &quot;&quot; &amp; SrchAttributes(j).Value
If stringValue1 &lt;&gt; 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)
&apos;If oFound.getPropertySetInfo.hasPropertyByName(ReplAttributes(i).Name) Then
oFound.SetPropertyValue(ReplAttributes(i).Name, ReplAttributes(i).Value)
&apos;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(&quot;com.sun.star.frame.DispatchHelper&quot;)
dispatcher.executeDispatch(document, &quot;.uno:Save&quot;, &quot;&quot;, 0, Array())
dispatcher.executeDispatch(document, &quot;.uno:Reload&quot;, &quot;&quot;, 0, Array())
End Sub
Private Sub saveDocument()
dim document as object
dim dispatcher as object
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService(&quot;com.sun.star.frame.DispatchHelper&quot;)
dispatcher.executeDispatch(document, &quot;.uno:Save&quot;, &quot;&quot;, 0, Array())
end Sub
Private Sub cleanFormatting
&apos;Не должно быть символов табуляции
AskAndReplace(&quot;\t&quot;,&quot;&quot;)
&apos;Не должно быть подряд больше одного пробела
AskAndReplace(&quot;(?&lt;=[:space:])[:space:]+&quot;,&quot;&quot;)
&apos;Не должно быть ни одного пробела в начале абзацев
AskAndReplace(&quot;^[:space:]+&quot;,&quot;&quot;)
&apos;Не должно быть пустых абзацев
AskAndReplace(&quot;^$&quot;,&quot;&quot;)
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(&quot;Базовый&quot;,&quot;Основной текст&quot;)
replaceParaStyle(&quot;Default Style&quot;,&quot;Text Body&quot;)
End Sub
Private Sub replaceParaStyle(oldStyleName,newStyleName)
dim document as Object
dim dispatcher as object
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService(&quot;com.sun.star.frame.DispatchHelper&quot;)
dim args1(21) as new com.sun.star.beans.PropertyValue
args1(0).Name = &quot;SearchItem.StyleFamily&quot;
args1(0).Value = 2
args1(1).Name = &quot;SearchItem.CellType&quot;
args1(1).Value = 0
args1(2).Name = &quot;SearchItem.RowDirection&quot;
args1(2).Value = true
args1(3).Name = &quot;SearchItem.AllTables&quot;
args1(3).Value = false
args1(4).Name = &quot;SearchItem.SearchFiltered&quot;
args1(4).Value = false
args1(5).Name = &quot;SearchItem.Backward&quot;
args1(5).Value = false
args1(6).Name = &quot;SearchItem.Pattern&quot;
args1(6).Value = true
args1(7).Name = &quot;SearchItem.Content&quot;
args1(7).Value = false
args1(8).Name = &quot;SearchItem.AsianOptions&quot;
args1(8).Value = false
args1(9).Name = &quot;SearchItem.AlgorithmType&quot;
args1(9).Value = 0
args1(10).Name = &quot;SearchItem.SearchFlags&quot;
args1(10).Value = 65536
args1(11).Name = &quot;SearchItem.SearchString&quot;
args1(11).Value = oldStyleName
args1(12).Name = &quot;SearchItem.ReplaceString&quot;
args1(12).Value = newStyleName
args1(13).Name = &quot;SearchItem.Locale&quot;
args1(13).Value = 255
args1(14).Name = &quot;SearchItem.ChangedChars&quot;
args1(14).Value = 2
args1(15).Name = &quot;SearchItem.DeletedChars&quot;
args1(15).Value = 2
args1(16).Name = &quot;SearchItem.InsertedChars&quot;
args1(16).Value = 2
args1(17).Name = &quot;SearchItem.TransliterateFlags&quot;
args1(17).Value = 1280
args1(18).Name = &quot;SearchItem.Command&quot;
args1(18).Value = 3
args1(19).Name = &quot;SearchItem.SearchFormatted&quot;
args1(19).Value = false
args1(20).Name = &quot;SearchItem.AlgorithmType2&quot;
args1(20).Value = 1
args1(21).Name = &quot;Quiet&quot;
args1(21).Value = true
dispatcher.executeDispatch(document, &quot;.uno:ExecuteSearch&quot;, &quot;&quot;, 0, args1())
End Sub
Private Sub doNotTrack
dispatcher = createUnoService(&quot;com.sun.star.frame.DispatchHelper&quot;)
document = ThisComponent.CurrentController.Frame
dim trackProperties(0) as new com.sun.star.beans.PropertyValue
trackProperties(0).Name = &quot;TrackChanges&quot;
trackProperties(0).Value = false
dispatcher.executeDispatch(document, &quot;.uno:TrackChanges&quot;, &quot;&quot;, 0, trackProperties())
dim args1(0) as new com.sun.star.beans.PropertyValue
args1(0).Name = &quot;ShowTrackedChanges&quot;
args1(0).Value = true
dispatcher.executeDispatch(document, &quot;.uno:ShowTrackedChanges&quot;, &quot;&quot;, 0, args1())
End Sub
Private Sub removeDirectFormatting
Dim oDescriptor &apos;The search descriptor
dim dispatcher as Object
dispatcher = createUnoService(&quot;com.sun.star.frame.DispatchHelper&quot;)
dim document as Object
document = ThisComponent.CurrentController.Frame
Dim oViewCursor As Object &apos;View cursor
oViewCursor = ThisComponent.CurrentController.getViewCursor()
oViewCursor.jumpToFirstPage()
oViewCursor.gotoStart(false)
oViewCursor.gotoEnd(true)
dispatcher.executeDispatch(document, &quot;.uno:ResetAttributes&quot;, &quot;&quot;, 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, &quot;.uno:ResetAttributes&quot;, &quot;&quot;, 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, &quot;.uno:ResetAttributes&quot;, &quot;&quot;, 0, Array())
next
oViewCursor.gotoStart(false)
End Sub
Private Sub resetFootnotesStyle
Dim oDescriptor &apos;The search descriptor
dim dispatcher as Object
dispatcher = createUnoService(&quot;com.sun.star.frame.DispatchHelper&quot;)
dim document as Object
document = ThisComponent.CurrentController.Frame
Dim oViewCursor As Object &apos;View cursor
oViewCursor = ThisComponent.CurrentController.getViewCursor()
allNotes= thisComponent.FootNotes
for x = 0 to allNotes.Count -1
aNote = allNotes.getByIndex(x)
aNote.Anchor.CharStyleName=&quot;Footnote anchor&quot;
oEnum = aNote.Text.createEnumeration()
Do While oEnum.hasMoreElements()
oCurPar = oEnum.nextElement()
oCurPar.ParaStyleName = &quot;Footnote&quot;
Loop
Next
End Sub
Private Sub removeUnusedStyles
&apos;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)
&apos;calls: getStyleNames
Dim sUsed() as String, sMsg$,iAnswer%, bStop as boolean
sUsed() = getStyleNames(oFamily,bLocalized:=True,bUsed:=False,bUserDef:=true)
If uBound(sUsed()) &gt; -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 = &quot;&quot;
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) &lt;&gt; 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 + &quot;([^&quot; + identifier+ &quot;]*)&quot; + 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 = &quot;&quot;
endTextRange = oTextCursor.getEnd()
oTextCursor.goToRange(found.start,false)
oTextCursor.goRight(Len(leftEnclosure), true)
oTextCursor.String = &quot;&quot;
found = Thiscomponent.findNext(endTextRange, SDesc)
Loop
End Sub
Private Function compileSearchString(identifier)
compileSearchString = &quot;&lt;&quot;+identifier+&quot;&gt;&quot;+&quot;(.*?)&quot;+&quot;&lt;/&quot;+identifier+&quot;&gt;&quot;
End Function
Private Function compileLeftEnclosure(identifier)
compileLeftEnclosure = &quot;&lt;&quot;+identifier+&quot;&gt;&quot;
End Function
Private Function compileRightEnclosure(identifier)
compileRightEnclosure = &quot;&lt;/&quot;+identifier+&quot;&gt;&quot;
End Function
Private Sub toTextBold
styleNames = Array(&quot;CharWeight&quot;)
styleValues = Array(com.sun.star.awt.FontWeight.BOLD)
convertFormatToEnclosure(CHR(867), styleNames, styleValues)
End Sub
Private Sub fromTextBold
styleNames = Array(&quot;CharWeight&quot;)
styleValues = Array(com.sun.star.awt.FontWeight.BOLD)
convertEnclosuresToFormat(CHR(867), styleNames, styleValues)
End Sub
Private Sub toTextItalic
styleNames = Array(&quot;CharPosture&quot;)
styleValues = Array(com.sun.star.awt.FontSlant.ITALIC)
convertFormatToEnclosure(CHR(868), styleNames, styleValues)
End Sub
Private Sub fromTextItalic
styleNames = Array(&quot;CharPosture&quot;)
styleValues = Array(com.sun.star.awt.FontSlant.ITALIC)
convertEnclosuresToFormat(CHR(868), styleNames, styleValues)
End Sub
Private Sub toTextStrikeout
styleNames = Array(&quot;CharStrikeout&quot;)
styleValues = Array(com.sun.star.awt.FontStrikeout.SINGLE)
convertFormatToEnclosure(CHR(869), styleNames, styleValues)
End Sub
Private Sub fromTextStrikeout
styleNames = Array(&quot;CharStrikeout&quot;)
styleValues = Array(com.sun.star.awt.FontStrikeout.SINGLE)
convertEnclosuresToFormat(CHR(869), styleNames, styleValues)
End Sub
Private Sub toTextUnderline
styleNames = Array(&quot;CharUnderline&quot;)
styleValues = Array(com.sun.star.awt.FontUnderline.SINGLE)
convertFormatToEnclosure(CHR(870), styleNames, styleValues)
End Sub
Private Sub fromTextUnderline
styleNames = Array(&quot;CharUnderline&quot;)
styleValues = Array(com.sun.star.awt.FontUnderline.SINGLE)
convertEnclosuresToFormat(CHR(870), styleNames, styleValues)
End Sub
Private Sub toTextSuperscript
styleNames = Array(&quot;CharEscapementHeight&quot;,&quot;CharEscapement&quot;)
styleValues = Array(58,14000)
convertFormatToEnclosure(CHR(871), styleNames, styleValues)
End Sub
Private Sub fromTextSuperscript
styleNames = Array(&quot;CharEscapementHeight&quot;,&quot;CharEscapement&quot;)
styleValues = Array(58,14000)
convertEnclosuresToFormat(CHR(871), styleNames, styleValues)
End Sub
Private Sub toTextSubscript
styleNames = Array(&quot;CharEscapementHeight&quot;,&quot;CharEscapement&quot;)
styleValues = Array(58,-14000)
convertFormatToEnclosure(CHR(872), styleNames, styleValues)
End Sub
Private Sub fromTextSubscript
styleNames = Array(&quot;CharEscapementHeight&quot;,&quot;CharEscapement&quot;)
styleValues = Array(58,-14000)
convertEnclosuresToFormat(CHR(872), styleNames, styleValues)
End Sub
Private Sub toTextSuperscriptOld
styleNames = Array(&quot;CharEscapementHeight&quot;,&quot;CharEscapement&quot;)
styleValues = Array(58,101)
convertFormatToEnclosure(CHR(871), styleNames, styleValues)
End Sub
Private Sub fromTextSuperscriptOld
styleNames = Array(&quot;CharEscapementHeight&quot;,&quot;CharEscapement&quot;)
styleValues = Array(58,101)
convertEnclosuresToFormat(CHR(871), styleNames, styleValues)
End Sub
Private Sub toTextSubscriptOld
styleNames = Array(&quot;CharEscapementHeight&quot;,&quot;CharEscapement&quot;)
styleValues = Array(58,-101)
convertFormatToEnclosure(CHR(872), styleNames, styleValues)
End Sub
Private Sub fromTextSubscriptOld
styleNames = Array(&quot;CharEscapementHeight&quot;,&quot;CharEscapement&quot;)
styleValues = Array(58,-101)
convertEnclosuresToFormat(CHR(872), styleNames, styleValues)
End Sub
Private Sub toTextSparce
styleNames = Array(&quot;CharKerning&quot;)
For i=70 To 70
styleValues = Array(i)
convertFormatToEnclosure(CHR(873) &amp; i, styleNames, styleValues)
Next
End Sub
Private Sub fromTextSparce
styleNames = Array(&quot;CharKerning&quot;)
For i=70 To 70
styleValues = Array(i)
convertEnclosuresToFormat(CHR(873) &amp; 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) &lt; 6 OR (CInt(bigNum) = 6 AND CInt(smallNum &lt; 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) &lt; 6 OR (CInt(bigNum) = 6 AND CInt(smallNum &lt; 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 = &quot;Автор&quot; Or sName = &quot;Автор по-английски&quot; Or sName = &quot;Ключевые слова&quot; Or sName = &quot;Текст списка литературы&quot; Or sName = &quot;Эпиграф&quot; or sName = &quot;Цитирование&quot; or sName = &quot;Сведения об авторе&quot; or sName = &quot;Аннотация&quot; Then
chkUse = False
Endif
If chkUse AND chkUDef then
bas_Pusharray sNames(),sName
Endif
Next
getStyleNames = sNames()
End Function
&apos;very simple routine appending some element to an array which can be undimensioned (LBound &gt; UBound)
Sub bas_PushArray(xArray(),vNextElement)
Dim iUB%,iLB%
iLB = lBound(xArray())
iUB = uBound(xArray())
If iLB &gt; 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
&apos;newFontName = &quot;IPH Astra Serif&quot;
Dim SrchAttributes(0) as new com.sun.star.beans.PropertyValue
Dim ReplAttributes(0) as new com.sun.star.beans.PropertyValue
SrchAttributes(0).Name = &quot;CharFontName&quot;
&apos;SrchAttributes(0).Value = &quot;WL LatinAllIn1Goth&quot;
ReplAttributes(0).Name = &quot;CharFontName&quot;
&apos;ReplAttributes(0).Value = newFontName
SrchAttributes(0).Value = Empty
ReplAttributes(0).Value = Empty
&apos;Replace macron below
oSearchString = &quot;(.)\uF0D4&quot;
oReplaceString = &quot;$1̱&quot;
&apos;from WL
ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false)
oSearchString = &quot;(.)\u0331&quot;
&apos;from unicode to remove direct formatting
ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false)
&apos;Replace dot below
oSearchString = &quot;(.)\uF0D6&quot;
oReplaceString = &quot;$1̣&quot;
&apos;from WL
ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false)
&apos;from unicode to remove direct formatting
oSearchString = &quot;(.)\u0323&quot;
ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false)
&apos;replace macron
oSearchString = &quot;(.)\uF0F4&quot;
oReplaceString = &quot;$1̄&quot;
&apos;from WL
ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false)
&apos;from unicode to remove direct formatting
oSearchString = &quot;(.)\u0304&quot;
ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false)
&apos;replace accent
oSearchString = &quot;(.)\uF0F1&quot;
oReplaceString = &quot;$1́&quot;
ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false)
&apos;from unicode to remove direct formatting
oSearchString = &quot;(.)\u0341&quot;
ReplaceFormatting(oSearchString,oReplaceString,SrchAttributes,ReplAttributes, false)
replaceFontsInStyles( &quot;WL LatinAllIn1Goth&quot;, newFontName)
End Sub
Function getVersion
GlobalScope.BasicLibraries.LoadLibrary(&quot;Tools&quot;)
Dim oProduct As Object
oProduct=GetRegistryKeyContent(&quot;org.openoffice.Setup/Product&quot;)
getVersion=oProduct.getByName(&quot;ooSetupVersion&quot;)
End Function
</script:module>