dcsimg
Results 1 to 10 of 10
  1. #1

    Thread Starter
    Frenzied Member
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    1,922

    [VB6, Win8+] Using the system spellchecker: Add spellcheck with only a few lines


    ISpellChecker Demo


    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)
    Attached Files Attached Files

  2. #2
    Addicted Member
    Join Date
    Jan 2015
    Posts
    161

    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

  3. #3

    Thread Starter
    Frenzied Member
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    1,922

    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.

  4. #4
    Addicted Member
    Join Date
    Jan 2015
    Posts
    161

    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

  5. #5
    Addicted Member
    Join Date
    Jan 2015
    Posts
    161

    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
    Last edited by Thierry69; May 19th, 2018 at 02:10 AM.

  6. #6
    Addicted Member
    Join Date
    Jan 2015
    Posts
    161

    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

  7. #7
    Addicted Member
    Join Date
    Jan 2015
    Posts
    161

    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.
    "

  8. #8

  9. #9
    Addicted Member
    Join Date
    Jan 2015
    Posts
    161

    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.

  10. #10

    Thread Starter
    Frenzied Member
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    1,922

    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.
    Attached Files Attached Files

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width


×
We have made updates to our Privacy Policy to reflect the implementation of the General Data Protection Regulation.