问题描述
根据 google group，这个宏可用于在 MS Office 中打印拼写错误的单词。
https://groups.google.com/g/microsoft.public.word.spelling.grammar/c/OiFYPkLAbeU
libre-office writer 有类似的选项吗？
解决方法
以下子程序复制了 Google 组中的代码所做的事情。它比 MS 版本更冗长，但对于 LibreOffice/OpenOffice，这是可以预料的。它只做拼写检查行，不做绿色语法检查行，Google 群里的 MS 版本也是如此。
Sub UnderlineMisspelledWords
' From OOME Listing 315 Page 336
GlobalScope.BasicLibraries.loadLibrary( "Tools" )
Dim sLocale As String
sLocale = GetRegistryKeyContent("org.openoffice.Setup/L10N",FALSE).getByName("ooLocale")
' ooLocale appears to return a string that consists of the language and country
' seperated by a dash,e.g. en-GB
Dim nDash As Integer
nDash = InStr(sLocale,"-")
Dim aLocale As New com.sun.star.lang.Locale
aLocale.Language = Left(sLocale,nDash - 1)
aLocale.Country = Right(sLocale,Len(sLocale) -nDash )
Dim oSpeller As Variant
oSpeller = createUnoService("com.sun.star.linguistic2.SpellChecker")
Dim emptyArgs() as new com.sun.star.beans.PropertyValue
Dim oCursor As Object
oCursor = ThisComponent.getText.createTextCursor()
oCursor.gotoStart(False)
oCursor.collapseToStart()
Dim s as String,bTest As Boolean
Do
oCursor.gotoEndOfWord(True)
s = oCursor.getString()
bTest = oSpeller.isValid(s,aLocale,emptyArgs())
If Not bTest Then
With oCursor
.CharUnderlineHasColor = True
.CharUnderlineColor = RGB(255,0)
.CharUnderline = com.sun.star.awt.FontUnderline.WAVE
' Possible alternatives include SMALLWAVE,DOUBLEWAVE and BOLDWAVE
End With
End If
Loop While oCursor.gotoNextWord(False)
End Sub
这会将字体的实际格式更改为具有红色波浪下划线，这将像任何其他格式一样打印出来。如果文档中任何拼写错误的单词已经有某种下划线，那么该下划线就会丢失。
您可能希望在打印后删除下划线。以下 Sub 仅在其样式与第一个例程添加的行的样式完全匹配时删除下划线。
Sub RemoveUnderlining
Dim oCursor As Object
oCursor = ThisComponent.getText.createTextCursor()
oCursor.gotoStart(False)
oCursor.collapseToStart()
Dim s as String,bTest As Boolean
Do
oCursor.gotoEndOfWord(True)
Dim bTest1 As Boolean
bTest1 = False
If oCursor.CharUnderlineHasColor = True Then
bTest1 = True
End If
Dim bTest2 As Boolean
bTest2 = False
If oCursor.CharUnderlineColor = RGB(255,0) Then
bTest2 = True
End If
Dim bTest3 As Boolean
bTest3 = False
If oCursor.CharUnderline = com.sun.star.awt.FontUnderline.WAVE Then
bTest3 = True
End If
If bTest1 And bTest2 And bTest3 Then
With oCursor
.CharUnderlineHasColor = False
.CharUnderline = com.sun.star.awt.FontUnderline.NONE
End With
End If
Loop While oCursor.gotoNextWord(False)
End Sub
这不会恢复任何被红色波浪线替换的原始下划线。去除波浪线以恢复这些波浪线的其他方法是：
-
按
undo(Ctrl Z)，但您需要对文档中的每个单词执行一次，这可能有点麻烦。 -
在文档的临时副本上运行子例程
UnderlineMisspelledWords，然后在打印后将其丢弃。
我希望这就是您要找的。p>
,为了回应您的上述评论，修改上述子例程来执行此操作而不是绘制波浪线很简单。下面的代码打开一个新的 Writer 文档，并在其中写入拼写错误的单词列表以及拼写检查器建议的替代词：
Sub ListMisSpelledWords
' From OOME Listing 315 Page 336
GlobalScope.BasicLibraries.loadLibrary( "Tools" )
Dim sLocale As String
sLocale = GetRegistryKeyContent("org.openoffice.Setup/L10N",Len(sLocale) -nDash )
Dim oSource As Object
oSource = ThisComponent
Dim oSourceCursor As Object
oSourceCursor = oSource.getText.createTextCursor()
oSourceCursor.gotoStart(False)
oSourceCursor.collapseToStart()
Dim oDestination As Object
oDestination = StarDesktop.loadComponentFromURL( "private:factory/swriter","_blank",Array() )
Dim oDestinationText as Object
oDestinationText = oDestination.getText()
Dim oDestinationCursor As Object
oDestinationCursor = oDestinationText.createTextCursor()
Dim oSpeller As Object
oSpeller = createUnoService("com.sun.star.linguistic2.SpellChecker")
Dim oSpellAlternatives As Object,emptyArgs() as new com.sun.star.beans.PropertyValue
Dim sMistake as String,oSpell As Object,sAlternatives() as String,bTest As Boolean,s As String,i as Integer
Do
oSourceCursor.gotoEndOfWord(True)
sMistake = oSourceCursor.getString()
bTest = oSpeller.isValid(sMistake,emptyArgs())
If Not bTest Then
oSpell = oSpeller.spell(sMistake,emptyArgs())
sAlternatives = oSpell.getAlternatives()
s = ""
for i = LBound(sAlternatives) To Ubound(sAlternatives) - 1
s = s & sAlternatives(i) & ","
Next i
s = s & sAlternatives(Ubound(sAlternatives))
oDestinationText.insertString(oDestinationCursor,sMistake & ": " & s & Chr(13),False)
End If
Loop While oSourceCursor.gotoNextWord(False)
End Sub
我不知道字典，但是，在回答您之前的评论时，如果您将以下代码粘贴到 Loop While 下方和 End Sub 上方，它将在新打开的 Writer 中生成文本文档被排序，没有重复。它不是很优雅，但它适用于我尝试过的文本。
oDestinationCursor.gotoStart(False)
oDestinationCursor.gotoEnd(True)
Dim oSortDescriptor As Object
oSortDescriptor = oDestinationCursor.createSortDescriptor()
oDestinationCursor.sort(oSortDescriptor)
Dim sParagraphToBeChecked As String
Dim sThisWord As String
sThisWord = ""
Dim sPreviousWord As String
sPreviousWord = ""
oDestinationCursor.gotoStart(False)
oDestinationCursor.collapseToStart()
Dim k As Integer
Do
oDestinationCursor.gotoEndOfParagraph(True)
sParagraphToBeChecked = oDestinationCursor.getString()
k = InStr(sParagraphToBeChecked,":")
If k <> 0 Then
sThisWord = Left(sParagraphToBeChecked,k-1)
End If
If StrComp(sThisWord,sPreviousWord,0) = 0 Then
oDestinationCursor.setString("")
End If
sPreviousWord = sThisWord
Loop While oDestinationCursor.gotoNextParagraph(False)
Dim oReplaceDescriptor As Object
oReplaceDescriptor = oDestination.createReplaceDescriptor()
oReplaceDescriptor.setPropertyValue("SearchRegularExpression",TRUE)
oReplaceDescriptor.setSearchString("^$")
oReplaceDescriptor.setReplaceString("")
oDestination.replaceAll(oReplaceDescriptor)
我似乎没有发现这一点，因为我测试它的文本仅包含正确的单词或具有多个替代选项的单词。我设法通过输入一个由拼写检查器无法建议任何替代方案的随机字符组成的单词来复制错误。如果没有找到替代方案，函数 .getAlternatives() 返回一个大小为 -1 的数组，因此可以通过在使用数组之前测试此条件来避免错误。下面是添加了这样一个条件的子例程中第一个 Do 循环的修改版本。如果你用它替换现有的循环，它应该消除错误。
Do
oSourceCursor.gotoEndOfWord(True)
sMistake = oSourceCursor.getString()
bTest = oSpeller.isValid(sMistake,emptyArgs())
If Not bTest Then
oSpell = oSpeller.spell(sMistake,emptyArgs())
sAlternatives = oSpell.getAlternatives()
s = ""
If Ubound(sAlternatives) >= 0 Then
for i = LBound(sAlternatives) To Ubound(sAlternatives) - 1
s = s & sAlternatives(i) & ","
Next i
s = s & sAlternatives(Ubound(sAlternatives))
End If
oDestinationText.insertString(oDestinationCursor,False)
End If
Loop While oSourceCursor.gotoNextWord(False)
在重新阅读整个子程序时，我认为如果将变量 sMistake 重命名为类似 sWordToBeChecked 的内容会提高其可读性，因为该变量包含的字符串并不总是拼写错误。这当然需要在例程中的任何地方进行更改，而不仅仅是在上面的代码片段中。
下面是一个修改版本，它使用了 Jim K 在他的回答 go to end of word is not always followed 中建议的调度程序。我已经把它完整地写出来了，因为这些变化比仅仅添加或替换一个块更广泛。特别是，在创建空的目标文档之前需要获取视图光标，否则例程会拼写检查。
Sub ListMisSpelledWords2
' From OOME Listing 315 Page 336
GlobalScope.BasicLibraries.loadLibrary( "Tools" )
Dim sLocale As String
sLocale = GetRegistryKeyContent("org.openoffice.Setup/L10N",Len(sLocale) -nDash )
Dim oSourceDocument As Object
oSourceDocument = ThisComponent
Dim nWordCount as Integer
nWordCount = oSourceDocument.WordCount
Dim oFrame As Object,oViewCursor As Object
With oSourceDocument.getCurrentController
oFrame = .getFrame()
oViewCursor = .getViewCursor()
End With
Dim oDispatcher as Object
oDispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
oDispatcher.executeDispatch(oFrame,".uno:GoToStartOfDoc","",Array())
Dim oDestinationDocument As Object
oDestinationDocument = StarDesktop.loadComponentFromURL( "private:factory/swriter",Array() )
Dim oDestinationText as Object
oDestinationText = oDestinationDocument.getText()
Dim oDestinationCursor As Object
oDestinationCursor = oDestinationText.createTextCursor()
Dim oSpeller As Object
oSpeller = createUnoService("com.sun.star.linguistic2.SpellChecker")
Dim oSpellAlternatives As Object,i as Integer
For i = 0 To nWordCount - 1
oDispatcher.executeDispatch(oFrame,".uno:WordRightSel",Array())
sWordToBeChecked = RTrim( oViewCursor.String )
bTest = oSpeller.isValid(sWordToBeChecked,emptyArgs())
If Not bTest Then
oSpell = oSpeller.spell(sWordToBeChecked,emptyArgs())
sAlternatives = oSpell.getAlternatives()
s = ""
If Ubound(sAlternatives) >= 0 Then
for i = LBound(sAlternatives) To Ubound(sAlternatives) - 1
s = s & sAlternatives(i) & ","
Next i
s = s & sAlternatives(Ubound(sAlternatives))
End If
oDestinationText.insertString(oDestinationCursor,sWordToBeChecked & ": " & s & Chr(13),False)
End If
oDispatcher.executeDispatch(oFrame,".uno:GoToPrevWord",Array())
oDispatcher.executeDispatch(oFrame,".uno:GoToNextWord",Array())
Next i
oDestinationCursor.gotoStart(False)
oDestinationCursor.gotoEnd(True)
' Sort the paragraphs
Dim oSortDescriptor As Object
oSortDescriptor = oDestinationCursor.createSortDescriptor()
oDestinationCursor.sort(oSortDescriptor)
' Remove duplicates
Dim sParagraphToBeChecked As String,sThisWord As String,sPreviousWord As String
sThisWord = ""
sPreviousWord = ""
oDestinationCursor.gotoStart(False)
oDestinationCursor.collapseToStart()
Dim k As Integer
Do
oDestinationCursor.gotoEndOfParagraph(True)
sParagraphToBeChecked = oDestinationCursor.getString()
k = InStr(sParagraphToBeChecked,":")
If k <> 0 Then
sThisWord = Left(sParagraphToBeChecked,k-1)
End If
If StrComp(sThisWord,0) = 0 Then
oDestinationCursor.setString("")
End If
sPreviousWord = sThisWord
Loop While oDestinationCursor.gotoNextParagraph(False)
' Remove empty paragraphs
Dim oReplaceDescriptor As Object
oReplaceDescriptor = oDestinationDocument.createReplaceDescriptor()
oReplaceDescriptor.setPropertyValue("SearchRegularExpression",TRUE)
oReplaceDescriptor.setSearchString("^$")
oReplaceDescriptor.setReplaceString("")
oDestinationDocument.replaceAll(oReplaceDescriptor)
End Sub
首先，针对您关于该错误的问题，我不是维护者，因此无法修复。但是，由于该错误涉及将文本光标移动到单词的开头和结尾，因此应该可以通过搜索单词之间的空格来绕过它。由于空白字符（我认为）在所有语言中都是相同的，因此识别某些字母中的某些字符的任何问题都无关紧要。最简单的方法是首先将文档的整个文本读入一个字符串，但 LibreOffice 字符串的最大长度为 2^16 = 65536 个字符，虽然这看起来很多，但很容易太小而无法合理大小的文档。可以通过一次浏览一段文本来避免这种限制。根据 Andrew Pitonyak（OOME 第 388 页）的说法：“我发现 gotoNextSentence() 和 gotoNextWord() 不可靠，但段落光标运行良好。”
下面的代码是对之前答案中子例程的又一次修改。这次它从段落中获取一个字符串，并通过查找单词之间的空格将其拆分为单词。然后像以前一样拼写检查单词。该子例程依赖于它下面列出的一些其他函数。这些允许您指定将哪些字符指定为单词分隔符（即空格）以及如果在单词的开头或结尾找到哪些字符要忽略。这是必要的，例如，被引用的单词周围的引号不会被算作单词的一部分，这会导致即使引号内的单词拼写正确，它也会被识别为拼写错误。
我不熟悉非拉丁字母，也没有安装合适的字典，但我粘贴了您问题 go to end of word is not always followed 中的单词，即 testी、भारत 和 इंडिया，它们都未修改地出现在输出文档。
在查找同义词的问题上，由于每个拼错的单词都有多个建议，并且每个建议都有多个同义词，因此输出可能会迅速变得非常大且令人困惑。如果您的用户想要使用不同的词，最好单独查找它们。
Sub ListMisSpelledWords3
' From OOME Listing 315 Page 336
GlobalScope.BasicLibraries.loadLibrary( "Tools" )
Dim sLocale As String
sLocale = GetRegistryKeyContent("org.openoffice.Setup/L10N","-")
Dim aLocale As New com.sun.star.lang.Locale
aLocale.Language = Left( sLocale,nDash - 1)
aLocale.Country = Right( sLocale,Len(sLocale) - nDash )
Dim oSource As Object
oSource = ThisComponent
Dim oSourceCursor As Object
oSourceCursor = oSource.getText.createTextCursor()
oSourceCursor.gotoStart(False)
oSourceCursor.collapseToStart()
Dim oDestination As Object
oDestination = StarDesktop.loadComponentFromURL( "private:factory/swriter",emptyArgs() as new com.sun.star.beans.PropertyValue
Dim sWordToCheck as String,bTest As Boolean
Dim s As String,i as Integer,j As Integer,sParagraph As String,nWordStart As Integer,nWordEnd As Integer
Dim nChar As Integer
Do
oSourceCursor.gotoEndOfParagraph(True)
sParagraph = oSourceCursor.getString() & " " 'It is necessary to add a space to the end of
'the string otherwise the last word of the paragraph is not recognised.
nWordStart = 1
nWordEnd = 1
For i = 1 to Len(sParagraph)
nChar = ASC(Mid(sParagraph,i,1))
If IsWordSeparator(nChar) Then '1
If nWordEnd > nWordStart Then '2
sWordToCheck = TrimWord( Mid(sParagraph,nWordStart,nWordEnd - nWordStart) )
bTest = oSpeller.isValid(sWordToCheck,emptyArgs())
If Not bTest Then '3
oSpell = oSpeller.spell(sWordToCheck,emptyArgs())
sAlternatives = oSpell.getAlternatives()
s = ""
If Ubound(sAlternatives) >= 0 Then '4
for j = LBound(sAlternatives) To Ubound(sAlternatives) - 1
s = s & sAlternatives(j) & ","
Next j
s = s & sAlternatives(Ubound(sAlternatives))
End If '4
oDestinationText.insertString(oDestinationCursor,sWordToCheck & " : " & s & Chr(13),False)
End If '3
End If '2
nWordEnd = nWordEnd + 1
nWordStart = nWordEnd
Else
nWordEnd = nWordEnd + 1
End If '1
Next i
Loop While oSourceCursor.gotoNextParagraph(False)
oDestinationCursor.gotoStart(False)
oDestinationCursor.gotoEnd(True)
Dim oSortDescriptor As Object
oSortDescriptor = oDestinationCursor.createSortDescriptor()
oDestinationCursor.sort(oSortDescriptor)
Dim sParagraphToBeChecked As String
Dim sThisWord As String
sThisWord = ""
Dim sPreviousWord As String
sPreviousWord = ""
oDestinationCursor.gotoStart(False)
oDestinationCursor.collapseToStart()
Dim k As Integer
Do
oDestinationCursor.gotoEndOfParagraph(True)
sParagraphToBeChecked = oDestinationCursor.getString()
k = InStr(sParagraphToBeChecked,k-1)
End If
If StrComp(sThisWord,0) = 0 Then
oDestinationCursor.setString("")
End If
sPreviousWord = sThisWord
Loop While oDestinationCursor.gotoNextParagraph(False)
Dim oReplaceDescriptor As Object
oReplaceDescriptor = oDestination.createReplaceDescriptor()
oReplaceDescriptor.setPropertyValue("SearchRegularExpression",TRUE)
oReplaceDescriptor.setSearchString("^$")
oReplaceDescriptor.setReplaceString("")
oDestination.replaceAll(oReplaceDescriptor)
End Sub
'----------------------------------------------------------------------------
' From OOME Listing 360.
Function IsWordSeparator(iChar As Integer) As Boolean
' Horizontal tab \t 9
' New line \n 10
' Carriage return \r 13
' Space 32
' Non-breaking space 160
Select Case iChar
Case 9,10,13,32,160
IsWordSeparator = True
Case Else
IsWordSeparator = False
End Select
End Function
'-------------------------------------
' Characters to be trimmed off beginning of word before spell checking
Function IsPermissiblePrefix(iChar As Integer) As Boolean
' Symmetric double quote " 34
' Left parenthesis ( 40
' Left square bracket [ 91
' Back-tick ` 96
' Left curly bracket { 123
' Left double angle quotation marks « 171
' Left single quotation mark ‘ 8216
' Left single reversed 9 quotation mark ‛ 8219
' Left double quotation mark “ 8220
' Left double reversed 9 quotation mark ‟ 8223
Select Case iChar
Case 34,40,91,96,123,171,8216,8219,8220,8223
IsPermissiblePrefix = True
Case Else
IsPermissiblePrefix = False
End Select
End Function
'-------------------------------------
' Characters to be trimmed off end of word before spell checking
Function IsPermissibleSuffix(iChar As Integer) As Boolean
' Exclamation mark ! 33
' Symmetric double quote " 34
' Apostrophe ' 39
' Right parenthesis ) 41
' Comma,44
' Full stop . 46
' Colon : 58
' Semicolon ; 59
' Question mark ? 63
' Right square bracket ] 93
' Right curly bracket } 125
' Right double angle quotation marks » 187
' Right single quotation mark ‘ 8217
' Right double quotation mark “ 8221
Select Case iChar
Case 33,34,39,41,44,46,58,59,63,93,125,187,8217,8221
IsPermissibleSuffix = True
Case Else
IsPermissibleSuffix = False
End Select
End Function
'-------------------------------------
Function TrimWord( sWord As String) As String
Dim n as Integer
n = Len(sWord)
If n > 0 Then
Dim m as Integer : m = 1
Do While IsPermissiblePrefix( ASC(Mid(sWord,m,1) ) ) And m <= n
m = m + 1
Loop
Do While IsPermissibleSuffix( ASC(Mid(sWord,n,1) ) ) And n >= 1
n = n - 1
Loop
If n > m Then
TrimWord = Mid(sWord,(n + 1) - m)
Else
TrimWord = sWord
End If
Else
TrimWord = ""
End If
End Function