Браузер для работы в глобальных сетях

end;

 

// Вырезать

procedure TfrmMyBrowser.Cut1Click(Sender: TObject);

begin

  WB_Cut(GetCurrentWB);

end;

  // Выделить всё

procedure TfrmMyBrowser.SelectAll1Click(Sender: TObject);

begin

  WB_SelectAll(GetCurrentWB);

end;

  // Обновить страницу

procedure TfrmMyBrowser.ToolBtnRefreshClick(Sender: TObject);

begin

  WB_Refresh(GetCurrentWB);

  ToolBtnStop.Enabled := True;

end;

// Поиск по странице

  procedure TfrmMyBrowser.ToolbtnBlackSearchClick(Sender: TObject);

begin

  WB_ShowFindDialog(GetCurrentWB);

end;

  // Поиск по странице

procedure TfrmMyBrowser.Search1Click(Sender: TObject);

begin

  WB_ShowFindDialog(GetCurrentWB);

end;

  // Опции обозревателя

procedure TfrmMyBrowser.InternetOptions1Click(Sender: TObject);

begin

  InvokeCMD(GetCurrentWB, HTMLID_OPTIONS);

end;

     // Назад к странице

procedure TfrmMyBrowser.ToolbtnBlackClick(Sender: TObject);

begin

  WB_GoBack(GetCurrentWB);

end;

// Перемещение сперёд

procedure TfrmMyBrowser.ToolBtnForwardClick(Sender: TObject);

begin

  WB_GoForward(GetCurrentWB);

end;

// Автономный режим

procedure TfrmMyBrowser.OfflineMode1Click(Sender: TObject);

begin

  OfflineMode1.Checked := not OfflineMode1.Checked;

  SetGlobalOffline(OfflineMode1.Checked);

end;

 

// Работа с TStatusbar

constructor TStatusBar.Create(AOwner: TComponent);

begin

  inherited Create(AOwner);

  ControlStyle := ControlStyle + [csAcceptsControls];

end;

// Кнопка передод-для перехода  на нужный сайт

procedure TfrmMyBrowser.sBitBtn1Click(Sender: TObject);

begin

  if edURL.Text <> '' then

  begin

    WB_Navigate(GetCurrentWB, edURL.Text);

    WB_SetFocus(GetCurrentWB);

  end;

end;

 

// Создаёти новую вкладку

procedure TfrmMyBrowser.sBitBtn2Click(Sender: TObject);

begin

   CreateTabBrowser('about:blank','Новая вкладка');

end;

// Закрывает активную вкладку

procedure TfrmMyBrowser.sBitBtn3Click(Sender: TObject);

begin

  if PageControl.ActivePageIndex > 0 then

  begin

    if PageControl.ActivePage.Controls[0] is TWebbrowser then

    begin

          (TWebbrowser(PageControl.ActivePage.Controls[0])).Free;

      FPrevBrowser := nil;

          PageControl.ActivePage.Free;

    end;

  end;

end;

 

// Двойной клик выделяет  адресс сайта

procedure TfrmMyBrowser.edURLDblClick(Sender: TObject);

begin

  edURl.SelectAll;

end;

// Нажатие Enter в edit

procedure TfrmMyBrowser.edURLKeyPress(Sender: TObject; var Key: Char);

begin

  if Key = #13 then

  begin

    Key := #0;

   sBitBtn1Click(self);

  end;

end;

    // Нажатие Enter в  строке поиска с поисковыми  системами

procedure TfrmMyBrowser.edSearchKeyPress(Sender: TObject; var Key: Char);

begin

  if Key = #13 then

  begin

    Key := #0;

   sBitBtn6Click(self);

  end;

end;

  // Установить набор  символов

procedure TfrmMyBrowser.urkishWindows1Click(Sender: TObject);

begin

  if WB_SetCharSet(GetCurrentWB, TMenuItem(Sender).Hint) then

    TMenuItem(Sender).Checked := True;

end;

  // Видимость TWebbrowser

function TfrmMyBrowser.GetCurrentWB: TWebbrowser;

begin

  Result := nil;

  with PageControl do

    if ActivePage.ControlCount > 0 then

    begin

      if ActivePage.Controls[0] is TWebbrowser then

      begin

        Result := (TWebbrowser(ActivePage.Controls[0]));

      end else

        Result := FPrevBrowser;

    end;

end;

 

//Загрузка пустой страницы

procedure TfrmMyBrowser.NewTabBlankClick(Sender: TObject);

