gistfile1.vb

Option Explicit
Private Const C_MODULE As String = "CSpellingIndicator"

Private Type POINTAPI
    X  As Long
    Y As Long
End Type

Private Type TEXTMETRIC
    tmHeight As Long
    tmAscent As Long
    tmDescent As Long
    tmInternalLeading As Long
    tmExternalLeading As Long
    tmAveCharWidth As Long
    tmMaxCharWidth As Long
    tmWeight As Long
    tmOverhang As Long
    tmDigitizedAspectX As Long
    tmDigitizedAspectY As Long
    tmFirstChar As Byte
    tmLastChar As Byte
    tmDefaultChar As Byte
    tmBreakChar As Byte
    tmItalic As Byte
    tmUnderlined As Byte
    tmStruckOut As Byte
    tmPitchAndFamily As Byte
    tmCharSet As Byte
End Type

Private Declare Function Polyline Lib "gdi32" (ByVal hDC As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd 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 GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As POINTAPI) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, wParam As Any, lParam As Any) As Long
Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hDC As Long, lpMetrics As TEXTMETRIC) As Long

Private Const WM_PAINT  As Long = &HF
Private Const WM_GETFONT As Long = &H31
Private Const EM_POSFROMCHAR As Long = &HD6
'

Private WithEvents m_oSubclass  As CMsgHook
Private m_oSpellEngine          As ISpellingService
Private m_hWnd                  As Long
'

Friend Function Init(ByVal p_hwnd As Long, ByVal p_oSpellEngine As ISpellingService) As CSpellingIndicator

    Set m_oSpellEngine = p_oSpellEngine
    
    m_hWnd = p_hwnd
    
    CreateMsgHook
    HighlightMistakes
    
    Set Init = Me

End Function


Private Sub CreateMsgHook()
    
    'If Not RunningInIDE Then
        Set m_oSubclass = New CMsgHook
        m_oSubclass.hwnd = m_hWnd
    'End If
    
End Sub

Private Sub DestroyMsgHook()
    On Error Resume Next
    
    Set m_oSubclass = Nothing
    
End Sub

Private Function WindowText() As String

    Dim l_sText As String
    
    l_sText = String$(GetWindowTextLength(m_hWnd) + 1, Chr$(0))
    GetWindowText m_hWnd, l_sText, Len(l_sText)
    
    WindowText = Left$(l_sText, Len(l_sText) - 1)

End Function

Private Sub HighlightMistakes()
    Dim l_tTextMetrics  As TEXTMETRIC
    Dim l_tSize         As POINTAPI
    Dim l_tStart        As POINTAPI
    Dim l_tEnd          As POINTAPI
    Dim l_hDC           As Long
    Dim i               As Long
    Dim l_hFont         As Long
    Dim l_hFontOld      As Long
    Dim l_nOffset       As Long
    Dim l_nPos          As Long
    Dim l_nRes          As Long
    Dim l_sText         As String
    Dim l_sWord         As String
    Dim l_asWords()     As String
    
    l_hDC = GetDC(m_hWnd)
    
    GetTextMetrics l_hDC, l_tTextMetrics
    'to place squiggle under the word
    l_nOffset = l_tTextMetrics.tmHeight - l_tTextMetrics.tmDescent
    
    l_hFont = SendMessage(m_hWnd, WM_GETFONT, 0, ByVal 0&)
    l_hFontOld = SelectObject(l_hDC, l_hFont)
        
    l_nPos = 1
    l_sText = WindowText
            
    For i = 1 To m_oSpellEngine.Count
        l_sWord = m_oSpellEngine.GetWord(i)
        GetTextExtentPoint32 l_hDC, l_sWord, Len(l_sWord), l_tSize
        
        l_nPos = InStr(l_nPos, l_sText, l_sWord, vbTextCompare) - 1
        l_nRes = SendMessage(m_hWnd, EM_POSFROMCHAR, ByVal l_nPos, ByVal 0&)
        l_tStart.X = LoWord(l_nRes)
        l_tStart.Y = HiWord(l_nRes) + l_nOffset
        l_tEnd.X = l_tStart.X + l_tSize.X + 1
        l_tEnd.Y = l_tStart.Y
    
        DrawSquiggle l_hDC, l_tStart, l_tEnd, vbRed
        l_nPos = l_nPos + Len(l_sWord)  '1
    Next
    
    SelectObject l_hDC, l_hFontOld
    ReleaseDC m_hWnd, l_hDC
    
End Sub

Private Sub DrawSquiggle(ByVal p_hDC As Long, ByRef p_tStart As POINTAPI, ByRef p_tEnd As POINTAPI, ByVal p_nColour As Long)

    Dim l_atPoints()        As POINTAPI
    Dim l_vPoint            As Variant
    Dim l_nPenCol           As Long
    Dim l_nRet              As Long
    Dim i                   As Long
    Dim j                   As Long
    
    If p_tEnd.X - p_tStart.X > 4 Then
    
        ReDim l_atPoints(1 To 100)
        j = 1
    
        For i = p_tStart.X To p_tEnd.X - 2 Step 4
            l_atPoints(j).X = i
            l_atPoints(j).Y = p_tStart.Y
            j = j + 1
            l_atPoints(j).X = i + 2
            l_atPoints(j).Y = p_tStart.Y + 2
            j = j + 1
        Next
        
        j = j - 1
        
        ReDim Preserve l_atPoints(1 To j)
    
    End If
    
    If j <> 0 Then
        l_nPenCol = CreatePen(0, 1, p_nColour)
        l_nRet = SelectObject(p_hDC, l_nPenCol)
        l_nRet = Polyline(p_hDC, l_atPoints(1), j)
        l_nRet = DeleteObject(l_nPenCol)
    End If
    
End Sub

Private Sub Class_Terminate()
    DestroyMsgHook
    Set m_oSpellEngine = Nothing
End Sub

Private Sub m_oSubclass_Message(msg As Long, wp As Long, lp As Long, Result As Long)
    
    Result = m_oSubclass.CallWindowProc(msg, wp, lp)
    
    If msg = WM_PAINT Then
        HighlightMistakes
    End If
    
End Sub