How to find characters in a string - substring

I am trying to use a string from textbox1 and look for the 3rd 'e' and tell the index of it
for example, if somebody typed in cheese, then the index of it
so far, i have
Dim word As String = TextBox2.Text
Dim x As String
Dim counter As Integer
Dim Letter As String
Dim word1 As String
x = 0
word1 = word.ToLower()
Do
If word1.Substring(x, 1) = "e" Then counter = counter + 1 And x = x + 1
Loop Until counter = 3 Or counter <> 3
If counter <> 3 Then MsgBox("There are only " & counter & "e's in the inputted string") Else ListBox2.Items.Add(Letter)

Related

Can you Print the wavy lines generated by Spell check in writer?

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

LinkedStyle for the Word BuiltinStyles

I am extending the capability of the Word report writing from VSTO to consider different languages. Therefore, instead of using the headings like "Heading 1" etc, I have used wdStyleHeading1 etc. I have built a function to assign the style to the heading. The problem is that the line 1 and line 2 below are overwriting each other. If I call the function first, I loose list number and If I call function second, I loose the format. Can you please explain where I am going wrong?
I have imported the necessary references.
Call HeadingListLevel(wrdApp, 1)
wrdApp.Selection.ParagraphFormat.Style = Word.WdBuiltinStyle.wdStyleHeading1
Below is the sub function
Sub HeadingListLevel(wrdApp As Object, HeadingLvl As Integer)
'Dim wrdHeading As String
Dim wrdHeadingNr As String
Dim i As Integer
Dim ListTemp As Word.ListTemplate
wrdHeadingNr = "%" & 1
ListTemp = wrdApp.ListGalleries(Word.WdListGalleryType.wdOutlineNumberGallery).ListTemplates(1)
For i = 1 To HeadingLvl
If i > 1 Then
wrdHeadingNr = wrdHeadingNr & "." & "%" & i
End If
Next i
'wrdHeading = "Heading " & HeadingLvl
With ListTemp.ListLevels(1)
Select Case HeadingLvl
Case 1
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading1
Case 2
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading2
Case 3
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading3
Case 4
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading4
Case 5
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading5
Case 6
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading6
Case 7
.LinkedStyle = Word.WdBuiltinStyle.wdStyleHeading7
End Select
.NumberFormat = wrdHeadingNr
.NumberStyle = Word.WdListNumberStyle.wdListNumberStyleArabic
End With
wrdApp.Selection.Range.ListFormat.ApplyListTemplate(ListTemplate:=ListTemp)
ListTemp = Nothing
End Sub

I discovered the answer myself. Below is the changes to the sub function. It worked well for me.
Sub HeadingListLevel(wrdApp As Object, HeadingLvl As Integer)
'Dim wrdHeading As String
Dim wrdHeadingNr As String
Dim i As Integer
Dim ListTemp As Word.ListTemplate
wrdHeadingNr = "%" & 1
ListTemp = wrdApp.ListGalleries(Word.WdListGalleryType.wdOutlineNumberGallery).ListTemplates(5)
For i = 1 To HeadingLvl
If i > 1 Then
wrdHeadingNr = wrdHeadingNr & "." & "%" & 1
End If
Next i
'wrdHeading = "Heading " & HeadingLvl
With ListTemp.ListLevels(HeadingLvl)
Select Case HeadingLvl
Case 1
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading1).NameLocal
Case 2
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading2).NameLocal
Case 3
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading3).NameLocal
Case 4
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading4).NameLocal
Case 5
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading5).NameLocal
Case 6
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading6).NameLocal
Case 7
.LinkedStyle = wrdApp.ActiveDocument.Styles(Word.WdBuiltinStyle.wdStyleHeading7).NameLocal
End Select
'.LinkedStyle = wrdHeading
.NumberFormat = wrdHeadingNr
.NumberStyle = Word.WdListNumberStyle.wdListNumberStyleArabic
'.StartAt = 1
'.ResetOnHigher = False
End With
wrdApp.Selection.Range.ListFormat.ApplyListTemplate(ListTemplate:=ListTemp)
ListTemp = Nothing
End Sub

VB6 Hashing SHA1 output not matched