begin

  CreateTabBrowser('about:blank','Новая вкладка');

end;

// Открыть HTML страницу

procedure TfrmMyBrowser.Open1Click(Sender: TObject);

begin

  if OpenDialog1.Execute then

    CreateTabBrowser(OpenDialog1.FileName, ExtractFileName(OpenDialog1.FileName));

end;

// Сохранить документ интернета

procedure TfrmMyBrowser.SaveAs1Click(Sender: TObject);

begin

  WB_Save(GetCurrentWB);

end;

        // Поисковые системы

procedure TfrmMyBrowser.FormCreate(Sender: TObject);

begin

 TrayIcon1.ShowBalloonHint;// значок в трее

combobox1.Items.Add('Поиск в Google.ru');

combobox1.Items.Add('Поиск в Mail.ru');

combobox1.Items.Add('Поиск в Yandex.ru');

combobox1.Items.Add('Поиск на Bing.com');

combobox1.Items.Add('Поиск на Wikipedia');

combobox1.Items.Add('Поиск на Microsoft');

end;

      // Поддержка скинов

procedure TfrmMyBrowser.FormShow(Sender: TObject);

var

  sl : TStringList;

  i : integer;

begin

  sl := TStringList.Create;

  sSkinManager1.GetSkinNames(sl);

  sComboBox1.Clear;

  for i := 0 to sl.Count - 1 do

   begin

    sComboBox1.Items.Add(sl[i]);

  end;

  begin

    Loading := True;

    sComboBox1.ItemIndex := sl.IndexOf(sSkinManager1.SkinName);

    Loading := False;

  end;

  FreeAndNil(sl);

  Form4.Close;        // при показе основного окна закрываем сплэш скрин

     freeandnil(Form4);  // освобождаем сплэш скрин

     Webbrowser1.GoHome;

     FormResize(nil);

end;

 

procedure TfrmMyBrowser.WebBrowser1ProgressChange(Sender: TObject; Progress, ProgressMax: Integer);

begin

  progressbar1.Max:=progressmax;

  tabsheet1.Caption:=webbrowser1.Locationname;

end;

// Вывод адреса  ULR на  верху окна программы

procedure TfrmMyBrowser.WebBrowser1TitleChange(Sender: TObject;

  const Text: WideString);

begin

// Надпись заголовка сайта на верху панели

  Caption := APP_CAPTION + Text;

  TWebbrowser(Sender).FTitle := Text;

end;

// Меню Файл активация

procedure TfrmMyBrowser.SetWBMenuEnabled(WB: TWebbrowser; Sender: TMenuItem);

begin

  if Assigned(WB) then

    Sender.Enabled := Assigned(WB.Document)

  else

    Sender.Enabled := False;

end;

    // Выполнение операций

procedure TfrmMyBrowser.File1Click(Sender: TObject);

var

  CurrentWB: TWebbrowser;

begin

  CurrentWB := GetCurrentWB;

  SetWBMenuEnabled(CurrentWB, PrintPreview1);

  SetWBMenuEnabled(CurrentWB, PageSetup1);

  SetWBMenuEnabled(CurrentWB, Properties1);

  SetWBMenuEnabled(CurrentWB, SaveAs1);

  OfflineMode1.Checked := IsGlobalOffline;

end;

  //Остановка загрузки

procedure TfrmMyBrowser.ToolBtnStopClick(Sender: TObject);

begin

  WB_Stop(GetCurrentWB);

end;

     // Развернуть программу из трея

procedure TfrmMyBrowser.TrayIcon1DblClick(Sender: TObject);

begin

  TrayIcon1.Visible:=true ;

  frmMyBrowser.Show;

end;

 

// Домой

procedure TfrmMyBrowser.ToolBtnHomeClick(Sender: TObject);

begin

  GetCurrentWB.GoHome;

end;

 

//Поиск в поисковых  системах

 procedure TfrmMyBrowser.sBitBtn6Click(Sender: TObject);

begin

