#Include "window9.bi"
'{ Константы Обработчика событий WebBrowser
#Define DISPID_DOWNLOADCOMPLETE 104
#Define DISPID_NEWWINDOW2 251
#Define DISPID_NEWWINDOW3 273
'}
Dim Shared IID_DWebBrowserEvents2 As IID = Type(_
&h34A715A0, &h6587, &h11D0, {&h92, &h4a, &h00, &h20, &haf, &hc7, &hac, &h4d})
Dim Shared pBrowser As IWebBrowser2 Ptr
'{ Класс обработчика
Type DispatchFunctionsVtbl_ As DispatchFunctionsVtbl
Type DispatchFunctions
lpVtbl As DispatchFunctionsVtbl_ Ptr
End Type
Type DispatchFunctionsVtbl
QueryInterface As Function (_
pDf As DispatchFunctions Ptr,_
iid As REFIID, ppv As LPVOID Ptr _
) As HRESULT
AddRef As Function (_
pDf As DispatchFunctions Ptr _
) As Ulong
Release As Function (_
pDf As DispatchFunctions Ptr _
) As Ulong
GetTypeInfoCount As Function (_
Byref D_O As DispatchFunctions Ptr,_
pctinfo As UINT Ptr _
) As HRESULT
GetTypeInfo As Function (_
Byref D_O As DispatchFunctions Ptr,_
iTInfo As UINT, lcid As LCID,_
ppTInfo As LPTYPEINFO Ptr _
) As HRESULT
GetIDsOfNames As Function (_
Byref D_O As DispatchFunctions Ptr,_
riid As IID Ptr,_
rgszNames As LPOLESTR Ptr,_
cNames As UINT,_
lcid As LCID,_
rgDispId As DISPID Ptr _
) As HRESULT
Invoke As Function (_
Byref D_O As DispatchFunctions Ptr,_
dispIdMember As DISPID,_
riid As IID Ptr,_
lcid As LCID,_
wFlags As WORD,_
Byref pDispParams As DISPPARAMS Ptr,_
pVarResult As VARIANT_ Ptr,_
pExcepInfo As EXCEPINFO Ptr,_
puArgErr As UINT Ptr _
) As HRESULT
End Type
Type Obj_D_F
Df As DispatchFunctions
cRef As Integer
End Type
'*******************Декларации функций*******************
Declare Sub LoadBlank()
Declare Sub Find()
Declare Sub Proc()
Declare Sub ClearStringGadget()
Declare Function D_F_QueryInterface (_
pDf As DispatchFunctions Ptr,_
iid As REFIID,_
ppv As LPVOID Ptr _
) As HRESULT
Declare Function D_F_AddRef(_
pDf As DispatchFunctions Ptr _
) As ULong
Declare Function D_F_Release(_
pDf As DispatchFunctions Ptr _
) As ULong
Declare Function D_F_GetTypeInfoCount(_
Byref D_O As DispatchFunctions Ptr,_
pctinfo As UINT Ptr _
) As HRESULT
Declare Function D_F_GetTypeInfo(_
Byref D_O As DispatchFunctions Ptr,_
iTInfo As UINT,_
lcid As LCID,_
ppTInfo As LPTYPEINFO Ptr _
) As HRESULT
Declare Function D_F_GetIDsOfNames(_
Byref D_O As DispatchFunctions Ptr,_
riid As IID Ptr,_
rgszNames As LPOLESTR Ptr,_
cNames As UINT,_
lcid As LCID,_
rgDispId As DISPID Ptr _
) As HRESULT
Declare Function D_F_Invoke(_
Byref D_O As DispatchFunctions Ptr,_
dispIdMember As DISPID,_
riid As IID Ptr,_
lcid As LCID,_
wFlags As WORD,_
Byref pDispParams As DISPPARAMS Ptr,_
pVarResult As VARIANT_ Ptr,_
pExcepInfo As EXCEPINFO Ptr,_
puArgErr As UINT Ptr _
) As HRESULT
'*******************Константы*******************
Enum FindEnum
BROWSER = 1
COMBOBOX
TEXT1
STRING1
BUTTON
End Enum
'*******************Переменные*******************
Dim As String sSites(4) = _ 'список сайтов в массиве
{"http://free-basic.ru/",_
"http://freebasic.justforum.net/",_
"http://www.freebasic.net/forum/",_
"http://www.freebasic-portal.de/",_
"http://forum.qbasic.at/"_
}
Dim Shared As String sFirstIndex ' данные страницы в блоке BODY HTML
sFirstIndex = "<P> <P> <P> <P> <P> <div style=" & _
Chr(34) & "text-align: center; color: rgb(204, 0, 0);" & _
Chr(34) & "><big><big><big><big><big>Поиск по сайтам</big></big></big></big></big><br></div>"
Dim As Integer Ievent ' переменная - буфер события
Dim Shared As HWND HWNDmain ' хендл главного окна
' ----- переменные и объявления для обработчика событий браузера
Dim dispatchFunc As DispatchFunctionsVtbl = Type(_
@D_F_QueryInterface(),_
@D_F_AddRef(),_
@D_F_Release(),_
@D_F_GetTypeInfoCount(),_
@D_F_GetTypeInfo(),_
@D_F_GetIDsOfNames(),_
@D_F_Invoke()_
)
Dim connectionPointContainer As IConnectionPointContainer Ptr
Dim connectionPoint As IConnectionPoint Ptr
Dim dispatchObject As Obj_D_F
dispatchObject.Df.lpVtbl = @dispatchFunc
Dim dispatch As IDispatch Ptr = Cast(IDispatch Ptr,@dispatchObject)
Dim Cookie As Integer
'---------
'*******************Главное окно************************
HWNDmain = OpenWindow(_
"Поисковик",_
10,_
10,_
735,_
600 _
)
CenterWindow(_
HWNDmain _
)
'*******************Гаджеты*******************
pBrowser = Cast(IWebBrowser2 Ptr,WebGadget(_ 'браузер
BROWSER,_
10,_
50,_
700,_
500,_
"about:blank",_
WS_VSCROLL Or WS_HSCROLL,WS_EX_CLIENTEDGE _
))
'------ код нужен для обработчика событий браузера
pBrowser->lpVtbl->QueryInterface(_
pBrowser,_
@IID_IConnectionPointContainer,_
@connectionPointContainer _
)
connectionPointContainer->lpVtbl->FindConnectionPoint(_
connectionPointContainer,_
@IID_DWebBrowserEvents2,_
@connectionPoint _
)
connectionPoint->lpVtbl->Advise(_
connectionPoint,_
Cast(IUnknown Ptr,_
dispatch),_
@Cookie _
)
'-----------------
AddKeyboardShortcut(_ ' горячая клавиша для кнопки OK
HWNDmain,_
FVIRTKEY,_
VK_RETURN,_
1001 _
)
AddKeyboardShortcut(_ ' горячая клавиша "обновить"
HWNDmain,_
FVIRTKEY,_
VK_F5,_
1002 _
)
AddKeyboardShortcut(_ ' горячая клавиша "НАЗАД в браузере"
HWNDmain,_
FALT,_
VK_LEFT,_
1003 _
)
AddKeyboardShortcut(_ ' горячая клавиша "Вперед в браузере"
HWNDmain,_
FALT,_
VK_RIGHT,_
1004 _
)
SetTimer( _ ' запуск по таймеру процедуры загрузки первой страницы
HWNDmain,_
1,_
10,_
Cast(TIMERPROC,@LoadBlank)_
)
SetTimer(_ ' запуск по таймеру процедуры , следящей за размерами окна и webgadget
HWNDmain,_
2,_
10,_
Cast(TIMERPROC,@Proc)_
)
TextGadget(_ 'Текстовый гаджет около комбобокс
TEXT1,_
10,_
10,_
120,_
20,_
"Поиск по сайту:",_
SS_CENTERIMAGE _
)
SetGadgetColor(_
TEXT1,_
0,_
&hff0000,_
2_
)
ComboBoxGadget(_ 'комбобокс
COMBOBOX,_
125,_
10,_
230,_
120 _
)
For i As Integer = 0 To 4 ' добавление строк - сайтов
AddComboBoxItem(_
COMBOBOX,_
sSites(i),_
-1 _
)
Next
SetItemComboBox(_ ' ставим видимым первый пункт
COMBOBOX,_
0 _
)
StringGadget(_ 'Текстовый гаджет - поисковая строка
STRING1,_
380,_
10,_
250,_
24,_
"Введите текст для поиска",_
ES_CENTER Or ES_AUTOHSCROLL, _
WS_EX_CLIENTEDGE _
)
SetGadgetColor(_
STRING1,_
0,_
&hff0000,_
2_
)'
ButtonGadget(_ ' кнопка подтверждение
BUTTON,_
640,_
10,_
30,_
23,_
"OK"_
)
'*******************Цикл событий*******************
Do
' Получаем событие
Ievent = WaitEvent
' Идентифицируем событие
Select Case Ievent
' Если произошло событие закрытия окна, то выходим из цикла
Case EventClose
Exit Do
' Если произошло событие от гаджета
Case eventgadget
' Идентифицируем гаджет по идентификатору BUTTON
If EventNumber = BUTTON Then
' Начали поиск
Find()
EndIf
Case eventmenu ' событие от меню
Select case EventNumber
case 1001 ' если горрячая клавиша ENTER
' Начали поиск
Find()
Case 1002
WebGadgetRefresh(Cast(Any Ptr,pBrowser)) ' обновить
Case 1003
WebGadgetGoBack(Cast(Any Ptr,pBrowser)) ' назад
Case 1004
WebGadgetGoForward(Cast(Any Ptr,pBrowser)) ' вперед
End Select
' Если произошло событие левой кнопки мыши
Case EventLBDown
'Очищаем StringGadget
ClearStringGadget()
End Select
Loop
KillTimer(_
HWNDmain,_
1)
KillTimer(_
HWNDmain,_
2)
End
'*******************Очистка StringGadget*******************
Sub ClearStringGadget()
' получаем текст из StringGadget и сравниваем его с начальной строкой
If GetGadgetText (_
STRING1 _
) = "Введите текст для поиска" Then
'очищаем StringGadget
SetGadgetText (_
STRING1,_
"" _
)
EndIf
End Sub
'*******************Загрузка первоначальной страницы*******************
Sub LoadBlank()
' Узнаем загружена ли полностью страница
If WebGadgetState( _
cast(Any Ptr,pBrowser) _
) = 0 Then
' Заносим в тег BODY страницы данные
WebGadgetSetBody(_
cast(Any Ptr,pBrowser),_
sFirstIndex _
)
' Таймер больше не нужен
KillTimer( _
HWNDmain,_
1 _
)
Exit Sub
EndIf
End Sub
'*******************ПОИСК*******************
Sub Find()
Dim As String sGetNameSite ,_ ' буфер для получения имени сайта из ComboBox
sKeyWord ' буфер для получения искомой строки
Dim As WString*256 sUrl ' задаваемый URL запрос
Dim As WString Ptr sUnicodeKeyWord ' указатель на UNICODE представление искомой строки
Dim As Integer iItemCombo ' текущий видимый пункт в ComboBox
' Получаем текущий видимый пункт ComboBox
iItemCombo = GetItemComboBox(_
COMBOBOX _
)
' Получаем текст из текущего видимого пункта ComboBox
sGetNameSite = GetComboBoxText(_
COMBOBOX,_
iItemCombo _
)
' Получаем поисковую строку из StringGadget
sKeyWord = GetGadgetText(_
STRING1 _
)
' Преобразуем поисковую строку в UNICODE строку
sUnicodeKeyWord = ASCIITOUTF(_
sKeyWord _
)
/' Если поиск ведется по сайту www.freebasic.net , то пользуемся
их встроенным поиском. Для других сайтов используем GOOGLE'/
Select Case iItemCombo
Case 2
sUrl = "http://www.freebasic.net/forum/search.php?keywords=" & TrimA(sKeyWord)
Case Else
sUrl = "http://www.google.ru/search?client=IE&rls=ru&q=" & _
*sUnicodeKeyWord & "+site:" & sGetNameSite
End Select
' Отправляем запрос в WebGadget
WebGadgetNavigate(_
cast(Any Ptr,pBrowser),_
sUrl _
)
' Освобождаем буфер Unicode строки
DeAllocate(_
sUnicodeKeyWord _
)
End Sub
' Методы класса обработчика событий браузера
Function D_F_QueryInterface (_
pDf As DispatchFunctions Ptr,_
iid As REFIID,_
ppv As LPVOID Ptr _
) As HRESULT
Dim pThis As Obj_D_F Ptr
pThis = Cast(Obj_D_F Ptr,pDf)
If IsEqualIID( iid, @IID_IUnknown) Then
*ppv = @(pThis->Df)
pDf->lpVtbl->AddRef(pDf)
Return S_OK
Elseif IsEqualIID( iid, @IID_IDispatch) Then
*ppv = @(pThis->Df)
pDf->lpVtbl->AddRef(pDf)
Return S_OK
End If
ppv = NULL
Function = E_NOINTERFACE
End Function
Function D_F_AddRef(_
pDf As DispatchFunctions Ptr _
) As Ulong
Dim pThis As Obj_D_F Ptr
pThis = Cast(Obj_D_F Ptr,pDf)
pThis->cRef +=1
Function = pThis->cRef
End Function
Function D_F_Release(_
pDf As DispatchFunctions Ptr _
) As Ulong
Dim pThis As Obj_D_F Ptr
pThis = Cast(Obj_D_F Ptr,pDf)
pThis->cRef -=1
Function = pThis->cRef
End Function
Function D_F_GetTypeInfoCount(_
Byref D_O As DispatchFunctions Ptr,_
pctinfo As UINT Ptr _
) As HRESULT
Return 0
End Function
Function D_F_GetTypeInfo(_
Byref D_O As DispatchFunctions Ptr,_
iTInfo As UINT,_
lcid As LCID,_
ppTInfo As LPTYPEINFO Ptr _
) As HRESULT
Return 0
End Function
Function D_F_GetIDsOfNames(_
Byref D_O As DispatchFunctions Ptr,_
riid As IID Ptr,_
rgszNames As LPOLESTR Ptr,_
cNames As UINT,_
lcid As LCID,_
rgDispId As DISPID Ptr _
) As HRESULT
Return 0
End Function
Function D_F_Invoke(_
Byref D_O As DispatchFunctions Ptr,_
dispIdMember As DISPID,_
riid As IID Ptr,_
lcid As LCID,_
wFlags As WORD,_
Byref pDispParams As DISPPARAMS Ptr,_
pVarResult As VARIANT_ Ptr,_
pExcepInfo As EXCEPINFO Ptr,_
puArgErr As UINT Ptr _
) As HRESULT
If dispIDMember = DISPID_DOWNLOADCOMPLETE Then
Elseif dispIDMember = DISPID_NEWWINDOW2 Then
Dim params1 As VARIANT Ptr = Cast(VARIANT Ptr,pDispParams)
*params1->pboolVal = VARIANT_TRUE
Elseif dispIDMember = DISPID_NEWWINDOW3 Then
Dim params1 As VARIANT Ptr = Cast(VARIANT Ptr,pDispParams)
WebGadgetNavigate(_
Cast(Integer Ptr,pBrowser),_
UTFTOASCII( params1->bstrVal)_
)
Endif
Return 0
End Function
'процедура следящая за соответствием размеров окна и webgadget
Sub Proc()
Static As integer a,b
Dim re As RECT
GetWindowRect(_
HWNDmain,_
@re _
)
If re.right-re.left<>a Or re.bottom-re.top<>b Then
ResizeGadget(_
BROWSER,_
,_
,_
re.right-re.left-35,_
re.bottom-re.top-100 _
)
a=re.right-re.left
b=re.bottom-re.top
endif
End Sub
