mdlautocompletesuggestion.bas

Autocomplete sugestion textbox from Google, yahoo, youtube, wikipedia. in visual basic

                    SetTextColor mDC, GetSysColor(COLOR_MENUTEXT)
                    DeleteObject hPen
                    DeleteObject hBrush
                Else
                    DrawText mDC, .Caption, Len(.Caption), CapRec, 0
                End If
            End With
         Next

         EndPaint hwnd, PS
    End If
  
    WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)

End Function


Public Function ControlProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  
    If uMsg = WM_KEYDOWN And IsWindowVisible(Handle) Then
        Select Case wParam
            Case vbKeyDown
            
                mCurrIndex = mCurrIndex + 1
                
                If mCurrIndex > UBound(Item) Then mCurrIndex = -1
                
                RedrawWindow Handle, ByVal 0&, ByVal 0&, &H1
                
                If mCurrIndex = -1 Then
                    SetEditText hwnd, mText
                Else
                    SetEditText hwnd, Item(mCurrIndex).Caption
                End If
                
                Exit Function
                
            Case vbKeyUp
            
                mCurrIndex = mCurrIndex - 1
                
                If mCurrIndex < -1 Then mCurrIndex = UBound(Item)
                
                RedrawWindow Handle, ByVal 0&, ByVal 0&, &H1
                
                If mCurrIndex = -1 Then
                    SetEditText hwnd, mText
                Else
                    SetEditText hwnd, Item(mCurrIndex).Caption
                End If
                
                Exit Function
                
            Case vbKeyEscape, vbKeyLeft, vbKeyRight
            
                If IsWindowVisible(Handle) Then
                    ShowWindow Handle, 0
                    SetEditText hwnd, mText
                    ControlProc = 1
                    Exit Function
                End If
                
            Case vbKeyReturn
            
                If mCurrIndex = -1 Then SetEditText hwnd, Item(mCurrIndex).Caption
                ShowWindow Handle, 0
        End Select
    End If
    
    ControlProc = CallWindowProc(ControlPrevProc, hwnd, uMsg, wParam, lParam)
    
    Select Case uMsg
        
        Case WM_SETFOCUS
        
            mText = GetEditText(hwnd)
            SetTimer Handle, 0, 50, AddressOf TimerProc
        
        Case WM_KILLFOCUS
        
            KillTimer Handle, 0
            ShowWindow Handle, 0
    
        Case WM_DESTROY
        
            Call StopSubClass
            
        Case WM_KEYUP
        
            Select Case wParam
                Case vbKeyEscape, vbKeyLeft, vbKeyRight, vbKeyDown, vbKeyUp, vbKeyReturn
                
                Case Else
                    Call TextChange
            End Select
            
    End Select

End Function

Private Function LoWord(ByVal Numero As Long) As Long
    LoWord = Numero And &HFFFF&
End Function

Private Function HiWord(ByVal Numero As Long) As Long
    HiWord = Numero \ &H10000 And &HFFFF&
End Function

Private Function MakeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long
    MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)
End Function

Private Function SetEditText(hwnd As Long, NewText As String)
    SetWindowText hwnd, NewText
    SendMessage hwnd, EM_SETSEL, Len(NewText), Len(NewText)
End Function

Private Function GetEditText(hwnd As Long)
    Dim sBuff As String
    sBuff = String(100, Chr$(0))
    GetWindowText hwnd, sBuff, 100
    GetEditText = Left$(sBuff, InStr(sBuff, Chr$(0)) - 1)
End Function

Function GetCode(sUrl As String) As String

    Dim hOpen As Long, hFile As Long, sBuffer As String, Ret As Long
    
    sBuffer = Space(1000)

    hOpen = InternetOpen("VB-AutoComplete-TextBox", INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)

    hFile = InternetOpenUrl(hOpen, sUrl, vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)
    
    Do
        InternetReadFile hFile, sBuffer, 1000, Ret
        GetCode = GetCode & Left(sBuffer, Ret)
        If Ret = 0 Then Exit Do
    Loop
    
    InternetCloseHandle hFile
    InternetCloseHandle hOpen
    
End Function