if combobox1.ItemIndex=0 then

 webbrowser1.Navigate('http://www.google.ru/search?hl=ru&source=hp&q='+edsearch.Text+'&btnG=%D0%9F%D0%BE%D0%B8%D1%81%D0%BA+%D0%B2+Google');

 if combobox1.ItemIndex=1 then

 webbrowser1.Navigate('http://go.mail.ru/search?q='+edsearch.Text+'&fr=oprtb&fr2=rfrmra03686');

 if combobox1.ItemIndex=2 then

 webbrowser1.Navigate('http://yandex.ru/yandsearch?text='+edsearch.text+'&lr=213');

 if combobox1.ItemIndex=3 then

 webbrowser1.Navigate('http://search.msn.com/results.aspx?q='+edsearch.text+'&lr=');

 if combobox1.ItemIndex=4 then

 webbrowser1.Navigate('http://ru.wikipedia.org/wiki/special:Search?search='+edsearch.text+'&lr=');

 if combobox1.ItemIndex=5 then

 webbrowser1.Navigate('http://search.microsoft.com/results.aspx?mkt=ru-RU&setland=ru-RU&q='+edsearch.text+'&lr=');

 end;

 

// Закрыть приложение

procedure TfrmMyBrowser.Exit1Click(Sender: TObject);

begin

  Close;

end;

  // Активация кнопок  назад и вперёд, остановить

procedure TfrmMyBrowser.WebBrowser1CommandStateChange(Sender: TObject;

  Command: Integer; Enable: WordBool);

begin

  case Command of

    CSC_NAVIGATEBACK: begin

        TWebbrowser(Sender).FNavBack := Enable;

        ToolbtnBack.Enabled := Enable;

      end;

    CSC_NAVIGATEFORWARD: begin

        TWebbrowser(Sender).FNavForward := Enable;

        ToolBtnForward.Enabled := Enable;

      end;

  end;

end;

  // Обработка события OnResize формы

procedure TfrmMyBrowser.FormResize(Sender: TObject);

var

  r: TRect;

const

  SB_GETRECT = WM_USER + 10;

begin

  Statusbar1.Perform(SB_GETRECT, 2, Integer(@R));

  ProgressBar1.Parent := Statusbar1;

  ProgressBar1.SetBounds(r.Left, r.Top, r.Right - r.Left - 5, r.Bottom - r.Top);

    with Statusbar1 do

  begin

    Panels[1].Width := Width div 2 - 10;

    Panels[0].Width := 80;

    Panels[2].Width := 90;

    Panels[3].Width := 25;

    Panels[4].Width := 150;

    Refresh;

  end;

end;

     // Позволяет выводить значки состояния на понели состояния

function TfrmMyBrowser.DrawZoneIcon(WB: TWebbrowser): TIcon;

var

  ZoneAttr: TZoneAttributes;

  ZoneIcon: TIcon;

begin

  ZoneAttr := GetZoneAttributes(WB.LocationURL);

  ZoneIcon := TIcon.Create;

  try

    if GetZoneIcon(ZoneAttr.szIconPath, ZoneIcon) then

      Statusbar1.Panels[4].Text := ZoneAttr.szDisplayName;

    Result := ZoneIcon;

  finally

  end;

end;

 

// Статус бар отображает состояние интернета

procedure TfrmMyBrowser.StatusBar1DrawPanel(StatusBar: TStatusBar;

  Panel: TStatusPanel; const Rect: TRect);

var

  ZoneIcon: TIcon;

  CurrentWB: TWebbrowser;

begin

  if Panel = Statusbar1.Panels[3] then

  begin

    CurrentWB := GetCurrentWB;

    if Assigned(CurrentWB) then

    begin

      ZoneIcon := DrawZoneIcon(CurrentWB);

      if ZoneIcon.Handle <> 0 then

      begin

       Statusbar1.Canvas.Font.Color := clRed;

       Statusbar1.Canvas.FillRect(Rect);

       Statusbar1.Canvas.Draw(Rect.Left, Rect.Top, ZoneIcon);

      end;

      ZoneIcon.Free;

    end else

      Statusbar1.Panels[3].Text := '';

  end;

end;

  // Показывать текст  в StatusBar

procedure TfrmMyBrowser.WebBrowser1StatusTextChange(Sender: TObject;

  const Text: WideString);

var

  CurrentWB: TWebbrowser;

begin

  CurrentWB := GetCurrentWB;

  if Assigned(CurrentWB) then

  begin

    if TControl(CurrentWB).Hint = TControl(Sender).Hint then

      StatusBar1.Panels[1].Text := Text;

  end;

end;

  // Событие OnDownloadComplete для формы

procedure TfrmMyBrowser.WebBrowser1DownloadComplete(Sender: TObject);

begin

  StatusBar1.Repaint;

  ToolBtnStop.Enabled := False;

end;

// Размер текста в программе

procedure TfrmMyBrowser.Zoom1Click(Sender: TObject);

var

  CurrentWB: TWebbrowser;

  ZoomIndex: TWBFontSize;

