main.pas

datacnie多页面浏览器datacnie 原程序

//程序设计：山泉 未经作者同意,请暂时不要传开源码，谢谢
unit main;

interface

uses
  Tabs,JclStrings, ComCtrls, ExtCtrls, ToolWin,StdCtrls, ImgList, SHDOCVW,
  Windows, Messages, jpeg, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, KsItems, KsSkinItems, KsMenus, KsSkinMenus, KsEdits,
  KsSkinEdits, KsLabels, KsSkinLabels, inifiles, KsSpeedButtons, KsControls,
  KsSkinSpeedButtons, KsToolBars, KsSkinToolBars, KsControlBars,
  KsSkinControlBars, Menus, KsHooks, KsForms, KsSkinForms, KsSkinEngine,
  IEAddress, KsTabs, KsSkinTabs, KsPanels,
  KsSkinPanels, KsButtons, KsSkinButtons, CheckLst, Buttons,
  HistoryListView, FavoritesListView, KsListBoxs, EmbeddedWB, KsSkinListBoxs,
  AppEvnts, registry, ActiveX, shlObj, Wininet, KsMessages, KsSkinMessages, shellapi, ComObj,
  ActnList, Urlmon, OleCtrls, mshtml, SHDocVw_TLB;
 const
  CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';

type
  TmainForm = class(TForm)
    PopupMenu1: TPopupMenu;
    meublank: TMenuItem;
    meucurrent: TMenuItem;
    Pmemufont: TPopupMenu;
    aa: TMenuItem;
    ab: TMenuItem;
    ac: TMenuItem;
    ad: TMenuItem;
    ae: TMenuItem;
    SeSkinEngine1: TSeSkinEngine;
    SeSkinForm1: TSeSkinForm;
    SeSkinControlBar1: TSeSkinControlBar;
    SeSkinToolBar2: TSeSkinToolBar;
    SeSkinSpeedButton1: TSeSkinSpeedButton;
    SeSkinSpeedButton2: TSeSkinSpeedButton;
    SeSkinSpeedButton3: TSeSkinSpeedButton;
    KsSpeedDivider1: TKsSpeedDivider;
    SeSkinSpeedButton4: TSeSkinSpeedButton;
    SeSkinSpeedButton5: TSeSkinSpeedButton;
    KsSpeedDivider2: TKsSpeedDivider;
    KsSpeedDivider3: TKsSpeedDivider;
    SeSkinSpeedButton6: TSeSkinSpeedButton;
    SeSkinSpeedButton7: TSeSkinSpeedButton;
    Tbziyuan: TSeSkinSpeedButton;
    Tbnew: TSeSkinSpeedButton;
    ForwardDropDownBtn: TSeSkinSpeedButton;
    Tbprint: TSeSkinSpeedButton;
    KsSpeedContainer1: TKsSpeedContainer;
    SeSkinMenuBar1: TSeSkinMenuBar;
    CustomItem1: TSeSkinItem;
    CustomItem3: TSeSkinItem;
    CustomItem15: TSeSkinItem;
    CustomItem16: TSeSkinItem;
    meuview: TSeSkinItem;
    meutoollan: TSeSkinItem;
    CustomItem6: TSeSkinItem;
    CustomItem7: TSeSkinItem;
    CustomItem9: TSeSkinItem;
    CustomItem12: TSeSkinItem;
    CustomItem21: TSeSkinItem;
    CustomItem22: TSeSkinItem;
    CustomItem23: TSeSkinItem;
    meutools: TSeSkinItem;
    CustomItem11: TSeSkinItem;
    CustomItem13: TSeSkinItem;
    CustomItem14: TSeSkinItem;
    meuhelpzhu: TSeSkinItem;
    CustomItem18: TSeSkinItem;
    CustomItem19: TSeSkinItem;
    meuabout: TSeSkinItem;
    meunew: TSeSkinItem;
    mueopen: TSeSkinItem;
    meusave: TSeSkinItem;
    meusaveas: TSeSkinItem;
    CustomItem28: TSeSkinItem;
    meuprint: TSeSkinItem;
    meuprintoption: TSeSkinItem;
    CustomItem31: TSeSkinItem;
    meucloseone: TSeSkinItem;
    meucloseall: TSeSkinItem;
    CustomItem4: TSeSkinItem;
    meuedit: TSeSkinItem;
    meucut: TSeSkinItem;
    meucopy: TSeSkinItem;
    meupaste: TSeSkinItem;
    meuselectall: TSeSkinItem;
    meufind: TSeSkinItem;
    CustomItem40: TSeSkinItem;
    CustomItem41: TSeSkinItem;
    meubutton: TSeSkinItem;
    meuaddress: TSeSkinItem;
    N60: TSeSkinItem;
    CustomItem48: TSeSkinItem;
    CustomItem52: TSeSkinItem;
    meugoti: TSeSkinItem;
    N45: TSeSkinItem;
    N46: TSeSkinItem;
    N48: TSeSkinItem;
    meufontsixe: TSeSkinItem;
    meubianma: TSeSkinItem;
    largest: TSeSkinItem;
    larger: TSeSkinItem;
    middle: TSeSkinItem;
    small: TSeSkinItem;
    smallest: TSeSkinItem;
    meujchinese: TSeSkinItem;
    meufchinese: TSeSkinItem;
    CustomItem63: TSeSkinItem;
    meustop: TSeSkinItem;
    meurefresh: TSeSkinItem;
    CustomItem66: TSeSkinItem;
    N54: TSeSkinItem;
    N53: TSeSkinItem;
    meufav: TSeSkinItem;
    meuguofav: TSeSkinItem;
    meuaddfav: TSeSkinItem;
    meusendmail: TSeSkinItem;
    CustomItem73: TSeSkinItem;
    CustomItem10: TSeSkinItem;
    N15: TSeSkinItem;
    N16: TSeSkinItem;
    N18: TSeSkinItem;
    CustomItem77: TSeSkinItem;
    meuNetop: TSeSkinItem;
    meuinterop: TSeSkinItem;
    meukuai: TSeSkinItem;
    N12: TSeSkinItem;
    CustomItem82: TSeSkinItem;
    N6: TSeSkinItem;
    N9: TSeSkinItem;
    N8: TSeSkinItem;
    N10: TSeSkinItem;
    meutrans: TSeSkinItem;
    meueng: TSeSkinItem;
    meujapan: TSeSkinItem;
    Cbaddress: TSeSkinControlBar;
    SeSkinToolBar1: TSeSkinToolBar;
    KsSpeedContainer4: TKsSpeedContainer;
    SeSkinLabel2: TSeSkinLabel;
    Tbsendemail: TSeSkinSpeedButton;
    Tbfullsencee: TSeSkinSpeedButton;
    Tbfontsize: TSeSkinSpeedButton;
    Tbhome: TSeSkinSpeedButton;
    tbrefresh: TSeSkinSpeedButton;
    tbstop: TSeSkinSpeedButton;
    Tbforward: TSeSkinSpeedButton;
    Tbback: TSeSkinSpeedButton;
    OpenDialog1: TOpenDialog;
    urls: TIEAddress;
    ImageList3: TImageList;
    SeSkinSpeedButton8: TSeSkinSpeedButton;
    SeSkinSpeedButton9: TSeSkinSpeedButton;
    Splitter1: TSplitter;
    Panell: TSeSkinPanel;
    CoolBar3: TSeSkinPanel;
    SeSkinToolBar3: TSeSkinToolBar;
    ToolBar6: TSeSkinSpeedButton;
    Panel2: TSeSkinPanel;
    StatusBarmain: TStatusBar;
    Panelr: TSeSkinPanel;
    Nebweb: TNotebook;
    ApplicationEvents2: TApplicationEvents;
    ApplicationEvents1: TApplicationEvents;
    SeSkinMessage1: TSeSkinMessage;
    Timer1: TTimer;
    PMeutab: TSeSkinPopupMenu;
    pmeuforward: TSeSkinItem;
    pmeuback: TSeSkinItem;
    pmeurefresh: TSeSkinItem;
    pmeustop: TSeSkinItem;
    N28: TSeSkinItem;
    N2: TSeSkinItem;
    N1: TSeSkinItem;
    pmeuclose: TSeSkinItem;
    pmeucloseall: TSeSkinItem;
    CustomItem69: TSeSkinItem;
    meupro: TSeSkinItem;
    meuoffline: TSeSkinItem;
    meuexit: TSeSkinItem;
    meugoback: TSeSkinItem;
    meugander: TSeSkinItem;
    Tbcweb: TTabControl;
    Tbfav: TSeSkinSpeedButton;
    Tbhistory: TSeSkinSpeedButton;
    SeSkinPageControl1: TSeSkinPageControl;
    KsCustomTabSheet1: TKsCustomTabSheet;
    KsCustomTabSheet2: TKsCustomTabSheet;
    KsCustomTabSheet3: TKsCustomTabSheet;
    FavoritesListView1: TFavoritesListView;
    HistoryListView1: THistoryListView;
    ToolBar7: TSeSkinPanel;
    ToolButton30: TSeSkinSpeedButton;
    ToolButton32: TSeSkinSpeedButton;
    ToolButton31: TSeSkinSpeedButton;
    CoolBar6: TSeSkinPanel;
    ToolButton34: TSeSkinSpeedButton;
    leftwindow: TEmbeddedWB;
    Tbsearch: TSeSkinSpeedButton;
    CustomItem2: TSeSkinItem;
    CustomItem5: TSeSkinItem;
    function stob(sb: string): boolean;
    function GetFavoritesPath: string;
    function btos(sb: boolean): string;
    procedure Initpifu;
    procedure deletewb(i: integer);
    procedure deleteweb;
    procedure buildfanmenu;
    procedure WebbCommandStateChange(Sender: TObject;
      Command: Integer; Enable: WordBool);
    procedure webDocumentComplete(Sender: TObject;
      const pDisp: IDispatch; var URL: OleVariant);
    procedure newmenuClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure webNavigateComplete2(Sender: TObject;
      const pDisp: IDispatch; var URL: OleVariant);
    procedure CustomItem1Click(Sender: TObject);
    procedure CustomItem11Click(Sender: TObject);
    function ShortCaption(LongCaption: string; ShortLength: Integer): string;
    procedure ApplicationEvents2Message(var Msg: tagMSG;
      var Handled: Boolean);
    procedure ApplicationEvents1Message(var Msg: tagMSG;
      var Handled: Boolean);
    procedure urlsKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure addweb(urls: string);
    procedure wbNewWindow2(Sender: TObject; var ppDisp: IDispatch;
      var Cancel: WordBool);
    procedure WbBeforeNavigate2(Sender: TObject;
      const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
      Headers: OleVariant; var Cancel: WordBool);
    procedure urlsUrlSelected(Sender: TObject; Url: string);
    procedure SeSkinSpeedButton8Click(Sender: TObject);
    procedure addnewweb(urls: string);
    procedure TbcwebChange(Sender: TObject);
    function GetFavoritesUrl(FavoritesFile: string): string;
    procedure addfavoritesmenu(item: Tmenuitem; favoritespath: string);
    procedure TbcwebMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure WebStatusTextChange(Sender: TObject;
      const Text: WideString);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure TimTimer(Sender: TObject);
    procedure rebuildmenu;
    procedure pmeuforwardClick(Sender: TObject);
    procedure pmeubackClick(Sender: TObject);
    procedure pmeurefreshClick(Sender: TObject);
    procedure pmeustopClick(Sender: TObject);
     procedure addfavfun;
    procedure N2Click(Sender: TObject);
    procedure pmeucloseClick(Sender: TObject);
    procedure pmeucloseallClick(Sender: TObject);
    procedure TbfavClick(Sender: TObject);
    procedure TbhistoryClick(Sender: TObject);
    procedure TbsearchClick(Sender: TObject);
    procedure TbfullsenceeClick(Sender: TObject);
    procedure TbbackClick(Sender: TObject);
    procedure TbforwardClick(Sender: TObject);
    procedure tbstopClick(Sender: TObject);
    procedure tbrefreshClick(Sender: TObject);
    procedure TbhomeClick(Sender: TObject);
    procedure meuaddfavClick(Sender: TObject);
    procedure meuguofavClick(Sender: TObject);
    procedure guofavfun;
    procedure ToolButton30Click(Sender: TObject);
    procedure ToolButton32Click(Sender: TObject);
    procedure ToolButton31Click(Sender: TObject);
    procedure FavoritesListView1URLSelected(Sender: TObject; Url: String);
    procedure PanellResize(Sender: TObject);
    procedure ToolBar6Click(Sender: TObject);
    function leftwindowTranslateUrl(const dwTranslate: Cardinal;
      const pchURLIn: PWideChar; var ppchURLOut: PWideChar): HRESULT;
    procedure leftwindowNewWindow2(Sender: TObject; var ppDisp: IDispatch;
      var Cancel: WordBool);
    procedure HistoryListView1URLSelected(Sender: TObject; Url: String);
    procedure TbsendemailClick(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure TbziyuanClick(Sender: TObject);
    procedure meuinteropClick(Sender: TObject);
    procedure N18Click(Sender: TObject);
    procedure meuNetopClick(Sender: TObject);
    procedure CustomItem2Click(Sender: TObject);
    procedure CustomItem5Click(Sender: TObject);
  
  private
    wb, web: TEmbeddedWB;
    panel: Tpanel;
    pi, pk: pointer;
    dx, dy, lg: integer;
    s, wheight, wwidth, wtop, wleft, blankde, filtername: string;
    Favorites,tempurls: string;
    formfull: boolean;
    old, oldh, oldw, oldx, oldy, delindex: longint;
    backlist, forwardlist, weblist, filterlist: Tstringlist;
    closeapp, closeall, currentapp: boolean;
{ Private declarations }
  public
    histlist: Tstringlist;
    ctrlf, ctrlb, shiftf, shiftb: string;
{ Public declarations }
  end;

var
  mainForm: TmainForm;
   
implementation

uses fununit, askUnit, hakeunit, Unit5;

{$R *.dfm}

procedure Tmainform.addnewweb(urls: string);
begin
  if tbcweb.Tabs[tbcweb.TabIndex] = '空白页' then
    web.go(urls)
  else
    addweb(urls);
end;

procedure TmainForm.WbNewWindow2(Sender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool);
var I, oldindex: integer;
begin
  oldindex := Tbcweb.TabIndex;
  i := Tbcweb.Tabs.add('web');
  Nebweb.Pages.add('web');
  Pi := Nebweb.Pages.Objects[i];
  panel := TPanel.create(pi);
  panel.Align := alclient;
  panel.BevelOuter := bvNone;
  panel.parent := pi;
  pk := panel;
  wb := Tembeddedwb.Create(panel);
  panel.Insertcontrol(wb);
  wb.Align := alclient;
  ppDisp := Wb.ControlInterface;
  weblist.addobject('wb', wb);
  Tbcweb.TabIndex := oldindex;
  Nebweb.PageIndex := oldindex;
  backlist.Add('false');
  forwardlist.Add('false');
  wb.onBeforeNavigate2 := WbBeforeNavigate2;
  wb.UserInterfaceOptions := [DIALOG, OPENNEWWIN, FLAT_SCROLLBAR, URL_ENCODING_ENABLE_UTF8, ENABLE_FORMS_AUTOCOMPLETE, ENABLE_INPLACE_NAVIGATION, IME_ENABLE_RECONVERSION];



end;

procedure Tmainform.rebuildmenu;
 var
 i:integer;
begin
   for  i:=4 to meufav.Count-1 do
       begin
          Tmenuitem(meufav.Items[i]).clear;
       end;
   for i:=4 to meufav.Count-1 do
         meufav.Delete(4);
   buildfanmenu;
end;

procedure TmainForm.webDocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var I: integer;
begin
  try
    I := weblist.IndexOfObject(Tembeddedwb(sender));
    if Tembeddedwb(sender).LocationName <> '' then
     tbcweb.Tabs[i] := Tembeddedwb(sender).OleObject.document.title;
    tbback.Enabled := stob(backlist[I]);
    tbforward.Enabled := stob(forwardlist[I]);
  except
  end;

end;

procedure TmainForm.webNavigateComplete2(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant); //设置tab标题
var
  k: integer;
begin
  try

    k := weblist.IndexOfObject(Tembeddedwb(sender));
    if length(Tembeddedwb(sender).Locationname) > 30 then
      Tbcweb.tabs[k] := copy(Tembeddedwb(sender).Locationname, 1, 30)
    else
      Tbcweb.tabs[k] := Tembeddedwb(sender).Locationname;
  except
  end;
end;


procedure Tmainform.WbBeforeNavigate2(Sender: TObject;
  const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
var h, i: integer;
  flag: boolean;
begin
  flag := false;
  h := weblist.IndexOfObject(Tembeddedwb(sender));
  for i := 0 to filterlist.Count - 1 do
  begin
    if url = filterlist[i] then
    begin
      flag := true;
      break;
    end;
  end;
  if (flag = true) and (h > 0) then
  begin
    cancel := true;
    Tembeddedwb(sender).onBeforeNavigate2 := nil;
    delindex := h;
    Tbcweb.Tabs.Delete(h);
    Timer1.OnTimer := TimTimer;


  end
  else
  begin
    wb.onStatusTextChange := WebStatusTextChange;
    wb.onNewWindow2 := WbNewWindow2;
    wb.onNavigateComplete2 := webNavigateComplete2;
    wb.OnDocumentComplete := webDocumentComplete;
  end;
end;

procedure TmainForm.Initpifu;
var
  ftpinputfile: TextFile;
begin
  AssignFile(ftpinputfile, 'pifu.dat');
  reset(ftpinputfile);
  readln(ftpinputfile, pifufile);
  if trim(pifufile) = '' then pifufile := GetCurpath + 'Skins/WinXP.kskn';
  SeSkinEngine1.SkinFile := pifufile;
  closefile(ftpinputfile);
end;

procedure TmainForm.WebStatusTextChange(Sender: TObject;
  const Text: WideString);
begin
  StatusBarmain.Panels[0].Text := text;
end;

function TmainForm.GetFavoritesPath: string; //收藏夹菜单的实现
var
  pidl: PItemIDList;
  buf: array[0..MAX_PATH] of Char;
begin
  if Succeeded(ShGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pidl)) then
  begin
    ShGetPathfromIDList(pidl, buf);
    Result := buf;
  end
  else Result := '';
end;

function TmainForm.GetFavoritesUrl(FavoritesFile: string): string;
var
  ini: TiniFile;
begin
  result := '';
  ini := TIniFile.create(FavoritesFile);
  try
    result := ini.ReadString('InternetShortcut', 'URL', '');
  finally
    ini.free;
  end;
end;

procedure TmainForm.addfavoritesmenu(item: Tmenuitem; favoritespath: string);
var
  newmitem: Tmenuitem;
  favoritefilename: string;
  Search, src: TSearchRec;
  i, j: integer;
begin
//生成目录
  if findfirst(favoritespath + '\*.*', faArchive or faDirectory,
    search) = 0 then