Private Sub TextChange()
    Dim Rec         As RECT
    Dim sSearch     As String
    Dim sArray()    As String
    Dim sPart()     As String
    Dim UrlEncode   As String
    Dim i           As Long
    Dim j           As Long
    Dim sUrl        As String

    mText = GetEditText(hEdit)
    mCurrIndex = -1
    
    If mText = "" Then
        ShowWindow Handle, 0
        Exit Sub
    End If
    
    UrlEncode = Unicode2UTF8(mText)
    
    sUrl = Replace(mSearcherOfSuggestions, "{searchTerms}", UrlEncode)
    sUrl = Replace(sUrl, "{locale}", mLangName)
    
    sSearch = GetCode(sUrl)

    'sSearch = GetCode("http://ff.search.yahoo.com/gossip?output=fxjson&command=" & UrlEncode)
    'sSearch = GetCode("http://suggestqueries.google.com/complete/search?output=firefox&client=firefox&hl=" & mLangName & "&q=" & UrlEncode)
    'sSearch = GetCode("http://es.wikipedia.org/w/api.php?action=opensearch&search=" & UrlEncode)
    'sSearch = GetCode("http://suggestqueries.google.com/complete/search?output=firefox&client=firefox&&ds=yt&hl=" & mLangName & "&q=" & UrlEncode)
    
    sSearch = Replace(sSearch, Chr(34), vbNullString)
    sSearch = Replace(sSearch, "]", vbNullString)
    sSearch = Replace(sSearch, "[", vbNullString)
    sSearch = UTF82Unicode(sSearch)
    
    
    If InStr(sSearch, ",") = 0 Then
        ShowWindow Handle, 0
        Exit Sub
    End If
    
    sArray = Split(sSearch, ",")


    If UBound(sArray) > 1 Then
        If sArray(1) = vbNullString Then
            ShowWindow Handle, 0
            Exit Sub
        End If
    End If
    
    mDC = GetDC(Handle)
    DeleteObject SelectObject(mDC, SendMessage(hEdit, WM_GETFONT, 0, ByVal 0&))
    GetWindowRect hEdit, Rec
    
    For i = 1 To UBound(sArray) - 1
        If sArray(i) <> vbNullString Then
            ReDim Preserve Item(j)
            Item(j).Caption = sArray(i)
            DrawText mDC, Item(j).Caption, Len(Item(j).Caption), Item(j).Rec, DT_CALCRECT
            SetRect Item(j).Rec, 0, Item(j).Rec.Bottom * j, Rec.Right - Rec.Left - 2, (Item(j).Rec.Bottom * j) + Item(j).Rec.Bottom
            j = j + 1
        End If
    Next
  
    SetWindowPos Handle, HWND_TOPMOST, Rec.Left, Rec.Top + (Rec.Bottom - Rec.Top), Rec.Right - Rec.Left, Item(UBound(Item)).Rec.Bottom + 2, SWP_NOACTIVATE Or SWP_SHOWWINDOW 'Or SWP_NOMOVE Or SWP_NOSIZE
      
    RedrawWindow Handle, ByVal 0&, ByVal 0&, &H1

End Sub

Public Function UTF82Unicode(ByVal sUTF8 As String) As String
    Dim UTF8Size        As Long
    Dim BufferSize      As Long
    Dim BufferUNI       As String
    Dim LenUNI          As Long
    Dim bUTF8()         As Byte
    
    If LenB(sUTF8) = 0 Then Exit Function
    
    bUTF8 = StrConv(sUTF8, vbFromUnicode)
    UTF8Size = UBound(bUTF8) + 1
    
    BufferSize = UTF8Size * 2
    BufferUNI = String$(BufferSize, vbNullChar)
    
    LenUNI = MultiByteToWideChar(CP_UTF8, 0, bUTF8(0), UTF8Size, StrPtr(BufferUNI), BufferSize)
    
    If LenUNI Then UTF82Unicode = Left$(BufferUNI, LenUNI)

End Function


Public Function Unicode2UTF8(ByVal strUnicode As String) As String
    Dim LenUNI          As Long
    Dim BufferSize      As Long
    Dim LenUTF8         As Long
    Dim bUTF8()         As Byte
    
    LenUNI = Len(strUnicode)
    
    If LenUNI = 0 Then Exit Function
    
    BufferSize = LenUNI * 3 + 1
    ReDim bUTF8(BufferSize - 1)
    
    LenUTF8 = WideCharToMultiByte(CP_UTF8, 0, StrPtr(strUnicode), LenUNI, bUTF8(0), BufferSize, vbNullString, 0)
    
    If LenUTF8 Then
        ReDim Preserve bUTF8(LenUTF8 - 1)
        Unicode2UTF8 = StrConv(bUTF8, vbUnicode)
    End If

End Function

Public Function GetSystemLocaleInfo(ByVal lInfo As Long) As String
    Dim Buffer As String, Ret As String
    Buffer = String$(256, 0)

    Ret = GetLocaleInfo(LOCALE_USER_DEFAULT, lInfo, Buffer, Len(Buffer))

    If Ret > 0 Then
        GetSystemLocaleInfo = Left$(Buffer, Ret - 1)
    Else
        GetSystemLocaleInfo = ""
    End If
End Function

Private Function pvAlphaBlend(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long
    Dim clrFore         As UcsRgbQuad
    Dim clrBack         As UcsRgbQuad
    
    OleTranslateColor clrFirst, 0, VarPtr(clrFore)
    OleTranslateColor clrSecond, 0, VarPtr(clrBack)
    With clrFore
        .R = (.R * lAlpha + clrBack.R * (255 - lAlpha)) / 255
        .G = (.G * lAlpha + clrBack.G * (255 - lAlpha)) / 255
        .B = (.B * lAlpha + clrBack.B * (255 - lAlpha)) / 255
    End With
    CopyMemory pvAlphaBlend, clrFore, 4
End Function