need help for my problem here. i do searching and googling for this problem but still don't found the solution why my output didnt matched with the expected output.
data to hash :
0800210142216688003333311100000554478000000
expected output :
DAAC526D4806C88CEDB8B7C6EA42A7442DE6E7DC
my output :
805C790E6BF39E3482067C44909EE126F9CBB878
and i am using this function to generate the hash
Public Function HashString(ByVal Str As String, Optional ByVal Algorithm As HashAlgorithm = SHA1) As String
On Error Resume Next
Dim hCtx As Long
Dim hHash As Long
Dim lRes As Long
Dim lLen As Long
Dim lIdx As Long
Dim AbData() As Byte
lRes = CryptAcquireContext(hCtx, vbNullString, vbNullString, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT)
If lRes <> 0 Then
lRes = CryptCreateHash(hCtx, Algorithm, 0, 0, hHash)
If lRes <> 0 Then
lRes = CryptHashData(hHash, ByVal Str, Len(Str), 0)
If lRes <> 0 Then
lRes = CryptGetHashParam(hHash, HP_HASHSIZE, lLen, 4, 0)
If lRes <> 0 Then
ReDim AbData(0 To lLen - 1)
lRes = CryptGetHashParam(hHash, HP_HASHVAL, AbData(0), lLen, 0)
If lRes <> 0 Then
For lIdx = 0 To UBound(AbData)
HashString = HashString & Right$("0" & Hex$(AbData(lIdx)), 2)
Next
End If
End If
End If
CryptDestroyHash hHash
End If
End If
CryptReleaseContext hCtx, 0
If lRes = 0 Then
MsgBox Err.LastDllError
End If
End Function
and this is command to call the function
Dim received As String
Dim HASH As String
HASH = "0800210142216688003333311100000554478000000"
received = HashString(HASH)
Debug.Print ("HASH VALUE : " & received)
thanks
UPDATE:
finally i managed to get the expected output. i change the function to generate the sha1 using the sha1 function in this website :
http://vb.wikia.com/wiki/SHA-1.bas
and i do use this function to convert my hexstring to byte array
Public Function HexStringToByteArray(ByRef HexString As String) As Byte()
Dim bytOut() As Byte, bytHigh As Byte, bytLow As Byte, lngA As Long
If LenB(HexString) Then
' preserve memory for output buffer
ReDim bytOut(Len(HexString) \ 2 - 1)
' jump by every two characters (in this case we happen to use byte positions for greater speed)
For lngA = 1 To LenB(HexString) Step 4
' get the character value and decrease by 48
bytHigh = AscW(MidB$(HexString, lngA, 2)) - 48
bytLow = AscW(MidB$(HexString, lngA + 2, 2)) - 48
' move old A - F values down even more
If bytHigh > 9 Then bytHigh = bytHigh - 7
If bytLow > 9 Then bytLow = bytLow - 7
' I guess the C equivalent of this could be like: *bytOut[++i] = (bytHigh << 8) || bytLow
bytOut(lngA \ 4) = (bytHigh * &H10) Or bytLow
Next lngA
' return the output
HexStringToByteArray = bytOut
End If
End Function
and i using this command to get the expected output
Dim received As String
Dim HASH As String
Dim intVal As Integer
Dim temp() As Byte
HASH = "08002101422166880033333111000005544780000000"
temp = HexStringToByteArray(HASH)
received = Replace(HexDefaultSHA1(temp), " ", "")
Debug.Print ("HASH VALUE : " & received)
and finally i got the same output as expected. Yeah!!..

805c... is the SHA1 hash of the characters in your input string, i.e. '0', '8', '0', '0', ...
daac... is the SHA1 hash of the characters in your input string after conversion of each pair of hexadecimal digits to a byte, i.e. 0x08, 0x00, ...
Convert the input string to an array of bytes prior to hashing.

Your output is correct. This is SHA1 using python:
>>> import hashlib
>>> s = hashlib.sha1('0800210142216688003333311100000554478000000')
>>> s.hexdigest()
'805c790e6bf39e3482067c44909ee126f9cbb878'
Where did you get the other SHA1 computation from?

Can I perform a count distinct query on values selected from a listbox?