begin

  CurrentWB := GetCurrentWB;

  if WB_DocumentLoaded(CurrentWB) then

  begin

    ZoomIndex := WB_GetZoom(CurrentWB);

    case ZoomIndex of

      4: Largest1.Checked := True;

      3: Large1.Checked := True;

      2: Medium1.Checked := True;

      1: Small1.Checked := True;

      0: Smallest1.Checked := True;

    end;

  end;

end;

      // Размер  текста в программе

procedure TfrmMyBrowser.Smallest1Click(Sender: TObject);

var

  CurrentWB: TWebbrowser;

  k: Integer;

begin

  CurrentWB := GetCurrentWB;

  if WB_DocumentLoaded(CurrentWB) then

  begin

      WB_SetZoom(CurrentWB, TMenuItem(Sender).Tag);

     for k := 0 to Zoom1.Count - 1 do

      Zoom1.Items[k].Checked := False;

        TMenuItem(Sender).Checked := True;

  end;

end;

      //  Изменение вкладок

procedure TfrmMyBrowser.PageControlChanging(Sender: TObject;

  var AllowChange: Boolean);

begin

  with PageControl do

    if ActivePage.ControlCount > 0 then

      if ActivePage.Controls[0] is TWebbrowser then

        FPrevBrowser := GetCurrentWB;

end;

 

   // Вывод адреса ссылки

 procedure TfrmMyBrowser.WebBrowser1NavigateComplete2(ASender: TObject;

  const pDisp: IDispatch; var URL: OleVariant);

begin

 edURL.Text := TWebbrowser(ASender).LocationURL;

end;

  ////////////////вывод заголовка  в вверху окна браузера//////////////////////////

  ////////////////создание автооткрывающегося  окна/////////////////

procedure TfrmMyBrowser.WebBrowser1NewWindow2(Sender: TObject;

  var ppDisp: IDispatch; var Cancel: WordBool);

var

  ts: TTabSheet;

begin

    if TWebbrowser(Sender).ReadyState <> READYSTATE_COMPLETE then

  begin

    ppDisp := nil;

    Cancel := True;

  end

  else

  begin

    ts:= CreateTabBrowser('','Новая вкладка');

    WaitForBrowser(TWebbrowser(ts.Controls[0]));

    ppdisp := (TWebbrowser(ts.Controls[0])).Application;

    WaitForBrowser(TWebbrowser(ts.Controls[0]));

  end;

end;

// Создание Webbrowser динамически

function TfrmMyBrowser.CreateTabBrowser(sURL, sCaption: string): TTabSheet;

var

  ts: TTabSheet;

  WB: TWebbrowser;

begin

  ts := TTabSheet.Create(PageControl);

  Result := ts;

  try

    ts.PageControl := PageControl;

    ts.Parent := PageControl;

    ts.Caption := sCaption;

    ts.PageIndex := PageControl.ActivePageIndex + 1;

    WB := TWebbrowser.Create(ts);

    TControl(WB).Parent := ts;

    WB.Align := alClient;

    WB.Silent := True;

    WB.Visible := True;

    PageControl.ActivePage := ts;

    WB.OnProgressChange := WebBrowser1ProgressChange;

    WB.OnStatusTextChange := WebBrowser1StatusTextChange;

    WB.OnTitleChange := WebBrowser1TitleChange;

    WB.OnNewWindow2 := WebBrowser1NewWindow2;

    WB.OnCommandStateChange := WebBrowser1CommandStateChange;

    WB.OnDownloadComplete := WebBrowser1DownloadComplete;

    WB.FNavForward := False;

    WB.FNavBack := False;

    if Trim(sURL) <> '' then

    begin

      WB.Navigate(sURL);

      WaitForBrowser(WB);

    end;

  except

    ts.Free;

  end;

end;

// Открытие Popupmenu

procedure TfrmMyBrowser.PageControlMouseDown(Sender: TObject;

  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

var

  XHitTestInfo: TTCHitTestInfo;

  HitIndex: Integer;

begin

  XHitTestInfo.pt := Classes.POINT(X, Y);

  HitIndex := TabCtrl_HitTest(PageControl.Handle, @XHitTestInfo);

  if HitIndex <> -1 then

    with PageControl do

    begin

      if Button = mbRight then

      begin

        ActivePageIndex := HitIndex;

        CloseTab1.Enabled := (ActivePage.Tag <> 2) and (ActivePageIndex <> 0);

        DuplicateTab1.Enabled := ActivePage.Controls[0] is TWebbrowser;

        if ActivePage.Tag <> 2 then

          PCPopup.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);

      end;

    end;

