browserfrm.~pas

《Delphi实例开发教程》源代码包说明

unit BrowserFrm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, OleCtrls, SHDocVw, StdCtrls, Buttons, IdBaseComponent,
  IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, ComCtrls;

type
  TfrmBrowser = class(TForm)
    wbBrowser: TWebBrowser;
    pnlBrowser: TPanel;
    pnlControl: TPanel;
    svdlgSaveAs: TSaveDialog;
    sbDefaultSave: TSpeedButton;
    sbSaveAs: TSpeedButton;
    sbStop: TSpeedButton;
    sbBackward: TSpeedButton;
    sbForward: TSpeedButton;
    sbRefresh: TSpeedButton;
    edtURL: TEdit;
    stbBrowserStatus: TStatusBar;
    sbHomepage: TSpeedButton;
    sbOpen: TSpeedButton;
    sbSaveAsFile: TSpeedButton;
    sbSetHomepage: TSpeedButton;
    sbExit: TSpeedButton;
    sbLink: TSpeedButton;
    prbNavProgress: TProgressBar;
    procedure SaveAs(URL: string);
    //procedure sbSaveAsClick(Sender: TObject);
    procedure sbDefaultSaveClick(Sender: TObject);
    procedure CheckBtnAvailable;
    procedure wbBrowserBeforeNavigate2(Sender: TObject;
      const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
      Headers: OleVariant; var Cancel: WordBool);
    procedure wbBrowserDownloadComplete(Sender: TObject);
    procedure stbBrowserStatusDrawPanel(StatusBar: TStatusBar;
      Panel: TStatusPanel; const Rect: TRect);
    procedure wbBrowserProgressChange(Sender: TObject; Progress,
      ProgressMax: Integer);
    procedure sbBackwardClick(Sender: TObject);
    procedure sbForwardClick(Sender: TObject);
    procedure sbStopClick(Sender: TObject);
    procedure sbRefreshClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure wbBrowserTitleChange(Sender: TObject;
      const Text: WideString);
    procedure sbHomepageClick(Sender: TObject);
    procedure sbOpenClick(Sender: TObject);
    procedure sbSaveAsFileClick(Sender: TObject);
    procedure sbSetHomepageClick(Sender: TObject);
    procedure sbExitClick(Sender: TObject);
    procedure sbLinkClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmBrowser: TfrmBrowser;
  ID: string;
  URL: string;
  TempStream: TMemoryStream;
  HistoryIndex: Integer;
  BtnClicked: Boolean;
  HistoryList: TStringList;
  Homepage:string;
implementation

uses MainFrm, CustomSearchFrm;

{$R *.dfm}

procedure TfrmBrowser.SaveAs(URL: string);
var
  Filename:TFileName;
begin
  //另存为
  if svdlgSaveAs.Execute then
  begin
    TempStream:=TMemoryStream.Create;
    //获取文件内容
    try
      frmMain.idhttpHTTP.Get(URL,TempStream);
      FileName:=svdlgSaveAs.FileName;
      //保存文件
      TempStream.SaveToFile(FileName);
      TempStream.Free;
    except
      ShowMessage('保存文件失败！');
      TempStream.Free;
      Exit;
    end;
  end;
end;

{procedure TfrmBrowser.sbSaveAsClick(Sender: TObject);
begin
  SaveAs(URL);
end; }

procedure TfrmBrowser.sbDefaultSaveClick(Sender: TObject);
var
  DefaultName,Msg,Filename,SQLString:string;
begin
  while True do
  begin
    //输入文件名
    if InputQuery('请输入文件名','',DefaultName)=False then
      Exit;
    Filename:=extractfilepath(application.ExeName)+'library\'+DefaultName;
    if not(FileExists(Filename)) then
    begin
      ShowMessage('');
      Break;
    end;
  end;

  //ID没有保存过，先保存ID
  if ID='' then
  begin
    //提示
    Msg:='保存入库之前要先保存定制！'+#13+'要现在保存定制吗？';
    if MessageDlg(Msg,mtWarning,[mbYes,mbNo],0)=mrNo then
      Exit;
    Msg:='将保存所有搜索信息！'+#13+'确定要保存定制吗？';
    if MessageDlg(Msg,mtWarning,[mbYes,mbNo],0)=mrNo then
      Exit;

    //保存ID定制
    frmCustomSearch.fraInput.sbSaveID.Click;
  end;

  //ID不为空或者已经保存过，则开始保存
  if ID<>'' then
  begin
    //保存搜索信息
    frmMain.TransferTable('temp','Info',ID);
    TempStream.SaveToFile(Filename);

    //把URL链接改为本地文件链接
    SQLString:='select * from Info where ID='+quotedstr(ID)+' and Link='+quotedstr(URL);
   // with frmMain.qryInfo do
   with frmMain.AdoqInfo do
    begin
     // frmMain.MyExecSQL(frmMain.qryInfo,SQLString
      frmMain.MyExecSQL(frmMain.AdoqInfo,SQLString);
      Edit;
      FieldByName('Link').AsString:=FileName;
      Post;
    end;
  end;
end;




//判断前进后退键能否使用
procedure TfrmBrowser.CheckBtnAvailable;
begin

  //判断后退键能否使用
  if HistoryIndex>0 then
    sbBackward.Enabled:=True
  else
    sbBackward.Enabled:=False;

  //判断前进键能否使用
  if HistoryIndex<HistoryList.Count-1 then
    sbForward.Enabled:=True
  else
    sbForward.Enabled:=False;
end;

procedure TfrmBrowser.wbBrowserBeforeNavigate2(Sender: TObject;
  const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
var
  NewIndex :Integer;
begin
  //启用按键
  sbStop.Enabled:=True;
  sbRefresh.Enabled:=True;
  NewIndex:=HistoryList.IndexOf(URL);

  //处理历史记录

  //用户新打开的页面
  if NewIndex=-1 then
  begin
    //存在多个历史记录，并且历史记录没有到最后
    if (HistoryIndex>=0) and (HistoryIndex<HistoryList.Count-1) then
      //清后面的历史记录
      while HistoryList.Count>HistoryIndex do
        HistoryList.Delete(HistoryIndex);
    //添加历史记录，指数指向新历史
    HistoryIndex:=HistoryList.Add(URL);
  end

  //历史记录页面
  else
    //设定历史记录指数
    HistoryIndex:=NewIndex;

  //检查按钮可用性
  CheckBtnAvailable;

  //显示地址
  edtURL.Text:=URL;

  stbBrowserStatus.Panels[0].Text:='正在查找'+edtURL.Text;
end;

procedure TfrmBrowser.wbBrowserDownloadComplete(Sender: TObject);
begin
  stbBrowserStatus.Panels[0].Text:='完成';
end;

procedure TfrmBrowser.stbBrowserStatusDrawPanel(StatusBar: TStatusBar;
  Panel: TStatusPanel; const Rect: TRect);
begin
  //把进度条放进状态栏
  prbNavProgress.Parent:=stbBrowserStatus;
  prbNavProgress.Top:=Rect.Top-1;
  prbNavProgress.Left:=Rect.Left-1;
  prbNavProgress.Width:=Panel.Width-2;
  prbNavProgress.Height:=Rect.Bottom-Rect.Top+2;
end;

procedure TfrmBrowser.wbBrowserProgressChange(Sender: TObject; Progress,
  ProgressMax: Integer);
begin
  //显示进度
  if ProgressMax<>0 then
    prbNavProgress.Position:=Trunc(Progress*100/ProgressMax)
  else
    prbNavProgress.Position:=0;
    
end;

procedure TfrmBrowser.sbBackwardClick(Sender: TObject);
begin
  wbBrowser.Navigate(HistoryList[HistoryIndex-1]);
end;

procedure TfrmBrowser.sbForwardClick(Sender: TObject);
begin
  wbBrowser.Navigate(HistoryList[HistoryIndex+1]);
end;

procedure TfrmBrowser.sbStopClick(Sender: TObject);
begin
  wbBrowser.Stop;
  stbBrowserStatus.Panels[0].Text:='完成';
end;

procedure TfrmBrowser.sbRefreshClick(Sender: TObject);
begin
  wbBrowser.Refresh;
end;

procedure TfrmBrowser.FormCreate(Sender: TObject);
begin
  //初始化变量
  HistoryIndex:=-1;

  //创建历史记录列表，存放浏览器历史记录
  HistoryList:=TStringList.Create;
end;

procedure TfrmBrowser.wbBrowserTitleChange(Sender: TObject;
  const Text: WideString);
begin  
  stbBrowserStatus.Panels[0].Text:='正在打开'+edtURL.Text;
end;

procedure TfrmBrowser.sbHomepageClick(Sender: TObject);
var
  flags:OleVariant;
begin
    flags:=0;
    wbBrowser.Stop;
    edtURL.text:=Homepage;
    wbbrowser.Navigate(widestring(edtURL.text),flags,flags,flags,flags);
end;

procedure TfrmBrowser.sbOpenClick(Sender: TObject);
var
  Flags:OleVariant;
  OpndlgOpen:TOpendialog;
begin
    OpndlgOpen:=TOpendialog.Create(self);
    OpndlgOpen.Filter:='HTML Files(*.html;htm)|*.html;*.htm';
    if OpndlgOpen.Execute then
    begin
        edtURL.text:=OpndlgOpen.filename;
        Flags:=0;
        wbBrowser.Navigate(widestring(edtURL.text),Flags,Flags,Flags,Flags);
    end;

end;

procedure TfrmBrowser.sbSaveAsFileClick(Sender: TObject);
var
  Code : String;
   F: textfile;

begin
  svdlgSaveAs.Filter:='HTML Files(*.html;htm)|*.html;*.htm';
  if svdlgSaveAs.Execute then
  begin

    try
      Code:=frmMain.IdhttpHTTP.Get(edtURL.Text);
      assignfile(f,svdlgSaveAs.FileName);
      rewrite(f);
      writeln(f,Code);
      closefile(f);

    except
      ShowMessage('保存文件失败！');
      Exit;
    end;
  end;

end;

procedure TfrmBrowser.sbSetHomepageClick(Sender: TObject);
var
  info:array[1..100] of string;
  ConfigFile:TextFile; //配置文件
  i,j:integer;
begin
  i:=1;
  AssignFile(ConfigFile,'netpeer.ini');
  if FileExists('netpeer.ini') then
  begin
      Reset(Configfile);
      while not Eof(ConfigFile) do
      begin
          Readln(ConfigFile,info[i]);
          i:=i+1;
      end;
      CloseFile(ConfigFile);
  end;
  if i=1 then
  begin
     Homepage:= InputBox('主页设置', '请输入主页地址：', '');
     i:=2;
  end
  else
  begin
     Homepage:= InputBox('主页设置', '请输入主页地址：', info[1]);
  end;
  info[1]:=Homepage;
  Rewrite(ConfigFile);
  for j:=1 to i-1 do
      Writeln(ConfigFile,info[j]);
  CloseFile(ConfigFile);

end;

procedure TfrmBrowser.sbExitClick(Sender: TObject);
begin
close;
end;

procedure TfrmBrowser.sbLinkClick(Sender: TObject);
begin
wbBrowser.Navigate(edtURL.Text);
end;

end.