I have a select distinct query that works find on selected fields from a listbox. However I would like it to be a count distinct and I can't seem to get the code right. Below is my working code for select distinct. Thanks in advance for any assistance I've searched for count distinct questions but I don't see any specific to listbox selections.
Private Sub CmdDistinctVal_Click()
Dim cn1 As ADODB.Connection
Dim rs1 As New ADODB.Recordset
Dim cmd1 As New ADODB.Command
Dim varItem As Variant
Dim aFields() As aArray
Dim NumRows As Integer
Dim NumFields As Integer
Dim colcount As Integer
Dim colwidths As String
Dim strRow As String
Dim cnt1 As Integer
Dim cnt2 As Integer
'On Error GoTo Err_ CmdDistinctVal_Click
'cmd1.ActiveConnection = CurrentProject.Connection
Me.DistinctResultsFldVal.RowSource = ""
ReDim aFields(50)
For cnt1 = 1 To 50
ReDim aFields(cnt1).fValue(6000)
Next
NumRows = 0
colcount = 0
For Each varItem In Me!ResultsFieldList.ItemsSelected
colcount = colcount + 1
aFields(colcount).fName = Me!ResultsFieldList.ItemData(varItem)
NumFields = 0
rs1.Open "SELECT DISTINCT " & Me!ResultsFieldList.ItemData(varItem) & "
FROM [Results Report]", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
If rs1.RecordCount > NumRows Then NumRows = rs1.RecordCount
strRow = strRow & Me!ResultsFieldList.ItemData(varItem) & ";"
While Not rs1.EOF
NumFields = NumFields + 1
If NumFields > NumRows Then
NumRows = NumFields
End If
aFields(colcount).fValue(NumFields) = rs1(0) & ""
rs1.MoveNext
Wend
rs1.Close
Next varItem
strRow = Left(strRow, Len(strRow) - 1)
Me.DistinctResultsFldVal.ColumnCount = colcount
Me.DistinctResultsFldVal.ColumnWidths = Mid(colwidths, 2)
Me.DistinctResultsFldVal.AddItem (strRow)
For cnt1 = 1 To NumRows
strRow = ""
For cnt2 = 1 To colcount
If aFields(cnt2).fValue(cnt1) = "" Then
strRow = strRow & ";"
Else
strRow = strRow & aFields(cnt2).fValue(cnt1) & ";"
End If
Next
strRow = Left(strRow, Len(strRow) - 1)
Me.DistinctResultsFldVal.AddItem (strRow)
Next
'Err_ CmdDistinctVal_Click:
'MsgBox "All null values were found in one or more of your selected fields"
End Sub

VBA Copy and paste a range of numbers

I'm trying to copy and paste a range, to create a 28 by 28 grid of numbers "rotating" the values so that each time the range is pasted into the next column, the range is moves down by one row and the last value "overflows" back to the top of the next row, I've got this far but am stumped on the overflow part (i' relative newbie to VBA)
Sub Test()
Dim oRange As Range
Set oRange = ActiveSheet.Range("A1:A28")
Dim i As Integer
For i = 1 To 28
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Next i
End Sub
Also I need to copy and paste values and formatting of the cells
Hope you guys can help
Thanks
Dan

Sub Test()
Dim oRange As Range
Dim startColumn As String
Dim rangeStart As Integer
Dim rangeEnd As Integer
Dim cellCount As Integer
Dim i As Integer
startColumn = "A"
rangeStart = 1
rangeEnd = 28
cellCount = rangeEnd - rangeStart + 1
For i = 1 To cellCount - 1
Set oRange = ActiveSheet.Range(startColumn & rangeStart & _
":" & startColumn & (rangeEnd - i))
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Set oRange = ActiveSheet.Range(startColumn & (rangeEnd - i + 1) & _
":" & startColumn & rangeEnd)
oRange.Copy
oRange.Offset((-1 * cellCount) + i, i).PasteSpecial xlPasteAll
Next i
End Sub
EDIT:
to insert a blanck row at index 'i':
Rows(i & ":" & i).Select
Selection.Insert Shift:=xlDown
to insert 5 rows at the top of the worksheet insert a row 5 times at index 1:
For i = 1 To 5
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Next