📄 main.pas

📁 Delphi网络应用开发的源代码
💻 PAS
字号:
unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,ComObj,Types, Menus, ExtCtrls, ToolWin, ComCtrls, StdCtrls, ActnList,
  OleCtrls, SHDocVw, jpeg, ImgList,Registry,ActiveX;

type
  TFrmBrowser = class(TForm)
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    MenuFavorit: TMenuItem;
    N5: TMenuItem;
    ActionList1: TActionList;
    TBBtn: TToolBar;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    CoolBar1: TCoolBar;
    TBMenu: TToolBar;
    N6: TMenuItem;
    N7: TMenuItem;
    N8: TMenuItem;
    N13: TMenuItem;
    N14: TMenuItem;
    N15: TMenuItem;
    N16: TMenuItem;
    N17: TMenuItem;
    Largest: TMenuItem;
    Larger: TMenuItem;
    Middle: TMenuItem;
    Small: TMenuItem;
    Smallest: TMenuItem;
    N24: TMenuItem;
    N25: TMenuItem;
    N26: TMenuItem;
    TBLink: TToolBar;
    ToolButton3: TToolButton;
    ToolButton4: TToolButton;
    ActOpen: TAction;
    ActClose: TAction;
    ActCopy: TAction;
    ActGoto: TAction;
    ActStop: TAction;
    ActRefrech: TAction;
    ActFont: TAction;
    ActAddTo: TAction;
    ActHelp: TAction;
    ActLinkToNetEase: TAction;
    ActLinkToSina: TAction;
    ActLinkToSohu: TAction;
    ActLinkHUST: TAction;
    ImageList1: TImageList;
    ToolButton5: TToolButton;
    ToolButton6: TToolButton;
    ActFoward: TAction;
    ActBackward: TAction;
    Panel1: TPanel;
    WebBrowser: TWebBrowser;
    ImaListHot: TImageList;
    ImaListUnFocus: TImageList;
    ToolButton7: TToolButton;
    ToolButton8: TToolButton;
    ToolButton9: TToolButton;
    ComboAddr: TComboBoxEx;
    ActFavoritClk: TAction;
    OpenDialog1: TOpenDialog;
    ActManageFavorit: TAction;
    N4: TMenuItem;
    ToolBar1: TToolBar;
    ToolButton10: TToolButton;
    ActSelAll: TAction;
    N10: TMenuItem;
    procedure ActLinkToNetEaseExecute(Sender: TObject);
    procedure ActLinkToSinaExecute(Sender: TObject);
    procedure ActLinkToSohuExecute(Sender: TObject);
    procedure ActLinkHUSTExecute(Sender: TObject);
    procedure ActAddToExecute(Sender: TObject);
    procedure ActRefrechExecute(Sender: TObject);
    procedure ActStopExecute(Sender: TObject);
    procedure ActFowardExecute(Sender: TObject);
    procedure ActBackwardExecute(Sender: TObject);
    procedure ComboAddrKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormCreate(Sender: TObject);
    procedure ComboAddrSelect(Sender: TObject);
    procedure ActFavoritClkExecute(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ActOpenExecute(Sender: TObject);
    procedure ActManageFavoritExecute(Sender: TObject);
    procedure ActFontExecute(Sender: TObject);
    procedure ActGotoExecute(Sender: TObject);
    procedure ActCopyExecute(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure ActCutExecute(Sender: TObject);
    procedure ActPasteExecute(Sender: TObject);
    procedure ActSelAllExecute(Sender: TObject);
    procedure ActCloseExecute(Sender: TObject);
  private
    { Private declarations }
    FavoritFolder : String;
    FolderCount : Integer;
    URLList : TStringList;
  public
    { Public declarations }
    procedure ReadTypedURL;
    procedure HistoryAddItem(AURL : String);
    procedure ReadFavorit(ARootItem : TMenuItem;APath : String);
  end;

var
  FrmBrowser: TFrmBrowser;
const
  CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';

implementation

{$R *.dfm}

procedure TFrmBrowser.ActLinkToNetEaseExecute(Sender: TObject);
begin
  ComboAddr.Text:='http://www.163.com';
  WebBrowser.Navigate('http://www.163.com');
end;

procedure TFrmBrowser.ActLinkToSinaExecute(Sender: TObject);
begin
  ComboAddr.Text:='http://www.sina.com';
  WebBrowser.Navigate('http://www.sina.com');
end;

procedure TFrmBrowser.ActLinkToSohuExecute(Sender: TObject);
begin
  ComboAddr.Text:='http://www.Sohu.com';
  WebBrowser.Navigate('http://www.Sohu.com');
end;

procedure TFrmBrowser.ActLinkHUSTExecute(Sender: TObject);
begin
  ComboAddr.Text:='http://www.hust.edu.cn';
  WebBrowser.Navigate('http://www.hust.edu.cn');
end;


procedure TFrmBrowser.ActAddToExecute(Sender: TObject);
var
  ShellUIHelper: ISHellUIHelper;
  url, title: Olevariant;
begin
  Title := Webbrowser.LocationName;
  Url := Webbrowser.LocationUrl;
  if Url <>  '' then
  begin
    ShellUIHelper := CreateComObject(CLSID_ShellUIHelper) as IShellUIHelper;
    ShellUIHelper.AddFavorite(url, title);
  end;
end;

procedure TFrmBrowser.ActRefrechExecute(Sender: TObject);
begin
  try
    WebBrowser.Refresh;
  finally
  end;
end;

procedure TFrmBrowser.ActStopExecute(Sender: TObject);
begin
  try
    WebBrowser.Stop;
  finally
  end;
end;

procedure TFrmBrowser.ActFowardExecute(Sender: TObject);
begin
  try
    WebBrowser.GoForward;
  finally
  end;
end;

procedure TFrmBrowser.ActBackwardExecute(Sender: TObject);
begin
  try
    WebBrowser.GoBack;
  finally
  end;
end;

procedure TFrmBrowser.ComboAddrKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  AText : String;
begin
  if Key = VK_RETURN then
  begin
    AText := Trim(ComboAddr.Text);
    if ComboAddr.Items.IndexOf(AText) < 0 then
      HistoryAddItem(AText);
    WebBrowser.Navigate(AText);
  end;
end;

procedure TFrmBrowser.FormCreate(Sender: TObject);
var
  Reg : TRegistry;
  URL : OleVariant;
  Font : OleVariant;
begin
{
1 从 HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\TypedURLs 处可以读出已经访问的地址
2 HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Favorites
  HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Favorites
  可以读出收藏夹目录
}
  inherited;
  Reg:=TRegistry.Create;

  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False) then
    begin
      FavoritFolder:=Reg.ReadString('Favorites');
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
    ReadTypedURL;
    FolderCount:=3;
    URLList := TStringList.Create;
    ReadFavorit(MenuFavorit,FavoritFolder);
    URL := 'about:blank';
    ComboAddr.Text:='about:blank';
    WebBrowser.Navigate2(URL);

    Self.Panel1.Align:=alClient;
//    WebBrowser.ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER,Font,Font);
//    WebBrowser.ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER);
//    case Font of
//      4: Largest.Checked :=true;
//      3: Larger.Checked :=true;
//      2: Middle.Checked :=true;
//      1: Small.Checked :=true;
//      0: Smallest.Checked :=true;
//    end;
  end;
end;

procedure TFrmBrowser.ReadTypedURL;
var
  Reg : TRegistry;
  Val : TStringList;
  I : Integer;
begin
  Reg:=TRegistry.Create;
  Val:=TStringList.Create;
  try
    if Reg.OpenKey('\Software\Microsoft\Internet Explorer\TypedURLs', False) then
    begin
      Reg.GetValueNames(Val);
      ComboAddr.ItemsEx.Clear;
      for I:=0 to Val.Count - 1 do
        HistoryAddItem(Reg.ReadString(Val.Strings[I]));
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
    Val.Free;
  end;
end;

procedure TFrmBrowser.HistoryAddItem(AURL : String);
var
  Item : TComboExItem;
begin
  Item:=ComboAddr.ItemsEx.Add;
  Item.Caption:=AURL;
  if pos('http:',AURL) > 0 then
     Item.ImageIndex := 0
  else if pos('ftp:',AURL) > 0 then
     Item.ImageIndex := 1
  else
    Item.ImageIndex := 2;
end;

procedure TFrmBrowser.ComboAddrSelect(Sender: TObject);
begin
  WebBrowser.Navigate(ComboAddr.Text);
end;

procedure TFrmBrowser.ReadFavorit(ARootItem : TMenuItem;APath : String);
var
  NewItem : TMenuItem;
  sr: TSearchRec;
  FileAttrs: Integer;
  AURL : String;
  Buffer: array[0..2047] of char;
begin
  FileAttrs := faArchive + faDirectory;
  if FindFirst(APath+'\*', FileAttrs, sr) = 0 then
  begin
    repeat
      if ((sr.Attr and faDirectory) = sr.Attr) And (sr.Name <> '.') And (sr.Name<>'..') then
      begin
        NewItem:=TMenuItem.Create(nil);
        NewItem.Caption:=sr.Name;
        NewItem.Visible:=true;
        NewItem.ImageIndex:= 3;
        ARootItem.Insert(FolderCount,NewItem);
        FolderCount := FolderCount+1;
        ReadFavorit(NewItem,APath+'\'+sr.Name);
      end
      else if (sr.Attr and faArchive) = sr.Attr then
      begin
        NewItem:=TMenuItem.Create(nil);
        GetPrivateProfileString('InternetShortcut',PChar('URL'), nil, Buffer, SizeOf(Buffer), PChar(APath+'\'+sr.Name));
        AURL:=String(Buffer);
        Delete(sr.Name, Pos('.url', sr.Name), 4);
        NewItem.ImageIndex:= 0;
        NewItem.Visible:=true;
        NewItem.Tag:=URLList.Count;
        NewItem.Hint:=AURL;
        URLList.Add(AURL);
        NewItem.OnClick:=ActFavoritClkExecute;
        NewItem.Caption:=sr.Name;
        ARootItem.Add(NewItem);
      end;
    until FindNext(sr) <> 0;
    FindClose(sr);
  end;
end;

procedure TFrmBrowser.ActFavoritClkExecute(Sender: TObject);
begin
  ComboAddr.Text:=URLList.Strings[TMenuItem(Sender).tag];
  WebBrowser.Navigate(ComboAddr.Text);
end;

procedure TFrmBrowser.FormDestroy(Sender: TObject);
begin
  URLList.Free;
end;

procedure TFrmBrowser.ActOpenExecute(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    ComboAddr.Text:=OpenDialog1.FileName;
    WebBrowser.Navigate(OpenDialog1.FileName);
  end;
end;

procedure TFrmBrowser.ActManageFavoritExecute(Sender: TObject);
var
  proc : procedure(Handle: THandle; Path: PChar); stdcall;
  WHwnd : HWnd;
begin
  WHwnd := LoadLibrary(PChar('shdocvw.dll'));
  if WHwnd <>  0 then
  begin
    proc := GetProcAddress(WHwnd, PChar('DoOrganizeFavDlg'));
    if Assigned(proc) then
       proc(Application.Handle, PChar(FavoritFolder));
  end;
  FreeLibrary(WHwnd);
end;

procedure TFrmBrowser.ActFontExecute(Sender: TObject);
var
  Font : OleVariant;
begin
  TMenuItem(Sender).Checked :=true;
  Font :=TMenuItem(Sender).Tag;
  WebBrowser.ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER,Font,Font);
end;

procedure TFrmBrowser.ActGotoExecute(Sender: TObject);
var
  AText :String;
begin
  AText := Trim(ComboAddr.Text);
  if ComboAddr.Items.IndexOf(AText) < 0 then
    HistoryAddItem(AText);
  WebBrowser.Navigate(AText);
end;

procedure TFrmBrowser.ActCopyExecute(Sender: TObject);
begin
  WebBrowser.ExecWB(OLECMDID_COPY, OLECMDEXECOPT_DONTPROMPTUSER);
end;

procedure TFrmBrowser.N3Click(Sender: TObject);
var
  Font : OleVariant;
begin
  WebBrowser.ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER,EmptyParam,Font);
  case Font of
    4: Largest.Checked :=true;
    3: Larger.Checked :=true;
    2: Middle.Checked :=true;
    1: Small.Checked :=true;
    0: Smallest.Checked :=true;
  end;

end;

procedure TFrmBrowser.ActCutExecute(Sender: TObject);
begin
  WebBrowser.ExecWB(OLECMDID_CUT, OLECMDEXECOPT_DONTPROMPTUSER);
end;

procedure TFrmBrowser.ActPasteExecute(Sender: TObject);
begin
  WebBrowser.ExecWB(OLECMDID_PASTE, OLECMDEXECOPT_DONTPROMPTUSER);
end;

procedure TFrmBrowser.ActSelAllExecute(Sender: TObject);
begin
  WebBrowser.ExecWB(OLECMDID_SELECTALL, OLECMDEXECOPT_DONTPROMPTUSER);
end;

procedure TFrmBrowser.ActCloseExecute(Sender: TObject);
begin
  Self.Close;
end;

initialization
  OleInitialize(nil);

finalization
  try
    OleUninitialize;
  except
  end;

end.
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -