I would like to know if there is a way to create hyperlinks from a text in bulk.
I have the following text:
www. abc .com/pictures/T_1.jpg
www. abc. com/pictures/T_2.jpg
www. abc. com/pictures/T_3.jpg
www. abc. com/pictures/T_4.jpg
Each text is a link in its own right, but if I select all and press Ctrl+K, I cannot create a hyperlink that takes the text as a weblink. I can do it one by one. If I select any of the text and press Ctrl+K, it'll give me www.abc.com/pictures/T_1.jpg as the web address for that link, but not in bulk. How to do it?
Note: spaces in the links to avoid posting errors.
Please try this,
Paste links in word and separate them by a paragraph,
Select the links and Insert -> Table -> Convert to Table,
View -> Macros -> View Macros and create the following macro named BH
Sub BH()
Dim Rng As Range, TblCell As Cell, StrTxt As String
With Selection
If .Information(wdWithInTable) = False Then Exit Sub
For Each TblCell In .Cells
Set Rng = TblCell.Range
With Rng
.End = .End - 1
StrTxt = .Text
.Text = ""
End With
ActiveDocument.Hyperlinks.Add Anchor:=Rng, _
Address:="Address", SubAddress:="SubAddress", _
ScreenTip:="", TextToDisplay:=StrTxt, Target:="_blank"
Next
End With
End Sub
For what you have described:
Sub ConvertURLTextsToHyperlinksInDoc()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[wh][wt][wtps]{1,3}[./][!^13^t^l ^s]{1,}"
.Replacement.Text = ""
.Forward = True
.Format = False
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If .Characters.Last Like "[:;.,(?)!})]" Then .End = .End - 1
.Hyperlinks.Add .Duplicate, .Text, , , .Text
.Start = .Hyperlinks(1).Range.End
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
The text you posted, though, does not include valid URLs - there are spaces either side of abc...
As per google group, this macro can be used to print mis-spelled words in MS office.
https://groups.google.com/g/microsoft.public.word.spelling.grammar/c/OiFYPkLAbeU
Is there similar option in libre-office writer?
The following Subroutine replicates what the code in the Google group does. It is more verbose than the MS version but that is to be expected with LibreOffice / OpenOffice. It only does the spellchecker lines and not the green grammar checker ones, which is also the case with the MS version in the Google group.
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,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
This will change the actual formatting of the font to have a red wavy underline, which will print out like any other formatting. If any of the misspelled words in the document already have some sort of underlining then that will be lost.
You will probably want to remove the underlining after you have printed it. The following Sub removes underlining only where its style exactly matches that of the line added by the first routine.
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,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
This will not restore any original underlining that was replaced by red wavy ones. Other ways of removing the wavy lines that would restore these are:
Pressing undo (Ctrl Z) but you will need to do that once for every word in your document, which could be a bit of a pain.
Running the subroutine UnderlineMisspelledWords on a temporary copy of the document and then discarding it after printing.
I hope this is what you were looking for.
In response to your above comment, it is straightforward to modify the above subroutine to do that instead of drawing wavy lines. The code below opens a new Writer document and writes into it a list of the misspelled words together with the alternatives that the spellchecker suggests:
Sub ListMisSpelledWords
' 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 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", 0, 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, aLocale, emptyArgs())
If Not bTest Then
oSpell = oSpeller.spell(sMistake, aLocale, 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
I don't know about the dictionaries but, in answer to your previous comment, if you paste the following code below Loop While and above End Sub it will result in the text in the newly opened Writer document being sorted without duplicates. It's not very elegant but it works on the text I've tried it on.
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)
It seems I didn't spot that because the text I tested it on contained only words that were either correct or had more than zero alternatives. I managed to replicate the error by putting in a word consisting of random characters for which the spellchecker was unable to suggest any alternatives. If no alternatives are found the function .getAlternatives() returns an array of size -1 so the error can be avoided by testing for this condition before the array is used. Below is a modified version of the first Do loop in the subroutine with such a condition added. If you replace the existing loop with that it should eliminate the error.
Do
oSourceCursor.gotoEndOfWord(True)
sMistake = oSourceCursor.getString()
bTest = oSpeller.isValid(sMistake, aLocale, emptyArgs())
If Not bTest Then
oSpell = oSpeller.spell(sMistake, aLocale, 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, sMistake & ": " & s & Chr(13), False)
End If
Loop While oSourceCursor.gotoNextWord(False)
On re-reading the whole subroutine I think it would improve its readability if the variable sMistake were renamed to something like sWordToBeChecked, as the string this variable contains isn't always misspelled. This would of course need to be changed everywhere in the routine and not just in the above snippet.
Below is a modified version that uses the dispatcher as suggested by Jim K in his answer go to end of word is not always followed. I have written it out in its entirety because the changes are more extensive than just adding or replacing a block. In particular, it is necessary to get the view cursor before creating the empty destination document, otherwise the routine will spell check that.
Sub ListMisSpelledWords2
' 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 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", "", 0, Array())
Dim oDestinationDocument As Object
oDestinationDocument = StarDesktop.loadComponentFromURL( "private:factory/swriter", "_blank", 0, 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, 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
For i = 0 To nWordCount - 1
oDispatcher.executeDispatch(oFrame, ".uno:WordRightSel", "", 0, Array())
sWordToBeChecked = RTrim( oViewCursor.String )
bTest = oSpeller.isValid(sWordToBeChecked, aLocale, emptyArgs())
If Not bTest Then
oSpell = oSpeller.spell(sWordToBeChecked, aLocale, 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", "", 0, Array())
oDispatcher.executeDispatch(oFrame, ".uno:GoToNextWord", "", 0, 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, sPreviousWord, 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
It looks like the problem is caused by one of the while loops in the function TrimWord, which removes punctuation from before and after a word before it is fed to the spell-check service. If the word is only one character long and if it is a valid punctuation character then the condition at the beginning of the loop is true, so the loop is entered and the counter n is decremented to zero. Then at the beginning of the next traversal of the loop, even though the condition is false anyway, it still asks the Mid function to return the 0th character of the word, which it can't do because the characters are numbered from 1, so it throws an error. Some languages would ignore the error if the truth value of the condition could be unambiguously determined from the other parts of the expression. It looks like BASIC doesn't do that.
The following modified version of the function gets round the problem in a rather inelegant way, but it seems to work:
Function TrimWord(sWord As String) As String
Dim n as Long
n = Len(sWord)
If n > 0 Then
Dim m as Long : m = 1
Dim bTest As Boolean
bTest = m <= n
Do While IsPermissiblePrefix( ASC(Mid(sWord, m, 1) ) ) And bTest
if (m < n) Then
m = m + 1
Else
bTest = False
End If
Loop
bTest = n > 0
Do While IsPermissibleSuffix( ASC(Mid(sWord, n, 1) ) ) And bTest
if (n > 1) Then
n = n - 1
Else
bTest = False
End If
Loop
If n > m Then
TrimWord = Mid(sWord, m, (n + 1) - m)
Else
TrimWord = sWord
End If
Else
TrimWord = ""
End If
End Function
This works for me.
Firstly, in response to your question about the bug, I'm not a maintainer so I can't fix that. However, as the bug concerns moving a text cursor to the start and end of a word it should be possible to get round it by searching for the white-space between words instead. Since the white-space characters are (I think) the same in all languages, any problems recognising certain characters from certain alphabets shouldn't matter. The easiest way to do it would be to first read the entire text of the document into a string but LibreOffice strings have a maximum length of 2^16 = 65536 characters and while this seems like a lot it could easily be too small for a reasonable sized document. The limit can be avoided by navigating through the text one paragraph at a time. According to Andrew Pitonyak (OOME Page 388): "I found gotoNextSentence() and gotoNextWord() to be unreliable, but the paragraph cursor worked well."
The code below is yet another modification of the subroutines in previous answers. This time it gets a string from a paragraph and splits it up into words by finding the white-space between the words. It then spell checks the words as before. The subroutine depends on some other functions that are listed below it. These allow you to specify which characters to designate as word separators (i.e. white-space) and which characters to ignore if they are found at the beginning or end of a word. This is necessary so that, for example, the quotes surrounding a quoted word are not counted as part of the word, which would lead to it being recognised as a spelling mistake even if the word inside the quotes is correctly spelled.
I am not familiar with non-latin alphabets and I don't have an appropriate dictionary installed, but I pasted the words from your question go to end of word is not always followed, namely testी, भारत and इंडिया and they all appeared unmodified in the output document.
On the question of looking up synonyms, as each misspelled word has multiple suggestions, and each of those will have multiple synonyms, the output could rapidly become very large and confusing. It may be better for your user to look them up individually if they want to use a different word.
Sub ListMisSpelledWords3
' 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 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", 0, 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 sWordToCheck as String, oSpell As Object, sAlternatives() 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, aLocale, emptyArgs())
If Not bTest Then '3
oSpell = oSpeller.spell(sWordToCheck, aLocale, 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, ":")
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)
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, m, (n + 1) - m)
Else
TrimWord = sWord
End If
Else
TrimWord = ""
End If
End Function
In LibreOffice Basic sub I use a bunch of uno properties in an array. Which is the simplest Unostructure or UnoService that I must "embed" them, in order to use the getByName "function"?
Example:
dim props(1) as new com.sun.star.beans.PropertyValue
props(0).Name = "blahblah1"
props(0).Value = "blahblah1Value"
props(1).Name = "blahblah2"
props(1).Name = 3000
I want to be able to use something like:
b = props.getByName("blahblah2").Value
or something like (assuming I "assigned" them in a structure-like-object called "somestruct") :
b = somestruct.getprops.getByName("blahblah2").Value
As I understand that this can be done by creating a "UnoService" which supports the getByName and then, somehow, assigning these props to this service
Which is the "lightest" such service?
(I mean the service that uses less resources)
Thanks in advance.
Really supporting the interface XNameAccess is not as easy. The services which implement this interface are supposed using this interface for existing named properties, not for own created ones.
But you can use the service EnumerableMap to achieve what you probably want.
Example:
sub testEnumerableMap
serviceEnumerableMap = com.sun.star.container.EnumerableMap
oEnumerableMap = serviceEnumerableMap.create("string", "any")
oEnumerableMap.put("blahblah1", "blahblah1Value")
oEnumerableMap.put("blahblah2", 3000)
oEnumerableMap.put("blahblah3", 1234.67)
msgbox oEnumerableMap.get("blahblah1")
msgbox oEnumerableMap.get("blahblah2")
msgbox oEnumerableMap.get("blahblah3")
'msgbox oEnumerableMap.get("blahblah4") 'will throw error
msgbox oEnumerableMap.containsKey("blahblah2")
msgbox oEnumerableMap.containsValue(3000)
if oEnumerableMap.containsKey("blahblah4") then
msgbox oEnumerableMap.get("blahblah4")
end if
end sub
But starbasic with option Compatible is also able supporting Class programming like VBA does.
Example:
Create a module named myPropertySet. Therein put the following code:
option Compatible
option ClassModule
private aPropertyValues() as com.sun.star.beans.PropertyValue
public sub setProperty(oProp as com.sun.star.beans.PropertyValue)
bUpdated = false
for each oPropPresent in aPropertyValues
if oPropPresent.Name = oProp.Name then
oPropPresent.Value = oProp.Value
bUpdated = true
exit for
end if
next
if not bUpdated then
iIndex = ubound(aPropertyValues) + 1
redim preserve aPropertyValues(iIndex)
aPropertyValues(iIndex) = oProp
end if
end sub
public function getPropertyValue(sName as string) as variant
getPropertyValue = "N/A"
for each oProp in aPropertyValues
if oProp.Name = sName then
getPropertyValue = oProp.Value
exit for
end if
next
end function
Then within a standard module:
sub testClass
oPropertySet = new myPropertySet
dim prop as new com.sun.star.beans.PropertyValue
prop.Name = "blahblah1"
prop.Value = "blahblah1Value"
oPropertySet.setProperty(prop)
prop.Name = "blahblah2"
prop.Value = 3000
oPropertySet.setProperty(prop)
prop.Name = "blahblah3"
prop.Value = 1234.56
oPropertySet.setProperty(prop)
prop.Name = "blahblah2"
prop.Value = 8888
oPropertySet.setProperty(prop)
msgbox oPropertySet.getPropertyValue("blahblah1")
msgbox oPropertySet.getPropertyValue("blahblah2")
msgbox oPropertySet.getPropertyValue("blahblah3")
msgbox oPropertySet.getPropertyValue("blahblah4")
end sub
LibreOffice Basic supports the vb6 Collection type.
Dim coll As New Collection
coll.Add("blahblah1Value", "blahblah1")
coll.Add(3000, "blahblah2")
MsgBox(coll("blahblah1"))
Arrays of property values are the only thing that will work for certain UNO interfaces such as dispatcher calls. If you simply need a better way to deal with arrays of property values, then use a helper function.
Sub DisplayMyPropertyValue
Dim props(0 To 1) As New com.sun.star.beans.PropertyValue
props(0).Name = "blahblah1"
props(0).Value = "blahblah1Value"
props(1).Name = "blahblah2"
props(1).Name = 3000
MsgBox(GetPropertyByName(props, "blahblah1"))
End Sub
Function GetPropertyByName(props As Array, propname As String)
For Each prop In props
If prop.Name = propname Then
GetPropertyByName = prop.Value
Exit Function
End If
Next
GetPropertyByName = ""
End Function
XNameAccess is used for UNO containers such as Calc sheets. Normally these containers are obtained from the UNO interface, not created.
oSheet = ThisComponent.Sheets.getByName("Sheet1")
May UNO objects support the XPropertySet interface. Normally these are also obtained from the UNO interface, not created.
paraStyleName = cellcursor.getPropertyValue("ParaStyleName")
It may be possible to create a new class in Java that implements XPropertySet. However, Basic uses helper functions instead of class methods.
I think the serviceEnumerableMap is the answer (so far). Creating the values and searching them was much faster then creating props in a dynamic array and searching them with a for loop in basic.
(I do not "dare" to use "option Compatible", although I was a big fun of VB6 and VBA, because of the problems in code that maybe arise).
I used this code to test time in a form:
SUB testlala(Event)
TESTPROPS(Event)
' TESTENUM(Event)
MSGBOX "END OF TEST"
END SUB
SUB TESTENUM(Event)
DIM xcounter AS LONG
'b = now()
serviceEnumerableMap = com.sun.star.container.EnumerableMap
oEnumerableMap = serviceEnumerableMap.create("string", "any")
FOR xcounter= 0 TO 10000
oEnumerableMap.put("pr" & FORMAT(xcounter,"0000"), xcounter -10000)
NEXT
'b=now()-b
b = now()
FOR xcounter = 1 TO 5000
lala = Int((9000 * Rnd) +1)
g =oEnumerableMap.get("pr" & FORMAT(lala,"0000"))
'MSGBOX GetValueFromName(props,"pr" & FORMAT(xcounter,"0000"))
NEXT
b=now()-b
MSGBOX b*100000
END SUB
SUB TESTPROPS(Event)
DIM props()
DIM xcounter AS LONG
'b = now()
FOR xcounter= 0 TO 10000
AppendProperty(props,"pr" & FORMAT(xcounter,"0000"), xcounter -10000)
NEXT
'b=now()-b
b = now()
FOR xcounter = 1 TO 5000
lala = Int((9000 * Rnd) +1)
g = GetValueFromName(props,"pr" & FORMAT(lala,"0000"))
'MSGBOX GetValueFromName(props,"pr" & FORMAT(xcounter,"0000"))
NEXT
b=now()-b
MSGBOX b*100000
END SUB
REM FROM Andrew Pitonyak's OpenOffice Macro Information ------------------
Sub AppendToArray(oData(), ByVal x)
Dim iUB As Integer 'The upper bound of the array.
Dim iLB As Integer 'The lower bound of the array.
iUB = UBound(oData()) + 1
iLB = LBound(oData())
ReDim Preserve oData(iLB To iUB)
oData(iUB) = x
End Sub
Function CreateProperty(sName$, oValue) As com.sun.star.beans.PropertyValue
Dim oProperty As New com.sun.star.beans.PropertyValue
oProperty.Name = sName
oProperty.Value = oValue
CreateProperty() = oProperty
End Function
Sub AppendProperty(oProperties(), sName As String, ByVal oValue)
AppendToArray(oProperties(), CreateProperty(sName, oValue))
End Sub
Using an ActiveX server from MATLAB, I am trying to highlight many cells in an Excel sheet at once. These are not in specific columns or rows so I use Range('A1,B2,...') to access them. However the string accepted by the Range object has to be less than 255 characters or an error:
Error: Object returned error code: 0x800A03EC
is thrown. The following code reproduces this error with an empty Excel file.
hActX = actxserver('Excel.Application');
hWB = hActX.Workbooks.Open('C:\Book1.xlsx');
hSheet = hWB.Worksheets.Item('Sheet1');
col = repmat('A', 100, 1);
row = num2str((1:100)'); %'
cellInd = strcat(col, strtrim(cellstr(row)));
str1 = strjoin(cellInd(1:66), ','); %// 254 characters
str2 = strjoin(cellInd(1:67), ','); %// 258 characters
hSheet.Range(str1).Interior.Color = 255; %// Works
hSheet.Range(str2).Interior.Color = 255; %// Error 0x800A03EC
hWB.Save;
hWB.Close(false);
hActX.Quit;
How can I get around this? I found no other relevant method of calling Range, or of otherwise getting the cells I want to modify.
If you start with a String, you can test its length to determine if Range() can handle it. Here is an example of building a diagonal range:
Sub DiagonalRange()
Dim BigString As String, BigRange As Range
Dim i As Long, HowMany As Long, Ln As String
HowMany = 100
For i = 1 To HowMany
BigString = BigString & "," & Cells(i, i).Address(0, 0)
Next i
BigString = Mid(BigString, 2)
Ln = Len(BigString)
MsgBox Ln
If Ln < 250 Then
Set BigRange = Range(BigString)
Else
Set BigRange = Nothing
arr = Split(BigString, ",")
For Each a In arr
If BigRange Is Nothing Then
Set BigRange = Range(a)
Else
Set BigRange = Union(BigRange, Range(a))
End If
Next a
End If
BigRange.Select
End Sub
For i = 10, the code will the the direct method, but if the code were i=100, the array method would be used.
The solution, as Rory pointed out, is to use the Union method. To minimize the number of calls from MATLAB to the ActiveX server, this is what I did:
str = strjoin(cellInd, ',');
isep = find(str == ',');
isplit = diff(mod(isep, 250)) < 0;
isplit = [isep(isplit) (length(str) + 1)];
hRange = hSheet.Range(str(1:(isplit(1) - 1)));
for ii = 2:numel(isplit)
hRange = hActX.Union(hRange, ...
hSheet.Range(str((isplit(ii-1) + 1):(isplit(ii) - 1))));
end
I used 250 in the mod to account for the cell names being up to 6 characters long, which is sufficient for me.
I searched but couldn't find what I'm looking for.
How do I convert a normal Date() in ASP Classic to a string in the format dd-monthname-YYYY?
Here is an example:
Old date (mm/dd/YYYY) : 5/7/2013
New date (dd-monthname-YYYY) : 7-May-2013
Dim Dt
Dt = CDate("5/7/2013")
Response.Write Day(Dt) & "-" & MonthName(Month(Dt)) & "-" & Year(Dt)
' yields 7-May-2013
' or if you actually want dd-monthname-YYYY instead of d-monthname-YYYY
Function PadLeft(Value, Digits)
PadLeft = CStr(Value)
If Len(PadLeft) < Digits Then
PadLeft = Right(String(Digits, "0") & PadLeft, Digits)
End If
End Function
Response.Write PadLeft(Day(Dt), 2) & "-" & MonthName(Month(Dt)) & "-" & Year(Dt)
'yields 07-May-2013
I wrote an ASP Classic date handling object a while back that might be of use to you. It has a .Format() method that lets you pass in format specifiers just like the Format() function from VB/VBA. If there are any parts missing, I apologize--but this should be a giant leap forward toward natural date formatting.
Private pMillisecondMatch
Function RemoveMillisecondsFromDateString(DateString) ' Handle string dates from SQL Server that have milliseconds attached
If IsEmpty(pMillisecondMatch) Then
Set pMillisecondMatch = New RegExp
pMillisecondMatch.Pattern = "\.\d\d\d$"
pMillisecondMatch.Global = False
End If
RemoveMillisecondsFromDateString = pMillisecondMatch.Replace(DateString, "")
End Function
Function DateConvert(DateValue, ValueIfError)
On Error Resume Next
If IsDate(DateValue) Then
DateConvert = CDate(DateValue)
Exit Function
ElseIf TypeName(DateValue) = "String" Then
DateValue = RemoveMillisecondsFromDateString(DateValue)
If IsDate(DateValue) Then
DateConvert = CDate(DateValue)
Exit Function
End If
End If
DateConvert = ValueIfError
End Function
Class AspDate
Private pValue
Public Default Property Get Value()
Value = pValue
End Property
Public Property Set Value(DateValue)
If TypeName(DateValue) = "AspDate" Then
pValue = DateValue.Value
Else
Err.Raise 60020, "Class AspDate: Invalid object type " & TypeName(DateValue) & " passed to Value property."
End If
End Property
Public Property Let Value(DateValue)
pValue = DateConvert(DateValue, Empty)
End Property
Public Property Get FormattedDate()
FormattedDate = Format("yyyy-mm-dd hh:nn:ss")
End Property
Public Function Format(Specifier)
Dim Char, Code, Pos, MonthFlag
Format = "": Code = ""
If IsEmpty(Value) Then
Format = "(Empty)"
End If
Pos = 0
MonthFlag = False
For Pos = 1 To Len(Specifier) + 1
Char = Mid(Specifier, Pos, 1)
If Char = Left(Code, 1) Or Code = "" Then
Code = Code & Char
Else
Format = Format & Part(Code, MonthFlag)
Code = Char
End If
Next
End Function
Private Function Part(Interval, MonthFlag)
Select Case LCase(Left(Interval, 1))
Case "y"
Select Case Len(Interval)
Case 1, 2
Part = Right(CStr(Year(Value)), 2)
Case 3, 4
Part = Right(CStr(Year(Value)), 4)
Case Else
Part = Right(CStr(Year(Value)), 4)
End Select
Case "m"
If Not MonthFlag Then ' this is a month calculation
MonthFlag = True
Select Case Len(Interval)
Case 1
Part = CStr(Month(Value))
Case 2
Part = Right("0" & CStr(Month(Value)), 2)
Case 3
Part = MonthName(Month(Value), True)
Case 4
Part = MonthName(Month(Value))
Case Else
Part = MonthName(Month(Value))
End Select
Else ' otherwise it's a minute calculation
Part = Right("0" & Minute(Value), 2)
End If
Case "n"
Part = Right("0" & Minute(Value), 2)
Case "d"
Part = CStr(Day(Value))
If Len(Part) < Len(Interval) Then
Part = Right("0" & Part, Len(Interval))
End If
Case "h"
MonthFlag = True
Part = CStr(Hour(Value))
If Len(Part) < Len(Interval) Then
Part = Right("0" & Part, Len(Interval))
End If
Case "s"
Part = Right("0" & Second(Value), 2)
Case Else ' The item is not a recognized date interval, just return the value
Part = Interval
End Select
End Function
End Class
Function NewDate(Value)
Set NewDate = New AspDate
NewDate.Value = Value
End Function
Function NewDateWithDefault(Value, DefaultValue)
Set NewDateWithDefault = New AspDate
If Value = Empty Then
NewDateWithDefault.Value = DefaultValue
Else
NewDateWithDefault.Value = Value
End If
End Function
Here's example code using the above class:
<%=NewDate(Checkin.Parameters.Item("#DOB").Value).Format("mm/dd/yyyy")%>
To get the format you've noted above, you would do:
.Format("d-mmmm-yyyy")