Поиск по сайтам
|
|
haav | Дата: Суббота, 08.12.2012, 09:50 | Сообщение # 1 |
Генералиссимус
Группа: Администраторы
Сообщений: 1373
Статус: Offline
| Поиск по сайтам
Данная программа предназначена для поиска по сайтам:
http://free-basic.ru/ http://freebasic.justforum.net/ http://www.freebasic.net/forum/ http://www.freebasic-portal.de/ http://forum.qbasic.at/
Код #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
Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
|
|
| |
haav | Дата: Воскресенье, 12.10.2014, 09:46 | Сообщение # 2 |
Генералиссимус
Группа: Администраторы
Сообщений: 1373
Статус: Offline
| Обновил немного программу. Теперь: 1) открытие ссылок исключительно в браузере самой программы (добавлен обработчик событий webGadget) 2) появилась горячая клавиша ENTER , которая дублирует функционал кнопки "ОК" 3) размеры WebGadget сопоставляются с размерами окна при растягивании окна
Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
|
|
| |
Alec | Дата: Воскресенье, 12.10.2014, 12:00 | Сообщение # 3 |
Лейтенант
Группа: Друзья
Сообщений: 73
Статус: Offline
| Попробовал, всё здорово. Но не хватает кнопок навигации.
WorldSim3D - 3D движок для FreeBasic, для PC. Мощная 3D графика и простота программирования. Ознакомиться.
|
|
| |
haav | Дата: Воскресенье, 12.10.2014, 17:00 | Сообщение # 4 |
Генералиссимус
Группа: Администраторы
Сообщений: 1373
Статус: Offline
| Цитата Alec ( ) Попробовал, всё здорово. Но не хватает кнопок навигации.
Я обновил код с возможностью:
"откат назад" ALT+ стрелка влево "откат вперед" ALT+ стрелка вправо "обновить" F5
Только откаты работают не так , как бы хотелось. Дело в том, что при клике по ссылке в гугле, идет редирект с созданием нового окошка. То есть к примеру производим поиск , в историю записывается:
URL поиска + URL Google редиректа + конечный сайт
В итоге когда мы откатываем назад с конечного сайта, мы попадаем на редирект и браузер автоматом кидает нас на конечный сайт. Получается как бы зацикленность. Однако я сделал откаты назад\ откаты вперед\ обновить по горячим клавишам, что дает возможность зажать клавиши и удерживать пока браузер не попадет на URL поиска. Когда мы так делаем , браузер не успевает перенаправлять и мы возвращаемся на начальную страницу.
В реальном браузере клик по ссылке в Google открывает новую страницу или вкладку, но реализовывать такое в моей простой программе как-то не хочется. Ведь придется для каждой новой вкладки автоматом создавать новый webgadget, контролировать его события. Слишком серьезно для такой утилиты
Добавлено позже:
Оказывается я не совсем был прав. WebGadget по умолчанию использует определенный режим эмуляции , точно не знаю какой IE7 или IE8.... В результате этого откаты работают чудаковато. Что касается скриптов, то тут вообще жопа. Например зайти на этот форум с webgadget полный геморрой. Вылетают диалоговые окна с критическими ошибками сценариев. Их конечно можно программно отключить, но тогда скрипты загрузятся как-то через одно место и отключить тот же баннер UCOZ будет нереально. Однако есть решение , но оно требует добавления в реестр. Если в реестре для определенной программы (например ПОИСК.exe) указать режим эмуляции IE11 , то webgadget в этой программе будет нормально работать (и с откатами и с со скриптами) как и встроенный браузер IE.
На будущее, может кто-то будет делать программы с помощью webgadget или с помощью интерфейса IWebBrowser2:
Ветка реестра, в которой надо занести добавления\изменения для нужной программы: HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\MAIN\FeatureControl\FEATURE_BROWSER_EMULATION
В ней создается параметр DWORD (32 бита) с именем программы (без пути), например Поиск.exe В качестве значения параметра указывается значение, которое и будет создавать нужную эмуляцию. Значения можно посмотреть здесь: http://msdn.microsoft.com/en-us....ulation . Я для этой программы поставил 11001 и программа стала работать как часы
Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
|
|
| |
Alec | Дата: Воскресенье, 12.10.2014, 19:04 | Сообщение # 5 |
Лейтенант
Группа: Друзья
Сообщений: 73
Статус: Offline
| Всё работает у меня, спасибо. Вообще-то, да.. не пробовал в этой утилите этот форум, выходит с ошибками сценария, поэтому буду поробовать с записью в реестре.
Интересно, такие проблемы со сценариями только на форуме юкоза.
WorldSim3D - 3D движок для FreeBasic, для PC. Мощная 3D графика и простота программирования. Ознакомиться.
Сообщение отредактировал Alec - Воскресенье, 12.10.2014, 21:07 |
|
| |
|