FreeBasic
Главная
Вход
Регистрация
Понедельник, 30.12.2024, 21:06Приветствую Вас Гость | RSS
[ Новые сообщения · Участники · Правила форума · Поиск · RSS ]
  • Страница 1 из 1
  • 1
Поиск по сайтам
haavДата: Суббота, 08.12.2012, 09:50 | Сообщение # 1
Генералиссимус
Группа: Администраторы
Сообщений: 1373
Репутация: 50
Статус: 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
Прикрепления: FIND.zip (36.8 Kb) · 4976209.png (29.1 Kb)


Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
 
haavДата: Воскресенье, 12.10.2014, 09:46 | Сообщение # 2
Генералиссимус
Группа: Администраторы
Сообщений: 1373
Репутация: 50
Статус: Offline
Обновил немного программу. Теперь:
1) открытие ссылок исключительно в браузере самой программы (добавлен обработчик событий webGadget)
2) появилась горячая клавиша ENTER , которая дублирует функционал кнопки "ОК"
3) размеры WebGadget сопоставляются с размерами окна при растягивании окна


Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
 
AlecДата: Воскресенье, 12.10.2014, 12:00 | Сообщение # 3
Лейтенант
Группа: Друзья
Сообщений: 73
Репутация: 1
Статус: Offline
Попробовал, всё здорово. Но не хватает кнопок навигации.

WorldSim3D - 3D движок для FreeBasic, для PC. Мощная 3D графика и простота программирования. Ознакомиться.
 
haavДата: Воскресенье, 12.10.2014, 17:00 | Сообщение # 4
Генералиссимус
Группа: Администраторы
Сообщений: 1373
Репутация: 50
Статус: Offline
Цитата Alec ()
Попробовал, всё здорово. Но не хватает кнопок навигации.


Я обновил код с возможностью:

"откат назад" ALT+ стрелка влево
"откат вперед" ALT+ стрелка вправо
"обновить" F5

Только откаты работают не так , как бы хотелось. Дело в том, что при клике по ссылке в гугле, идет редирект с созданием нового окошка. То есть к примеру производим поиск , в историю записывается:

URL поиска + URL Google редиректа + конечный сайт

В итоге когда мы откатываем назад с конечного сайта, мы попадаем на редирект и браузер автоматом кидает нас на конечный сайт. Получается как бы зацикленность. Однако я сделал откаты назад\ откаты вперед\ обновить по горячим клавишам, что дает возможность зажать клавиши и удерживать пока браузер не попадет на URL поиска. Когда мы так делаем , браузер не успевает перенаправлять и мы возвращаемся на начальную страницу.

В реальном браузере клик по ссылке в Google открывает новую страницу или вкладку, но реализовывать такое в моей простой программе как-то не хочется. Ведь придется для каждой новой вкладки автоматом создавать новый webgadget, контролировать его события. Слишком серьезно для такой утилиты smile

Добавлено позже:

Оказывается я не совсем был прав. 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 и программа стала работать как часы wine


Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
 
AlecДата: Воскресенье, 12.10.2014, 19:04 | Сообщение # 5
Лейтенант
Группа: Друзья
Сообщений: 73
Репутация: 1
Статус: Offline
Всё работает у меня, спасибо. smile
Вообще-то, да.. не пробовал в этой утилите этот форум, выходит с ошибками сценария, поэтому буду поробовать с записью в реестре.

Интересно, такие проблемы со сценариями только на форуме юкоза.


WorldSim3D - 3D движок для FreeBasic, для PC. Мощная 3D графика и простота программирования. Ознакомиться.

Сообщение отредактировал Alec - Воскресенье, 12.10.2014, 21:07
 
  • Страница 1 из 1
  • 1
Поиск: