1 Attachment(s)
[VB6, Win8+] Using the system spellchecker: Add spellcheck with only a few lines
About
Windows 8 introduced the Spell Checking API, a set of interfaces and a default implementation for the system spellchecker. The ISpellChecker interface is fairly straightforward to use, and returns the positions of words you should autocorrect to a given word, delete entirely, or it offers a list a suggestions if neither of those apply. You can add custom words, custom autocorrects, and words to ignore, and these are automatically saved as you're adding them to the system list (there's a remove option as well) by default, but there's a dictionary registrar that may help (not quite sure how that works yet).
The demo shows basic usage-- it doesn't automatically apply the corrections list yet, maybe in the future.
Requirements
-Windows 8 or newer
-oleexp 4.43 or higher (new release for this project on 5/18)
Code
The basic code for running a spellcheck looks like this:
Code:
Private pSPFact As SpellCheckerFactory
Private pChecker As ISpellChecker
Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Private Sub CheckSpelling(sText As String)
Dim pErrors As IEnumSpellingError
Dim pError As ISpellingError
Dim lStart As Long, lLen As Long
Dim lpsz As Long, sz As String
Dim s1 As String, s2 As String
Dim sSug() As String
Dim nSug As Long
Dim lf As Long
If (pSPFact Is Nothing) Then
Set pSPFact = New SpellCheckerFactory
Set pChecker = pSPFact.CreateSpellChecker(StrPtr(Text3.Text))
End If
Set pErrors = pChecker.Check(StrPtr(sText))
Do While pErrors.Next(pError) = S_OK
Select Case pError.CorrectiveAction
Case CORRECTIVE_ACTION_DELETE
lStart = pError.StartIndex() + 1
lLen = pError.Length()
s1 = Mid$(sText, lStart, lLen)
Text2.Text = Text2.Text & "Delete: " & s1 & vbCrLf
Case CORRECTIVE_ACTION_REPLACE
lStart = pError.StartIndex() + 1
lLen = pError.Length()
s1 = Mid$(sText, lStart, lLen)
lpsz = pError.Replacement()
sz = LPWSTRtoStr(lpsz)
Text2.Text = Text2.Text & "Replace " & s1 & " with " & sz & vbCrLf
Case CORRECTIVE_ACTION_GET_SUGGESTIONS
Dim pIES As IEnumString
lStart = pError.StartIndex() + 1
lLen = pError.Length()
s1 = Mid$(sText, lStart, lLen)
Set pIES = pChecker.Suggest(StrPtr(s1))
ReDim sSug(0)
Do While pIES.Next(1&, lpsz, lf) = S_OK
ReDim Preserve sSug(nSug)
sSug(nSug) = LPWSTRtoStr(lpsz)
nSug = nSug + 1
Loop
Text2.Text = Text2.Text & "Error: " & s1 & "; suggestions: " & Join(sSug, ",") & vbCrLf
End Select
lStart = 0
lLen = 0
lpsz = 0
nSug = 0
Loop
End Sub
Public Function LPWSTRtoStr(lPtr As Long, Optional ByVal fFree As Boolean = True) As String
SysReAllocString VarPtr(LPWSTRtoStr), lPtr
If fFree Then
Call CoTaskMemFree(lPtr)
End If
End Function
(this refers to the textboxes on the form from the demo, it's not a standalone function you can copy and paste without the demo or similar textbox setup)
Re: [VB6, Win8+] Using the system spellchecker: Add spellcheck with only a few lines
Very interesting. It works also in other languages.
Now, trying to find a way to autocorrect while type in textbox.
I'll investigate a bit
Re: [VB6, Win8+] Using the system spellchecker: Add spellcheck with only a few lines
For active autocorrect like that, you could certainly continuously check... if the text you're checking is too long and it slows down, use punctuation to just check the most recent sentence.
All we really need is a good routine to draw that red squiggly line, then full normal spellcheck interface is just a bit of string logic away. Could use RichText and turn whole words red.
Re: [VB6, Win8+] Using the system spellchecker: Add spellcheck with only a few lines
Just tested spell on the fly. And it doens't slow down, even check a whole sentence.
As youi said, now, trying to find a way to draw the red line, and find a way to propose directly an auto correction like in a combo
Re: [VB6, Win8+] Using the system spellchecker: Add spellcheck with only a few lines
This is my version with red line drawn under bad spell errors.
Not perfect, it could be enhanced I think. A small flicker is still there
And Multilne is not handled well
Code:
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Purpose :
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Option Explicit
Private pSPFact As SpellCheckerFactory
Private pChecker As ISpellChecker
Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function GetTextExtentPoint32W Lib "gdi32" (ByVal hdc As Long, ByVal lpsz As Long, ByVal cbString As Long, ByRef lpSize As SizeAPI) As Long
Private Type SizeAPI
cx As Long
cy As Long
End Type
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function LineTo Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
Private Declare Function ExtCreatePen Lib "gdi32.dll" (ByVal dwPenStyle As Long, ByVal dwWidth As Long, ByRef lplb As LOGBRUSH, ByVal dwStyleCount As Long, ByRef lpStyle As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Function LPWSTRtoStr(lPtr As Long, Optional ByVal fFree As Boolean = True) As String
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : LPWSTRtoStr
' * Purpose :
' * Parameters :
' * lPtr As Long
' * Optional ByVal fFree As Boolean = True
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
SysReAllocString VarPtr(LPWSTRtoStr), lPtr
If fFree Then
Call CoTaskMemFree(lPtr)
End If
End Function
Private Sub Command1_Click()
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : Command1_Click
' * Purpose :
' * Parameters :
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Text2.Text = vbNullString
CheckSpelling Text1.Text
End Sub
Private Sub CheckSpelling(sText As String)
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : CheckSpelling
' * Purpose :
' * Parameters :
' * sText As String
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Dim pErrors As IEnumSpellingError
Dim pError As ISpellingError
Dim nStart As Long
Dim nLen As Long
Dim lpsz As Long
Dim sString2 As String
Dim sInvalid As String
Dim sSug() As String
Dim nSug As Long
Dim nFetched As Long
Dim nhDC As Long
Dim oPoint As POINTAPI
Dim oRect As RECT
Dim hPenWhite As Long
Dim hPenRed As Long
Dim hOldPen As Long
Dim nLeft As Long
Dim nRight As Long
Dim nWidth As Long
Dim nHeight As Long
If (pSPFact Is Nothing) Then
Set pSPFact = New SpellCheckerFactory
Set pChecker = pSPFact.CreateSpellChecker(StrPtr(Text3.Text))
End If
If LenB(sText) > 2 Then
Set pErrors = pChecker.Check(StrPtr(sText))
nhDC = GetDC(Text1.hwnd)
Call GetWindowRect(Text1.hwnd, oRect)
nWidth = GetStringWidth(nhDC, "Z")
nHeight = GetStringHeight(nhDC, Text1.Text) + 2
' *
' **
' *** Clean
hPenWhite = CreatePen(0, 1, RGB(255, 255, 255))
hPenRed = CreatePen(0, 1, RGB(255, 0, 0))
MoveToEx nhDC, 0, nHeight, oPoint
hOldPen = SelectObject(nhDC, hPenWhite)
LineTo nhDC, oRect.Right, nHeight
SelectObject nhDC, hOldPen
Do While pErrors.Next(pError) = S_OK
Select Case pError.CorrectiveAction
Case CORRECTIVE_ACTION_DELETE
nStart = pError.StartIndex() + 1
nLen = pError.Length()
sInvalid = Mid$(sText, nStart, nLen)
Text2.Text = Text2.Text & "Delete: " & sInvalid & vbCrLf
Case CORRECTIVE_ACTION_REPLACE
nStart = pError.StartIndex() + 1
nLen = pError.Length()
sInvalid = Mid$(sText, nStart, nLen)
lpsz = pError.Replacement()
sString2 = LPWSTRtoStr(lpsz)
Text2.Text = Text2.Text & "Replace " & sInvalid & " with " & sString2 & vbCrLf
Case CORRECTIVE_ACTION_GET_SUGGESTIONS
Dim pIES As IEnumString
nStart = pError.StartIndex() + 1
nLen = pError.Length()
sInvalid = Mid$(sText, nStart, nLen)
Set pIES = pChecker.Suggest(StrPtr(sInvalid))
ReDim sSug(0)
Do While pIES.Next(1&, lpsz, nFetched) = S_OK
ReDim Preserve sSug(nSug)
sSug(nSug) = LPWSTRtoStr(lpsz)
nSug = nSug + 1
Loop
' *
' **
' *** Draw invalid in red
nLeft = GetStringWidth(nhDC, Left$(Text1.Text, nStart - 1))
nRight = GetStringWidth(nhDC, sInvalid) + 1
MoveToEx nhDC, nLeft, nHeight, oPoint
hOldPen = SelectObject(nhDC, hPenRed)
LineTo nhDC, nLeft + nRight, nHeight
SelectObject nhDC, hOldPen
Text2.Text = Text2.Text & "Error: " & sInvalid & "; suggestions: " & Join(sSug, ",") & vbCrLf
End Select
nStart = 0
nLen = 0
lpsz = 0
nSug = 0
Loop
ReleaseDC Text1.hwnd, nhDC
End If
End Sub
Private Sub Command2_Click()
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : Command2_Click
' * Purpose :
' * Parameters :
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
If (pSPFact Is Nothing) Then
Set pSPFact = New SpellCheckerFactory
Set pChecker = pSPFact.CreateSpellChecker(StrPtr(Text3.Text))
End If
pChecker.Add StrPtr(Text4.Text)
Text4.Text = ""
End Sub
Private Sub Command3_Click()
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : Command3_Click
' * Purpose :
' * Parameters :
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
If (pSPFact Is Nothing) Then
Set pSPFact = New SpellCheckerFactory
Set pChecker = pSPFact.CreateSpellChecker(StrPtr(Text3.Text))
End If
pChecker.AutoCorrect StrPtr(Text5.Text), StrPtr(Text6.Text)
Text5.Text = ""
Text6.Text = ""
End Sub
Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : Text1_KeyUp
' * Purpose :
' * Parameters :
' * KeyCode As Integer
' * Shift As Integer
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Select Case KeyCode
Case vbKeyDown, vbKeyUp, vbKeyLeft, vbKeyRight, vbKeyPageDown, vbKeyPageUp
Case Else
Text2.Text = vbNullString
Call CheckSpelling(Text1.Text)
End Select
End Sub
Private Function GetStringWidth(ByVal nhDC As Long, ByVal sText As String) As Long
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 07:56
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : GetStringWidth
' * Purpose :
' * Parameters :
' * ByVal nhDC As Long
' * ByVal sText As String
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Dim nSize As SizeAPI
Call GetTextExtentPoint32W(hdc, ByVal StrPtr(sText), Len(sText), nSize)
GetStringWidth = nSize.cx
End Function
Private Function GetStringHeight(ByVal nhDC As Long, ByVal sText As String) As Long
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:00
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : GetStringHeight
' * Purpose :
' * Parameters :
' * ByVal nhDC As Long
' * ByVal sText As String
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Dim nSize As SizeAPI
Call GetTextExtentPoint32W(hdc, ByVal StrPtr(sText), Len(sText), nSize)
GetStringHeight = nSize.cy
End Function
Re: [VB6, Win8+] Using the system spellchecker: Add spellcheck with only a few lines
Now multilines in textbox is managed
Remaining, adding suggestion
Code:
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Purpose :
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Option Explicit
Private pSPFact As SpellCheckerFactory
Private pChecker As ISpellChecker
Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function GetTextExtentPoint32W Lib "gdi32" (ByVal hdc As Long, ByVal lpsz As Long, ByVal cbString As Long, ByRef lpSize As SizeAPI) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function LineTo Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
Private Declare Function ExtCreatePen Lib "gdi32.dll" (ByVal dwPenStyle As Long, ByVal dwWidth As Long, ByRef lplb As LOGBRUSH, ByVal dwStyleCount As Long, ByRef lpStyle As Long) As Long
Private Type SizeAPI
cx As Long
cy As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Sub CheckSpelling(sText As String)
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : CheckSpelling
' * Purpose :
' * Parameters :
' * sText As String
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Dim pErrors As IEnumSpellingError
Dim pError As ISpellingError
Dim nStart As Long
Dim nLen As Long
Dim lpsz As Long
Dim sString2 As String
Dim sInvalid As String
Dim sSug() As String
Dim nSug As Long
Dim nFetched As Long
Dim nhDC As Long
Dim oPoint As POINTAPI
Dim oRect As RECT
Dim hPenWhite As Long
Dim hPenRed As Long
Dim hOldPen As Long
Dim nLeft As Long
Dim nRight As Long
Dim nWidth As Long
Dim nHeight As Long
Dim nRedLinePos As Long
Dim sFirstPart As String
Dim nLines As Long
Dim nI As Long
Dim sLines() As String
Dim sLineToCheck As String
If (pSPFact Is Nothing) Then
Set pSPFact = New SpellCheckerFactory
Set pChecker = pSPFact.CreateSpellChecker(StrPtr(Text3.Text))
End If
If LenB(sText) > 2 Then
Set pErrors = pChecker.Check(StrPtr(sText))
nLines = InstrCount(Text1.Text, vbCr)
nhDC = GetDC(Text1.hwnd)
Call GetWindowRect(Text1.hwnd, oRect)
nWidth = GetStringWidth(nhDC, "Z")
nHeight = GetStringHeight(nhDC, "Z")
nRedLinePos = 0
' *
' **
' *** Clean
hPenWhite = CreatePen(0, 1, RGB(255, 255, 255))
hPenRed = CreatePen(0, 1, RGB(255, 0, 0))
hOldPen = SelectObject(nhDC, hPenWhite)
For nI = 1 To nLines + 1
MoveToEx nhDC, 0, (nHeight * nI) + nRedLinePos, oPoint
LineTo nhDC, oRect.Right, (nHeight * nI) + nRedLinePos
Next
SelectObject nhDC, hOldPen
Do While pErrors.Next(pError) = S_OK
Select Case pError.CorrectiveAction
Case CORRECTIVE_ACTION_DELETE
nStart = pError.StartIndex() + 1
nLen = pError.Length()
sInvalid = Mid$(sText, nStart, nLen)
Text2.Text = Text2.Text & "Delete: " & sInvalid & vbCrLf
Case CORRECTIVE_ACTION_REPLACE
nStart = pError.StartIndex() + 1
nLen = pError.Length()
sInvalid = Mid$(sText, nStart, nLen)
lpsz = pError.Replacement()
sString2 = LPWSTRtoStr(lpsz)
Text2.Text = Text2.Text & "Replace " & sInvalid & " with " & sString2 & vbCrLf
Case CORRECTIVE_ACTION_GET_SUGGESTIONS
Dim pIES As IEnumString
nStart = pError.StartIndex() + 1
nLen = pError.Length()
sInvalid = Mid$(sText, nStart, nLen)
Set pIES = pChecker.Suggest(StrPtr(sInvalid))
ReDim sSug(0)
Do While pIES.Next(1&, lpsz, nFetched) = S_OK
ReDim Preserve sSug(nSug)
sSug(nSug) = LPWSTRtoStr(lpsz)
nSug = nSug + 1
Loop
' *
' **
' *** Draw invalid in red
sFirstPart = Left$(Text1.Text, nStart - 1)
nLines = InstrCount(sFirstPart, vbCr)
If nLines = 0 Then
nLeft = GetStringWidth(nhDC, sFirstPart) + 1
nRight = GetStringWidth(nhDC, sInvalid) + 1
MoveToEx nhDC, nLeft, (nHeight + nRedLinePos) * (nLines + 1), oPoint
hOldPen = SelectObject(nhDC, hPenRed)
LineTo nhDC, nLeft + nRight, (nHeight + nRedLinePos) * (nLines + 1)
Else
sLines = Split(Text1.Text, vbCrLf)
sLineToCheck = sLines(nLines)
nStart = InStr(sLineToCheck, sInvalid)
Do While nStart > 0
sFirstPart = Left$(sLineToCheck, nStart - 1)
nLeft = GetStringWidth(nhDC, sFirstPart) + 1
nRight = GetStringWidth(nhDC, sInvalid) + 1
MoveToEx nhDC, nLeft, (nHeight + nRedLinePos) * (nLines + 1), oPoint
hOldPen = SelectObject(nhDC, hPenRed)
LineTo nhDC, nLeft + nRight, (nHeight + nRedLinePos) * (nLines + 1)
nStart = InStr(nStart + 1, sLineToCheck, sInvalid)
Loop
End If
SelectObject nhDC, hOldPen
Text2.Text = Text2.Text & "Error: " & sInvalid & "; suggestions: " & Join(sSug, ",") & vbCrLf
End Select
nStart = 0
nLen = 0
lpsz = 0
nSug = 0
Loop
ReleaseDC Text1.hwnd, nhDC
End If
End Sub
Private Function GetStringHeight(ByVal nhDC As Long, ByVal sText As String) As Long
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:00
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : GetStringHeight
' * Purpose :
' * Parameters :
' * ByVal nhDC As Long
' * ByVal sText As String
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Dim nSize As SizeAPI
Call GetTextExtentPoint32W(hdc, ByVal StrPtr(sText), Len(sText), nSize)
GetStringHeight = nSize.cy
End Function
Private Function GetStringWidth(ByVal nhDC As Long, ByVal sText As String) As Long
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 07:56
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : GetStringWidth
' * Purpose :
' * Parameters :
' * ByVal nhDC As Long
' * ByVal sText As String
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Dim nSize As SizeAPI
Call GetTextExtentPoint32W(hdc, ByVal StrPtr(sText), Len(sText), nSize)
GetStringWidth = nSize.cx
End Function
Public Function LPWSTRtoStr(lPtr As Long, Optional ByVal fFree As Boolean = True) As String
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : LPWSTRtoStr
' * Purpose :
' * Parameters :
' * lPtr As Long
' * Optional ByVal fFree As Boolean = True
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
SysReAllocString VarPtr(LPWSTRtoStr), lPtr
If fFree Then
Call CoTaskMemFree(lPtr)
End If
End Function
Private Sub Command1_Click()
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : Command1_Click
' * Purpose :
' * Parameters :
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Text2.Text = vbNullString
CheckSpelling Text1.Text
End Sub
Private Sub Command2_Click()
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : Command2_Click
' * Purpose :
' * Parameters :
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
If (pSPFact Is Nothing) Then
Set pSPFact = New SpellCheckerFactory
Set pChecker = pSPFact.CreateSpellChecker(StrPtr(Text3.Text))
End If
pChecker.Add StrPtr(Text4.Text)
Text4.Text = ""
End Sub
Private Sub Command3_Click()
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : Command3_Click
' * Purpose :
' * Parameters :
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
If (pSPFact Is Nothing) Then
Set pSPFact = New SpellCheckerFactory
Set pChecker = pSPFact.CreateSpellChecker(StrPtr(Text3.Text))
End If
pChecker.AutoCorrect StrPtr(Text5.Text), StrPtr(Text6.Text)
Text5.Text = ""
Text6.Text = ""
End Sub
Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
' #VBIDEUtils#************************************************************
' * Date : 05/19/2018
' * Time : 08:12
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : Text1_KeyUp
' * Purpose :
' * Parameters :
' * KeyCode As Integer
' * Shift As Integer
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
If Shift = 0 Then
Select Case KeyCode
Case vbKeyDown, vbKeyUp, vbKeyLeft, vbKeyRight, vbKeyPageDown, vbKeyPageUp
Case Else
Text2.Text = vbNullString
Call CheckSpelling(Text1.Text)
End Select
End If
End Sub
Public Function InstrCount(sToSearch As String, sToFind As String) As Long
' #VBIDEUtils#************************************************************
' * Date : 08/25/2005
' * Time : 15:00
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : InstrCount
' * Purpose :
' * Parameters :
' * sToSearch As String
' * sToFind As String
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
If LenB(sToSearch) >= LenB(sToFind) Then
InstrCount = UBound(Split(sToSearch, sToFind))
Else
InstrCount = 0
End If
End Function
Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Text2.Text = vbNullString
Call CheckSpelling(Text1.Text)
End Sub
1 Attachment(s)
Re: [VB6, Win8+] Using the system spellchecker: Add spellcheck with only a few lines
Update, multiline, suogestions, and correction.
Text to be spell checked with the demo :
"This is my verssion with red line drawn under bad spell errors.
Not perfectt, it could be enhanced.
Highlighting the invalide word will display the suggestsions that will be repalced directly in the textbox.
Scrollbares needs to be handled, and alsau texte coing to the nexte line when reaxching the righte of the textbox.
But it is a vzery good start.
"
Re: [VB6, Win8+] Using the system spellchecker: Add spellcheck with only a few lines
Very cool work. Shouldn't be that hard to have the suggestions in a right click menu for errors... I might look into adding that in later on.
Re: [VB6, Win8+] Using the system spellchecker: Add spellcheck with only a few lines
It is your turn to enhance it fafalone :)
I updated it quickly, but need more before integrating in my applications.
The main thing remaining is when you type long text, and no CR, in order to have the red line at the right place, and manage scrollbars (easy this part).
It will be easy to integrate the spellchecker in my applications as I don't use textbox, but my own textbox, so I just need to encapsulmate it in the OCX, a few more properties and that's all.
1 Attachment(s)
Re: [VB6, Win8+] Using the system spellchecker: Add spellcheck with only a few lines
Ok, here's a modification of your project with the existing ListBox replaced by a popup menu, and modifying the right-click context menu to have the suggestions at the top (and replace when clicked). It's a rough proof of concept, still needs a lot of refinement. Like you have to left-click to set the cursor position before right clicking, as it goes with the word where the cursor is; for now I just used the same method you did; on mousedown it selects the word, then just executes the choice just like before. Obviously modifying the right-click menu meant having to subclass; used some code LaVolpe gave me to accomplish that.
Re: [VB6, Win8+] Using the system spellchecker: Add spellcheck with only a few lines
Hello fafalone ..... and how do you clean the wavy lines from all the text?
