mainfm.~pas

利用delphi编程实现一个简单的web浏览器。实现浏览器的基本功能。

unit MainFM;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, ToolWin, ComCtrls, ImgList, StdCtrls, ActnList, OleCtrls,
  SHDocVw;

type
  TWebBrowerForm = class(TForm)
    MainMenu: TMainMenu;
    MIFile: TMenuItem;
    MIOpenFile: TMenuItem;
    N3: TMenuItem;
    MIExit: TMenuItem;
    N5: TMenuItem;
    MIToolBar: TMenuItem;
    N7: TMenuItem;
    MIStop: TMenuItem;
    MIRefresh: TMenuItem;
    N10: TMenuItem;
    MIBack: TMenuItem;
    MIForward: TMenuItem;
    N13: TMenuItem;
    CoolBar1: TCoolBar;
    ToolBar1: TToolBar;
    ImageList: TImageList;
    TBBack: TToolButton;
    TBForward: TToolButton;
    TBStop: TToolButton;
    TBRefresh: TToolButton;
    Animate: TAnimate;
    CBAddress: TComboBox;
    ToolBar2: TToolBar;
    TBSina: TToolButton;
    TBSohu: TToolButton;
    WebBrowser: TWebBrowser;
    ActionList1: TActionList;
    ActionBack: TAction;
    ActionForward: TAction;
    ActionStop: TAction;
    ActionRefresh: TAction;
    DgOpenFile: TOpenDialog;
    procedure ActionBackExecute(Sender: TObject);
    procedure ActionBackUpdate(Sender: TObject);
    procedure ActionForwardExecute(Sender: TObject);
    procedure ActionForwardUpdate(Sender: TObject);
    procedure ActionStopExecute(Sender: TObject);
    procedure ActionRefreshExecute(Sender: TObject);
    procedure CBAddressClick(Sender: TObject);
    procedure CBAddressKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure TBSinaClick(Sender: TObject);
    procedure TBSohuClick(Sender: TObject);
    procedure MIOpenFileClick(Sender: TObject);
    procedure MIExitClick(Sender: TObject);
    procedure MIToolBarClick(Sender: TObject);
    procedure WebBrowserBeforeNavigate2(Sender: TObject;
      const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
      Headers: OleVariant; var Cancel: WordBool);
    procedure WebBrowserDownloadBegin(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure WebBrowserDownloadComplete(Sender: TObject);
    procedure N13Click(Sender: TObject);
  private
    { Private declarations }
    HistoryIndex:integer; //历史纪录索引
    SLHistory:TStringList; //保存历史纪录的字符串列表
    UPdateCBAddress:boolean; //是否刷新过
    procedure SearchAddress; //查找当前地址

  public
    { Public declarations }
  end;

var
  WebBrowerForm: TWebBrowerForm;

implementation

{$R *.dfm}

procedure TWebBrowerForm.SearchAddress;
var Flags:OLEVariant;
begin
    try
      Flags:=0;
      UPdateCBAddress:=True;
      WebBrowser.Navigate(WideString(CBAddress.Text),Flags,Flags,Flags,Flags);
    except
      ShowMessage('打不开文件！');
    end;
end;

procedure TWebBrowerForm.ActionBackExecute(Sender: TObject);
begin
    CBAddress.Text:=SLHistory.Strings[HistoryIndex-1];
    SearchAddress;
end;

procedure TWebBrowerForm.ActionBackUpdate(Sender: TObject);
begin
    if SLHistory.Count>0 then
        ActionBack.Enabled:=HistoryIndex>0
    else
        ActionBack.Enabled:=False;
end;

procedure TWebBrowerForm.ActionForwardExecute(Sender: TObject);
begin
    CBAddress.Text:=SLHistory.Strings[HistoryIndex+1];
    SearchAddress;
end;

procedure TWebBrowerForm.ActionForwardUpdate(Sender: TObject);
begin
    if SLHistory.Count>0 then
        ActionForward.Enabled:=HistoryIndex<(SLHistory.Count-1)
    else
        ActionForward.Enabled:=False;    
end;

procedure TWebBrowerForm.ActionStopExecute(Sender: TObject);
begin
    WebBrowser.Stop;
end;

procedure TWebBrowerForm.ActionRefreshExecute(Sender: TObject);
begin
    SearchAddress;
end;

procedure TWebBrowerForm.CBAddressClick(Sender: TObject);
begin
    SearchAddress;
end;

procedure TWebBrowerForm.CBAddressKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
    if Key=VK_Return then
        SearchAddress;
end;

procedure TWebBrowerForm.TBSinaClick(Sender: TObject);
begin
    CBAddress.Text:='www.sina.com.cn';
    SearchAddress;
end;

procedure TWebBrowerForm.TBSohuClick(Sender: TObject);
begin
    CBAddress.Text:='www.sohu.com';
    SearchAddress;
end;

procedure TWebBrowerForm.MIOpenFileClick(Sender: TObject);
begin
    if DgOpenFile.Execute then
    begin
        CBAddress.Text:=DgOpenFile.FileName;
        SearchAddress;
    end;
end;

procedure TWebBrowerForm.MIExitClick(Sender: TObject);
begin
    Close;
end;

procedure TWebBrowerForm.MIToolBarClick(Sender: TObject);
begin
    with Sender as TMenuItem do
    begin
        Checked:=not Checked;
        CoolBar1.Visible:=Checked;
    end;
end;

procedure TWebBrowerForm.WebBrowserBeforeNavigate2(Sender: TObject;
  const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
var NewIndex:integer;
begin
    NewIndex:=SLHistory.IndexOf(URL);

    if NewIndex=-1 then //未找到
    begin
        if (HistoryIndex>=0) and (HistoryIndex<SLHistory.Count-1) then
            while SLHistory.Count> HistoryIndex do
                SLHistory.Delete(HistoryIndex);
        HistoryIndex:=SLHistory.Add(URL);
    end
    else
        HistoryIndex:=NewIndex;

    if UpdateCBAddress then
    begin
        UpdateCBAddress:=False;
        NewIndex:=CBAddress.Items.IndexOf(URL);
        if NewIndex=-1 then
            CBAddress.Items.Insert(0,URL)
        else
            CBAddress.Items.Move(NewIndex,0);
    end;

    CBAddress.Text:=URL;
end;

procedure TWebBrowerForm.WebBrowserDownloadBegin(Sender: TObject);
begin
    TBStop.Enabled:=True;
    Animate.Active:=True;
end;

procedure TWebBrowerForm.FormCreate(Sender: TObject);
begin
    HistoryIndex:=-1;
    SLHistory:=TStringList.Create;
    Animate.Active:=False;
end;

procedure TWebBrowerForm.FormDestroy(Sender: TObject);
begin
    SLHistory.Free;
end;

procedure TWebBrowerForm.WebBrowserDownloadComplete(Sender: TObject);
begin
    TBStop.Enabled:=False;
    Animate.Active:=False;
end;

procedure TWebBrowerForm.N13Click(Sender: TObject);
begin
    Application.HelpCommand(HELP_CONTENTS,0)
end;

end.