Sub markval30 End Sub Sub validateButton Dim badFootnoteSigns As Boolean Dim badGraphics As Boolean Dim badSectionsInTables As Boolean Dim badHeadingsInFootnotes As Boolean Dim outlinePageStylesReport As String Dim badHeadingsInTables As Boolean Dim badText As Boolean Dim needExtendedInfo As Boolean Dim config As Object Dim needFixColoredText As Boolean Dim brokenCharBackTransparent As Boolean config = initRedactionConfiguration() Dim statusIndicator as Object statusIndicator = ThisComponent.getCurrentController.statusIndicator statusIndicator.Start(getTranslation("validationStarted"),100) badFootnoteSigns = noteSignsCheck() statusIndicator.setValue(10) badGraphics = checkGraphics() badText = findBadCharacters() needFixColoredText = findColoredBackgroundInDoc() statusIndicator.setValue(20) badSectionsInTables = checkSectionsInTables() statusIndicator.setValue(30) badHeadingsInFootnotes = checkNotesOutline() statusIndicator.setValue(40) outlinePageStylesReport = checkHeadingsInHeadersFooters() statusIndicator.setValue(50) badHeadingsInTables = checkHeadingsInTextTables() statusIndicator.setValue(60) If outlinePageStylesReport <> "" Then MsgBox outlinePageStylesReport EndIf If config.getPropertyValue("complexity") = "makerUp" then needExtendedInfo = true Else needExtendedInfo = false EndIf brokenCharBackTransparent = hasbrokenCharBackTransparent() If (brokenCharBackTransparent) Then MsgBox getTranslation("invalidParagraphFormattingFound") EndIf numberingsErros = printNumberingSymbols(needExtendedInfo) statusIndicator.setValue(80) If brokenCharBackTransparent OR needFixColoredText OR numberingsErros OR badText OR badFootnoteSigns OR badGraphics Or badHeadingsInFootnotes Or badSectionsInTables OR badHeadingsInTables OR outlinePageStylesReport <> "" Then MsgBox getTranslation("validationWarning") Else MsgBox getTranslation("validationSuccess") EndIf statusIndicator.end() End Sub Function checkGraphics() As Boolean Dim drawPages As Object Dim count as Integer Dim draw As Object Dim shapeType As String Dim embeededObject As Object drawPages = ThisComponent.DrawPage Dim i As Long Dim badDrawings() As Object Dim badFrames() As Object count = drawPages.getCount() For i = 0 to count - 1 draw = drawPages.getByIndex(i) shapeType = draw.ShapeType If InStr(shapeType,"com.sun.star.drawing") = 1 Then addToArray(badDrawings, draw.Anchor) EndIf If InStr(shapeType,"FrameShape") = 1 Then If draw.supportsService("com.sun.star.text.TextEmbeddedObject") Then embeededObject = draw.getEmbeddedObject() If IsNull(embeededObject) Then addToArray(badFrames, draw.Anchor) Else If Not embeededObject.supportsService("com.sun.star.formula.FormulaProperties") Then addToArray(badFrames, draw.Anchor) Else 'Formula EndIf EndIf EndIf EndIf Next i checkGraphics = false If UBound(badDrawings) > -1 Then startNavigatorDialog(getTranslation("validationBadDrawings") & (UBound(badDrawings) + 1) & getTranslation("validationExcerptNotSuitable"),badDrawings) checkGraphics = true EndIf If UBound(badFrames) > -1 Then startNavigatorDialog(getTranslation("validationBadEmbeededObjects") & (UBound(badFrames) + 1) & getTranslation("validationExcerptNotSuitable"),badFrames) checkGraphics = true EndIf End Function Private Sub fixDOI StartTracking replaceCharsInDOI StopTracking End Sub Sub replaceCharsInDOI AskAndReplace("(?<=DOI[0-9. /XVI:‒–—−ХOО?-]{1,50})[Х]{1,5}","X") AskAndReplace("(?<=DOI[0-9. /XVI:‒–—−ХOО?-]{1,50})[OО]{1,5}","0") AskAndReplace("(?<=DOI[0-9. /XVI:‒–—−ХOО?-]{1,50})[‒–—−]{1,5}","-") End sub Private Function noteSignsCheck() As Boolean Dim footnotes As Object Dim footnote As Object Dim endnote As Object Dim endnotes As Object Dim count as Integer Dim charNum as Long Dim char As Long Dim label As String Dim result As String Dim founds() As Object noteSignsCheck = false result = "" footnotes = ThisComponent.Footnotes endnotes = ThisComponent.Endnotes count = footnotes.getCount Dim i As Integer Dim j As Integer For i = 0 to count-1 footnote = footnotes.getByIndex(i) label = footnote.Label charNum = Len(label) For j = 1 to charNum char = Asc(Right(Left(label,j),1)) If char >= 57344 AND char <= 63743 Then addToArray(founds,footnote.Anchor) 'result = result & getTranslation("validateFootnotes1") & " " & Chr(char) & " " & getTranslation("validateFootnotes2") & " " & i & " " & getTranslation("validateFootnotes3") & chr(10) End If Next j Next i count = endnotes.getCount For i = 0 to count-1 endnote = endnotes.getByIndex(i) label = endnote.Label charNum = Len(label) For j = 1 to charNum char = Asc(Right(Left(label,j),1)) If char >= 57344 AND char <= 63743 Then addToArray(founds,endnote.Anchor) 'result = result & getTranslation("validateFootnotes1") & " " & Chr(char) & " " & getTranslation("validateEndnotes1") & " " & i & " " & getTranslation("validateFootnotes3") & chr(10) End If Next j Next i If (UBound(founds) > -1) Then noteSignsCheck = true MsgBox(getTranslation("validationBadFootnotesSymbolsNotification")) startNavigatorDialog(getTranslation("badNoteSings"),founds) EndIf 'noteSignsCheck = result End Function Function checkNotesOutline As Boolean Dim footNotes As Object Dim endNotes As Object Dim x As Long Dim aNote As Object Dim oEnum As Object Dim oCurPar As Object ' Dim result As String Dim founds() As Object ' result = "" footNotes = thisComponent.footNotes endNotes = thisComponent.EndNotes for x = 0 to footNotes.Count -1 aNote = footNotes.getByIndex(x) aNote.Anchor.CharStyleName="Footnote anchor" oEnum = aNote.Text.createEnumeration() Do While oEnum.hasMoreElements() oCurPar = oEnum.nextElement() If oCurPar.OutlineLevel > 0 Then addToArray(founds,oCurPar) ' result = result & getTranslation("validateFootnotes2") & " " & x & " " & getTranslation("setOutlineLevel") & " " & oCurPar.OutlineLevel & chr(10) EndIf Loop Next for x = 0 to endNotes.Count -1 aNote = endNotes.getByIndex(x) aNote.Anchor.CharStyleName="Footnote anchor" oEnum = aNote.Text.createEnumeration() Do While oEnum.hasMoreElements() oCurPar = oEnum.nextElement() If oCurPar.OutlineLevel > 0 Then addToArray(founds,oCurPar) ' result = result & getTranslation("validateEndnotes1") & " " & x & " " & getTranslation("setOutlineLevel") & " " & oCurPar.OutlineLevel & chr(10) EndIf Loop Next If (UBound(founds) > -1) Then startNavigatorDialog(getTranslation("badHeadingsInFootnotes"),founds) checkNotesOutline = true Else checkNotesOutline = false EndIf End Function Function checkSectionsInTables As Boolean Dim x As Integer Dim oEnum As Object 'Dim result As String Dim sections As Object Dim section As Object Dim anchor As Object Dim anchorText As Object Dim badSections() As Object result = "" sections = thisComponent.TextSections for x = 0 to sections.Count -1 section = sections.getByIndex(x) anchor = section.getAnchor() anchorText = anchor.getText() If anchorText.supportsService("com.sun.star.text.CellProperties") Then addToArray(badSections(),anchor) 'result = result & getTranslation("section") & " " & section.Name & " " & getTranslation("isInTable") & chr(10) EndIf Next If (UBound(badSections) > -1) Then checkSectionsInTables = true startNavigatorDialog(getTranslation("badSectionsInTables"),badSections) Else checkSectionsInTables = false EndIf End Function Function checkHeadingsInHeadersFooters As String Dim result As String Dim count As Integer Dim oStyle As Object Dim i As Integer result = "" Dim pageStyles As Object pageStyles = ThisComponent.StyleFamilies.getByName("PageStyles") count = pageStyles.count - 1 For i = 0 to count oStyle = pageStyles.getByIndex(i) If oStyle.isInUse Then If oStyle.HeaderIsOn Then If oStyle.HeaderIsShared Then If isHeadingsInText(oStyle.HeaderText) Then result = result & getTranslation("foundHeadingIn") & " " & getTranslation("inHeader") & " " & getTranslation("inPageStyle") & " " & oStyle.getName() & chr(10) EndIf Else If isHeadingsInText(oStyle.HeaderTextLeft) Then result = result & getTranslation("foundHeadingIn") & " " & getTranslation("inHeader") & " " & getTranslation("inPageStyle") & " " & oStyle.getName() & chr(10) EndIf If isHeadingsInText(oStyle.HeaderTextRight) Then result = result & getTranslation("foundHeadingIn") & " " & getTranslation("inHeader") & " " & getTranslation("inPageStyle") & " " & oStyle.getName() & chr(10) EndIf EndIf If NOT oStyle.FirstIsShared Then If isHeadingsInText(oStyle.HeaderTextFirst) Then result = result & getTranslation("foundHeadingIn") & " " & getTranslation("inHeader") & " " & getTranslation("inPageStyle") & " " & oStyle.getName() & chr(10) EndIf EndIf EndIf If oStyle.FooterIsOn Then If oStyle.FooterIsShared Then If isHeadingsInText(oStyle.FooterText) Then result = result & getTranslation("foundHeadingIn") & " " & getTranslation("inFooter") & " " & getTranslation("inPageStyle") & " " & oStyle.getName() & chr(10) EndIf Else If isHeadingsInText(oStyle.FooterTextLeft) Then result = result & getTranslation("foundHeadingIn") & " " & getTranslation("inFooter") & " " & getTranslation("inPageStyle") & " " & oStyle.getName() & chr(10) EndIf If isHeadingsInText(oStyle.FooterTextRight) Then result = result & getTranslation("foundHeadingIn") & " " & getTranslation("inFooter") & " " & getTranslation("inPageStyle") & " " & oStyle.getName() & chr(10) EndIf EndIf If NOT oStyle.FirstIsShared Then If isHeadingsInText(oStyle.FooterTextFirst) Then result = result & getTranslation("foundHeadingIn") & " " & getTranslation("inFooter") & " " & getTranslation("inPageStyle") & " " & oStyle.getName() & chr(10) EndIf EndIf EndIf EndIf Next i checkHeadingsInHeadersFooters = result End Function Function checkHeadingsInTextTables() As Boolean Dim enum1Element As Object Dim enum1 As Object Dim enum2 As Object Dim thisPortion As Object Dim footnoteText As Object Dim label As String Dim labelNum As Integer Dim i As Integer Dim count As Integer Dim cell As Object Dim cellText As Object Dim firstCellName As String Dim founds() As Object enum1 = ThisComponent.Text.createEnumeration While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.TextTable") Then firstCellName = enum1Element.getCellByPosition(0,0).cellName cellNames = enum1Element.cellNames For i = LBound(cellNames) To Ubound(cellNames) cell = enum1Element.getCellByName(cellNames(i)) cellText = cell.getText() If cellNames(i) = firstCellName Then addHeadingNotFirstInText(cellText,founds) Else addHeadingsInText(cellText,founds) EndIf Next i EndIf Wend If (UBound(founds) > -1) Then checkHeadingsInTextTables = true startNavigatorDialog(getTranslation("badHeadingsInTables"),founds) Else checkHeadingsInTextTables = false EndIf End Function Sub addHeadingNotFirstInText(oText As Object, founds() As Object) Dim enum1Element As Object Dim enum1 As Object Dim enum2 As Object Dim thisPortion As Object Dim footnoteText As Object Dim label As String Dim labelNum As Integer Dim i As Integer Dim count As Integer Dim cell As Object Dim cellText As Object Dim first As Boolean first = true enum1 = oText.createEnumeration While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") Then If Not first Then If enum1Element.OutlineLevel > 0 Then addToArray(founds,enum1Element) EndIf EndIf 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() addHeadingsInText(cellText,founds) Next i EndIf first = false Wend End Sub Sub addHeadingsInText(oText As Object, founds() As Object) Dim enum1Element As Object Dim enum1 As Object Dim enum2 As Object Dim thisPortion As Object Dim footnoteText As Object Dim label As String Dim labelNum As Integer Dim i As Integer Dim count As Integer Dim cell As Object Dim cellText As Object enum1 = oText.Text.createEnumeration While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") Then If enum1Element.OutlineLevel > 0 Then addToArray(founds,enum1Element) EndIf 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() addHeadingsInText(cellText,founds) Next i EndIf Wend End Sub Function isHeadingNotFirstInText(oText As Object) As Boolean Dim enum1Element As Object Dim enum1 As Object Dim enum2 As Object Dim thisPortion As Object Dim footnoteText As Object Dim label As String Dim labelNum As Integer Dim i As Integer Dim count As Integer Dim cell As Object Dim cellText As Object Dim first As Boolean first = true enum1 = oText.createEnumeration While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") Then If Not first Then If enum1Element.OutlineLevel > 0 Then isHeadingNotFirstInText = true Exit Function EndIf EndIf 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() If isHeadingsInText(cellText) Then isHeadingNotFirstInText = true Exit Function EndIf Next i EndIf first = false Wend isHeadingNotFirstInText = false End Function Function isHeadingsInText(oText As Object) As Boolean Dim enum1Element As Object Dim enum1 As Object Dim enum2 As Object Dim thisPortion As Object Dim footnoteText As Object Dim label As String Dim labelNum As Integer Dim i As Integer Dim count As Integer Dim cell As Object Dim cellText As Object enum1 = oText.Text.createEnumeration While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") Then If enum1Element.OutlineLevel > 0 Then isHeadingsInText = true Exit Function EndIf 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() If isHeadingsInText(cellText) Then isHeadingsInText = true Exit Function EndIf Next i EndIf Wend isHeadingsInText = false End Function Function hasBrokenCharBackTransparent As Boolean Dim footNotes As Object Dim endNotes As Object Dim i As Long Dim oStyles As Object Dim pageStyles As Object Dim pageStyle As Object hasBrokenCharBackTransparent = isBackColorInText(ThisComponent.Text) If (hasBrokenCharBackTransparent) Then Exit Function EndIf footNotes = ThisComponent.FootNotes For i = 0 to footNotes.getCount - 1 hasBrokenCharBackTransparent = isBackColorInText(footNotes.getByIndex(i).Text) If (hasBrokenCharBackTransparent) Then Exit Function EndIf Next i endNotes = thisComponent.footNotes For i = 0 to footNotes.Count -1 hasBrokenCharBackTransparent = isBackColorInText(endNotes.getByIndex(i).Text) If (hasBrokenCharBackTransparent) Then Exit Function EndIf Next i oStyles = ThisComponent.StyleFamilies pageStyles = oStyles.getByName(oStyles.elementNames(2)) For i = 0 to pageStyles.Count -1 pageStyle = pageStyles.getByIndex(i) If Not IsEmpty(pageStyle.FooterText) Then hasBrokenCharBackTransparent = isBackColorInText(pageStyle.FooterText) If (hasBrokenCharBackTransparent) Then Exit Function EndIf EndIf If Not IsEmpty(pageStyle.FooterTextFirst) Then hasBrokenCharBackTransparent = isBackColorInText(pageStyle.FooterTextFirst) If (hasBrokenCharBackTransparent) Then Exit Function EndIf EndIf If Not IsEmpty(pageStyle.FooterTextRight) Then hasBrokenCharBackTransparent = isBackColorInText(pageStyle.FooterTextRight) If (hasBrokenCharBackTransparent) Then Exit Function EndIf EndIf If Not IsEmpty(pageStyle.FooterTextLeft) Then hasBrokenCharBackTransparent = isBackColorInText(pageStyle.FooterTextLeft) If (hasBrokenCharBackTransparent) Then Exit Function EndIf EndIf If Not IsEmpty(pageStyle.HeaderText) Then hasBrokenCharBackTransparent = isBackColorInText(pageStyle.HeaderText) If (hasBrokenCharBackTransparent) Then Exit Function EndIf EndIf If Not IsEmpty(pageStyle.HeaderTextFirst) Then hasBrokenCharBackTransparent = isBackColorInText(pageStyle.HeaderTextFirst) If (hasBrokenCharBackTransparent) Then Exit Function EndIf EndIf If Not IsEmpty(pageStyle.HeaderTextRight) Then hasBrokenCharBackTransparent = isBackColorInText(pageStyle.HeaderTextRight) If (hasBrokenCharBackTransparent) Then Exit Function EndIf EndIf If Not IsEmpty(pageStyle.HeaderTextLeft) Then hasBrokenCharBackTransparent = isBackColorInText(pageStyle.HeaderTextLeft) If (hasBrokenCharBackTransparent) Then Exit Function EndIf EndIf Next i End Function Function isBackColorInText(oText As Object) As Boolean Dim enum1Element As Object Dim enum1 As Object Dim enum2 As Object Dim thisPortion As Object Dim footnoteText As Object Dim label As String Dim labelNum As Integer Dim i As Integer Dim count As Integer Dim cell As Object Dim cellText As Object enum1 = oText.Text.createEnumeration While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") Then If enum1Element.CharBackTransparent = false Then isBackColorInText = true Exit Function EndIf 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() If isBackColorInText(cellText) Then isBackColorInText = true Exit Function EndIf Next i EndIf Wend isBackColorInText = false End Function Function printNumberingSymbols(needExtendedInfo) As Boolean Dim families As Object Dim numStyles As Object Dim numStyle As Object Dim numRules As Object Dim numRule As Object Dim prop As Object Dim enum1 As Object Dim enum1Element As Object Dim fontProp As Object Dim fontName As String Dim result As String Dim resultBad As String Dim excerpt As String Dim exLength As Integer Dim report As String Dim k As Integer printNumberingSymbols = false families = ThisComponent.StyleFamilies numStyles = families.getByName("NumberingStyles") result = "" resultBad = "" enum1 = ThisComponent.Text.createEnumeration Do While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") Then If NOT IsMissing(enum1Element.NumberingRules) AND NOT IsEmpty(enum1Element.NumberingRules) Then numRules = enum1Element.NumberingRules If numRules.hasElements Then numRule = numRules.getByIndex(enum1Element.NumberingLevel) fontName = "" fontChar = "" For k = 0 To Ubound(numRule) prop = numRule(k) If prop.Name = "BulletFont" Then fontName = prop.Value.Name EndIf If prop.Name = "BulletChar" Then fontChar = prop.Value EndIf Next k exLength = 15 excerpt = enum1Element.String If Len(excerpt) < exLength Then exLength = Len(excerpt) EndIf If fontChar <> "" Then tmp = numRules.Name &" "& getTranslation("validateNumberingLevel") &" " & (j + 1) & " " & getTranslation("validateNumberingFont") & " " & fontName & " " & getTranslation("validateNumberingSymbol") & " " & fontChar & " (" & Hex(Asc(fontChar)) & ") "& Left(excerpt,exLength) & chr(10) If Asc(fontChar) > 57344 AND Asc(fontChar) < 63743 Then resultBad = resultBad & tmp ElseIf fontName <> "IPH Astra Serif" _ AND fontName <> "OpenSymbol" _ AND fontName <> "IPH Lib Serif" _ AND fontName <> "IPH Lib Sans" _ AND fontName <> "Liberation Serif" _ AND fontName <> "Liberation Sans" _ AND needExtendedInfo Then result = result & tmp EndIf EndIf EndIf EndIf EndIf Loop report = "" If result = "" AND resultBad = "" Then Exit Function Else printNumberingSymbols = true If resultBad <> "" Then report = getTranslation("validateNumberingsReportSymbols") & chr(10) & resultBad EndIf If result <> "" Then report = report & getTranslation("validateNumberingsReportFonts") & " "& chr(10)& result EndIf EndIf MsgBox report End Function Private Sub showTrackedChanges dim document as object dim dispatcher as object document = ThisComponent.CurrentController.Frame dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") dispatcher.executeDispatch(document, ".uno:AcceptTrackedChanges", "", 0, Array()) dim args2(0) as new com.sun.star.beans.PropertyValue args2(0).Name = "ShowTrackedChanges" args2(0).Value = true dispatcher.executeDispatch(document, ".uno:ShowTrackedChanges", "", 0, args2()) end Sub Private Sub StartTracking Dim dispatcher As Object Dim document As Object 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 = true 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 StopTracking Dim dispatcher As Object Dim document As Object 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 Dim fontDialog As Object Sub fontReportButton Dim fontNames() As String Dim listBox As Object Dim description As Object Dim statusIndicator as Object statusIndicator = ThisComponent.getCurrentController.statusIndicator statusIndicator.Start(getTranslation("fontReportInProgress"),100) fontNames = getODGFontNames() DialogLibraries.LoadLibrary("Redaction") fontDialog = CreateUnoDialog( DialogLibraries.Redaction.ChooseFontname ) listBox = fontDialog.getControl("fontList") listBox.addItems(fontNames , 0) fontDialog.Title = getTranslation("chooseFontNameDialogTitle") description = fontDialog.getControl("description") description.SetText(getTranslation("chooseFontNameDialogDescription")) statusIndicator.setValue(50) fontDialog.Execute() Dim targetFontName As String targetFontName = fontDialog.model.Tag If targetFontName="0" or targetFontName="" Then statusIndicator.end() Exit sub EndIf Dim FileName As String FileName = getCharsInFont(targetFontName) statusIndicator.end() If FileName <> "" Then openReport(FileName) EndIf End Sub Sub onSelectFont(oEvent) fontDialog.endExecute() fontDialog.model.Tag = oEvent.ActionCommand End Sub Function getODGFontNames() As Variant 'Globalscope.BasicLibraries.LoadLibrary( "MRILib" ) Dim fontNames() As String Dim pages As Object Dim pageCount As Long Dim page As Object Dim elementCount As Long Dim groupCount As Long Dim i As Long Dim j As Long Dim k As Long Dim element As Object Dim elementText As Object Dim groupElement As Object Dim enum1 As Object Dim enum1Element As Object Dim enum2 As Object Dim thisPortion As Object Dim fontChar As Long Dim fontName As String pages = ThisComponent.getDrawPages() pagesCount = pages.getCount() For i = 0 To pagesCount - 1 page = pages.getByIndex(i) elementCount = page.getCount() For j = 0 To elementCount - 1 element = page.getByIndex(j) If element.supportsService("com.sun.star.drawing.Text") Then elementText = element.getText() enum1 = elementText.createEnumeration() While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") Then enum2 = enum1Element.createEnumeration While enum2.hasMoreElements thisPortion = enum2.nextElement If Len(thisPortion.String) > 0 Then fontName = thisPortion.CharFontName If NOT fontIsAlreadyFound(fontNames, fontName) Then AddToArray(fontNames, fontName) EndIf EndIf Wend EndIf Wend EndIf If element.supportsService("com.sun.star.drawing.GroupShape") Then groupCount = element.getCount() For k = 0 To groupCount - 1 groupElement = element.getByIndex(k) If groupElement.supportsService("com.sun.star.drawing.Text") Then elementText = groupElement.getText() enum1 = elementText.createEnumeration() While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") Then enum2 = enum1Element.createEnumeration While enum2.hasMoreElements thisPortion = enum2.nextElement If Len(thisPortion.String) > 0 Then fontName = thisPortion.CharFontName If NOT fontIsAlreadyFound(fontNames, fontName) Then AddToArray(fontNames, fontName) EndIf EndIf Wend EndIf Wend EndIf Next k EndIf Next j Next i getODGFontNames = fontNames End Function Function fontIsAlreadyFound(fontNames() As String, proposeName As String) As Boolean If IsEmpty(fontNames) Then fontIsAlreadyFound = false Exit Function EndIf If getIndex(fontNames(), proposeName) > -1 Then fontIsAlreadyFound = True Exit Function EndIf fontIsAlreadyFound = False End Function Function IsInArray(array, content) IsInArray = false For i = LBound(array) To UBound(array) inArr = array(i) If inArr = content Then IsInArray = true EndIf Next i End Function Function getIndex(array As variant, value As variant) As Integer Dim id As Integer Dim nRight As Integer Dim nLen As Integer id = 0 nRight = uBound(array) nLen = len(value) while id <= nRight If array(id) = value Then getIndex = id exit Function Else id = id + 1 end if wend getIndex = -1 End Function Sub addToArray(xArray(),vNextElement) Dim iUB As Integer Dim iLB As Integer 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 Function getCharsInFont(fontName As String) As String Dim resultArray() As String Dim pageNums() As Long Dim firstPages() As Long Dim resultString As String Dim pages As Object Dim pageCount As Long Dim page As Object Dim elementCount As Long Dim i As Long Dim j As Long Dim k As Long Dim element As Object Dim elementText As Object Dim enum1 As Object Dim enum1Element As Object Dim enum2 As Object Dim thisPortion As Object Dim fontChar As String Dim groupCount As Long Dim groupElement As Object Dim charString As String Dim charNum As Long pages = ThisComponent.getDrawPages() pagesCount = pages.getCount() For i = 0 To pagesCount - 1 page = pages.getByIndex(i) elementCount = page.getCount() For j = 0 To elementCount - 1 element = page.getByIndex(j) If element.supportsService("com.sun.star.drawing.Text") Then elementText = element.getText() enum1 = elementText.createEnumeration() While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") Then enum2 = enum1Element.createEnumeration While enum2.hasMoreElements thisPortion = enum2.nextElement If thisPortion.CharFontName = fontName Then resultString = thisPortion.String For k = 0 To Len(resultString) - 1 charString = Mid(resultString,k+1,1) charNum = Asc(charString) fontChar = Hex(charNum) If NOT IsInArray(resultArray,fontChar) Then AddToArray(resultArray(), fontChar) AddToArray(pageNums(), i + 1) EndIf Next k EndIf Wend EndIf Wend EndIf If element.supportsService("com.sun.star.drawing.GroupShape") Then groupCount = element.getCount() For k = 0 To groupCount - 1 groupElement = element.getByIndex(k) If groupElement.supportsService("com.sun.star.drawing.Text") Then elementText = groupElement.getText() enum1 = elementText.createEnumeration() While enum1.hasMoreElements enum1Element = enum1.nextElement If enum1Element.supportsService("com.sun.star.text.Paragraph") Then enum2 = enum1Element.createEnumeration While enum2.hasMoreElements thisPortion = enum2.nextElement If thisPortion.CharFontName = fontName Then resultString = thisPortion.String For k = 0 To Len(resultString) - 1 fontChar = Hex(Asc(Mid(resultString,k+1,1))) If NOT IsInArray(resultArray,fontChar) Then AddToArray(resultArray(), fontChar) AddToArray(pageNums(), i + 1) EndIf Next k EndIf Wend EndIf Wend EndIf Next k EndIf Next j Next i resultString = "" For i = LBound(resultArray) To UBound(resultArray) resultString = resultString & "<a href='https://unicode-table.com/ru/" & resultArray(i) & "'" & ">https://unicode-table.com/ru/" & resultArray(i) & "</a> " & getTranslation("charFirstPage") & " " & pageNums(i) & "<br>" & Chr(10) Next i If resultString <> "" Then 'MsgBox "Символы в шрифте "& fontName &Chr(10)&resultString Dim FileName As String 'Holds the file name Dim n As Integer 'Holds the file number Dim f As Integer 'Index variable Dim s As String 'Temporary string for input Dim fileaccess As Object Dim outtextstream As Object Dim out As Object Dim sTemp$ GlobalScope.BasicLibraries.loadLibrary("Tools") path=DirectoryNameoutofPath(ThisComponent.getURL(),"/") FileName = path & "/symbolsInFont" & fontName & ".html" 'n = FreeFile() 'Next free file number 'Open FileName For Output Access Read Write As #n 'Open for read/write fileaccess = createUnoService ("com.sun.star.ucb.SimpleFileAccess") outtextstream = createUnoService ("com.sun.star.io.TextOutputStream") outtextstream.setEncoding( "UTF-8" ) out = fileaccess.openFileWrite( FileName ) outtextstream.setOutputStream( out ) outtextstream.writeString( "<html><head><title>" & getTranslation("symbolsInFontHeading") & " "& fontName & "</title></head><body><h2>" & getTranslation("symbolsInFontHeading") & " "& fontName &":</h2>"&resultString &"</body></html>" ) outtextstream.closeOutput() getCharsInFont = FileName Exit Function Else MsgBox getTranslation("symbolsInFontNotFound1") & " " & fontName & " " & getTranslation("symbolsInFontNotFound2") getCharsInFont = "" Exit Function EndIf End Function Function findBadCharacters() As Boolean Dim founds As Object Dim foundObjects() As Object founds = findInDoc("[\uE000-\uF8FF]+") findBadCharacters = false If founds.count <> 0 Then 'MsgBox getTranslation("validationBadSymbolsNotification") foundObjects = convertXIndexAccessToArray(founds) startNavigatorDialog(getTranslation("badSymbols"),foundObjects) findBadCharacters = true EndIf End Function Function findColoredBackgroundInDoc() As Boolean Dim founds As Object Dim sDesc As Object Dim foundObjects() As Object Dim SrchAttributes(0) as new com.sun.star.beans.PropertyValue SrchAttributes(0).Name = "CharBackTransparent" SrchAttributes(0).Value = False sDesc = Thiscomponent.createSearchDescriptor() sDesc.SearchAll = true sDesc.ValueSearch = false sDesc.SearchRegularExpression = true sDesc.searchStyles = true sDesc.SetSearchAttributes(SrchAttributes()) founds = Thiscomponent.findAll(sDesc) findColoredBackgroundInDoc = false If founds.count <> 0 Then MsgBox getTranslation("foundColoredTextMessage") foundObjects = convertXIndexAccessToArray(founds) startNavigatorDialog(getTranslation("coloredTextDescription"),foundObjects) findColoredBackgroundInDoc = true EndIf End Function Sub startNavigatorDialog(objectsDescription As String,foundObjects() As Object) Dim dialog As Object Dim leftImageURL As String Dim rightImageURL As String Dim curNum As Long Dim maxNum As Long Dim found As Object waitingForDialog = true maxNum = UBound(foundObjects) dialog = notModalDialog("Navigator") dialog.getControl("found").SetText(getTranslation("navigatorFound") & CStr(maxNum+1)) curNum = 0 found = foundObjects(curNum) dialog.getControl("current").SetText(CStr(curNum+1)) dialog.getControl("description").SetText(objectsDescription) ' dialog.getControl("cancel").Label = getTranslation("buttonCancel") dialog.getControl("close").Label = getTranslation("buttonClose") leftImageURL = convertToURL(getExtensionPath() & "/images/left-navigator.svg") rightImageURL = convertToURL(getExtensionPath() & "/images/right-navigator.svg") dialog.getControl("prev").model.imageURL = leftImageURL 'dialog.getControl("prev").model.ScaleMode = 2 dialog.getControl("next").model.imageURL = rightImageURL 'dialog.getControl("next").model.ScaleMode = 2 dialog.setvisible(true) 'select first found ' 'not using view cursor as if shape was prevously selected runtime exception will appear Thiscomponent.CurrentController.select(found) Do While waitingForDialog If dialog.getControl("close").model.state = 1 then exit Do EndIf If dialog.getControl("prev").model.state = 1 then curNum = getPrevFound(curNum, maxNum) found = foundObjects(curNum) Thiscomponent.CurrentController.select(found) dialog.getControl("current").SetText(CStr(curNum+1)) dialog.getControl("prev").model.state = 0 EndIf If dialog.getControl("next").model.state = 1 then curNum = getNextFound(curNum, maxNum) found = foundObjects(curNum) Thiscomponent.CurrentController.select(found) dialog.getControl("current").SetText(CStr(curNum+1)) dialog.getControl("next").model.state = 0 EndIf wait (100) Loop dialog.dispose End Sub Function convertXIndexAccessToArray(founds As Object) As Variant Dim i As Integer Dim maxNum As Integer Dim arrayOfObjects() As Object maxNum = founds.count - 1 For i = 0 To maxNum addToArray(arrayOfObjects,founds.getByIndex(i)) Next i convertXIndexAccessToArray = arrayOfObjects End Function Function getNextFound(curNum As Long, max As Long) As Long If curNum < max Then getNextFound = curNum + 1 Else getNextFound = 0 EndIf End Function Function getPrevFound(curNum As Long, max As Long) As Long If curNum = 0 Then getPrevFound = max Else getPrevFound = curNum - 1 EndIf End Function Function getExtensionPath() As String Dim extensionIdentifier As String Dim pip As Object extensionIdentifier = "pro.litvinovg.Redaction" pip = GetDefaultContext.getByName("/singletons/com.sun.star.deployment.PackageInformationProvider") getExtensionPath = pip.getPackageLocation(extensionIdentifier) End Function Function notModalDialog(dialogName As String) As Variant Dim windowProvider As Object Dim containerWindow As Object Dim handler As Object Dim dialogUrl As String Dim dialog As Object containerWindow = ThisComponent.getCurrentController().getFrame().getContainerWindow() dialogUrl = "vnd.sun.star.script:Redaction." & dialogName & "?location=application" windowProvider = CreateUnoService("com.sun.star.awt.ContainerWindowProvider") dialog = windowProvider.createContainerWindow(dialogUrl, "", containerWindow, handler) notModalDialog = dialog End Function sub openReport(fileName As String) dim document as object dim dispatcher as object Dim path As String Dim tmpName As String Dim oldName As String document = ThisComponent.CurrentController.Frame dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") dim args1(1) as new com.sun.star.beans.PropertyValue args1(0).Name = "URL" args1(0).Value = fileName args1(1).Name = "FilterName" args1(1).Value = "HTML (StarWriter)" dispatcher.executeDispatch(document, ".uno:Open", "", 0, args1()) If FileExists(tmpName) Then Kill(tmpName) End If End Sub Function isInDoc(searchString As String) As Boolean Dim founds As Variant founds = findInDoc(searchString) If founds.count <> 0 Then isInDoc = true Else isInDoc = false EndIf End Function Function findInDoc(searchString As String) As Variant Dim founds As Object Dim sDesc As Object Dim srch(0) as new com.sun.star.beans.PropertyValue sDesc = Thiscomponent.createSearchDescriptor() sDesc.SearchAll = true sDesc.ValueSearch = false sDesc.SearchStyles = false sDesc.SearchCaseSensitive = true sDesc.SearchRegularExpression = true sDesc.SearchString = searchString founds = Thiscomponent.findAll(sDesc) findInDoc = founds End Function