end;

  // Зактытие вкладки

procedure TfrmMyBrowser.CloseTab1Click(Sender: TObject);

begin

  if PageControl.ActivePageIndex > 0 then

  begin

    if PageControl.ActivePage.Controls[0] is TWebbrowser then

    begin

      (TWebbrowser(PageControl.ActivePage.Controls[0])).Free;

      FPrevBrowser := nil;

      PageControl.ActivePage.Free;

    end;

  end;

end;

  //закрывает активную  вкладку по нажатии кнопки

procedure TfrmMyBrowser.N11Click(Sender: TObject);

begin

  if PageControl.ActivePageIndex > 0 then

  begin

    if PageControl.ActivePage.Controls[0] is TWebbrowser then

    begin

        (TWebbrowser(PageControl.ActivePage.Controls[0])).Free;

      FPrevBrowser := nil;

      PageControl.ActivePage.Free;

    end;

  end;

end;

// Вызов справки

procedure TfrmMyBrowser.N13Click(Sender: TObject);

begin

  ShellExecute (frmMyBrowser.Handle, nil, 'UserGuide.chm', nil, nil, SW_show);  // вызов справка

end;

 

// Стоп загрузки страницы

procedure TfrmMyBrowser.N14Click(Sender: TObject);

begin

   WB_Stop(GetCurrentWB);

end;

  // Обновить страницу

procedure TfrmMyBrowser.N15Click(Sender: TObject);

begin

   WB_Refresh(GetCurrentWB);

   ToolBtnStop.Enabled := True;

end;

 

// Переход назад

 procedure TfrmMyBrowser.N17Click(Sender: TObject);

begin

  WB_GoBack(GetCurrentWB);

end;

  // Переход вперёд

procedure TfrmMyBrowser.N18Click(Sender: TObject);

begin

     WB_GoForward(GetCurrentWB);

end;

// Домашняя страница

procedure TfrmMyBrowser.N19Click(Sender: TObject);

begin

  GetCurrentWB.GoHome;

end;

// О программе

procedure TfrmMyBrowser.N20Click(Sender: TObject);

begin

 form3.Color:=panel1.Color;

form3.ListBox1.Color:=panel1.Color;

 form3.Show;

end;

    // Выход из программы

procedure TfrmMyBrowser.N21Click(Sender: TObject);

begin

 Close;

end;

 

// Создание новой вкладки

procedure TfrmMyBrowser.DuplicateTab1Click(Sender: TObject);

var

  iCurrTabIndex: Integer;

  ts: TTabSheet;

  CurrentWB, NewWB: TWebbrowser;

  sCurrURL: string;

begin

  CurrentWB := GetCurrentWB;

  if CurrentWB <> nil then

  begin

    iCurrTabIndex := PageControl.ActivePage.TabIndex;

      // название вкладки созданной заново

     sCurrURL := 'Новая  вкладка';

    ts := CreateTabBrowser('Новая вкладка',sCurrURL);

    NewWB := TWebbrowser(ts.Controls[0]);

    WaitForBrowser(NewWB);

    if NewWB.Document <> nil then

      (NewWB.Document as IHTMLDocument2).body.innerHTML := (CurrentWB.Document as IHTMLDocument2).body.innerHTML;

    ts.PageIndex := iCurrTabIndex + 1;

    PageControl.ActivePageIndex := ts.PageIndex;

  end;

end;

 

  // Исправление для ввода

procedure TfrmMyBrowser.ApplicationEvents1Message(var Msg: tagMSG;

  var Handled: Boolean);

const

  StdKeys = [VK_TAB, VK_RETURN];

  ExtKeys = [VK_DELETE, VK_BACK, VK_LEFT, VK_RIGHT];

  fExtended = $01000000;

var

  CurrentWB: TWebbrowser;

begin

  CurrentWB := GetCurrentWB;

  try

    if (CurrentWB = nil) or (CurrentWB.Document = nil) then

    begin

      Handled := False;

      Exit;

    end;

  except

  end;

    if (Msg.Message = WM_RBUTTONDOWN) or (Msg.Message = WM_RBUTTONDBLCLK) then

    begin

      if IsChild(CurrentWB.Handle, Msg.hwnd) then

      begin

        Handled := True;

        Exit;

      end;

    end;

if (GetKeyState(VK_CONTROL) < 0) and (Msg.Message = WM_KEYDOWN) and

    (Msg.wParam = Ord('N')) then