main.pas

大富翁离线浏览器源码

unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, DBCtrls, Db, DBTables, ExtCtrls, ComCtrls, Grids, DBGrids,
  ToolWin,  ImgList, Buttons,shellapi,
  jpeg, ADODB, SHDocVw, OleCtrls, activex, Menus;

type
  TfrmMain = class(TForm)
    sb1: TStatusBar;
    ImageList1: TImageList;
    ImageList2: TImageList;
    MainMenu: TMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    mnuToolbar: TMenuItem;
    mnuTree: TMenuItem;
    mnuList: TMenuItem;
    N8: TMenuItem;
    N9: TMenuItem;
    N10: TMenuItem;
    N11: TMenuItem;
    N12: TMenuItem;
    N13: TMenuItem;
    N14: TMenuItem;
    N15: TMenuItem;
    N16: TMenuItem;
    N17: TMenuItem;
    N18: TMenuItem;
    CoolBar1: TCoolBar;
    Panel4: TPanel;
    Label1: TLabel;
    cbbID: TComboBox;
    ToolBar1: TToolBar;
    btnSetDB: TToolButton;
    btnSave: TToolButton;
    btnPrint: TToolButton;
    ToolButton7: TToolButton;
    btnPrior: TToolButton;
    btnNext: TToolButton;
    btnSearch: TToolButton;
    ToolButton2: TToolButton;
    btnFullScreen: TToolButton;
    btnAbout: TToolButton;
    btnExit: TToolButton;
    palTree: TPanel;
    Panel6: TPanel;
    TV1: TTreeView;
    Splitter2: TSplitter;
    Panel5: TPanel;
    dbgMain: TDBGrid;
    Splitter1: TSplitter;
    PCContent: TPageControl;
    TSContent: TTabSheet;
    Panel3: TPanel;
    lblTitle: TLabel;
    TSInfo: TTabSheet;
    LVInfo: TListView;
    IE: TWebBrowser;
    mnuContent: TMenuItem;
    procedure dosql(SSql: string);
    procedure DoadoSql(CurADODS:TADODataSet;SSql: string);
    procedure ShowRecord(ID:integer);
    procedure LVInfoAdd(itemname,value:string);
    procedure btnexqClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure TV1Change(Sender: TObject; Node: TTreeNode);
    procedure btnSearchClick(Sender: TObject);
    procedure lbauthorClick(Sender: TObject);
    procedure Image1Click(Sender: TObject);
    procedure dbgMainCellClick(Column: TColumn);
    procedure btnExitClick(Sender: TObject);
    procedure btnSetDBClick(Sender: TObject);
    procedure Init;
    procedure btnPriorClick(Sender: TObject);
    procedure btnNextClick(Sender: TObject);
    procedure btnAboutClick(Sender: TObject);
    procedure cbbIDKeyPress(Sender: TObject; var Key: Char);
    procedure btnPrintClick(Sender: TObject);
    procedure btnSaveClick(Sender: TObject);
    procedure dbgMainDrawColumnCell(Sender: TObject; const Rect: TRect;
      DataCol: Integer; Column: TColumn; State: TGridDrawState);
    procedure mnuToolbarClick(Sender: TObject);
    procedure mnuTreeClick(Sender: TObject);
    procedure mnuListClick(Sender: TObject);
    procedure mnuContentClick(Sender: TObject);
    procedure btnFullScreenClick(Sender: TObject);
  private
   { Private declarations }
  public
    { Public declarations }
    strCurTitle:string;
    procedure SetColumn;
    procedure ShowHtml(Browser:TWebBrowser;content:string);
  end;

var
  frmMain: TfrmMain;


implementation

uses ComObj,mshtml, Search, dm, htmlGen;

{$R *.DFM}

procedure TfrmMain.dosql(SSql: string);
var
   oldcur:tcursor;
begin
     sb1.Panels[0].Text:='正在查询数据……';
     sb1.Refresh;
     oldcur:=Screen.Cursor;
     screen.cursor :=crHourGlass;
     try
{     with Query1 do
     begin
        if Active then close;
        sql.Text := SSql;
        open;
     end;                }
     finally
     screen.Cursor:=oldcur;
     end;
end;


procedure TfrmMain.btnexqClick(Sender: TObject);
var
   ssql:string;
begin
     ssql:='select * from letters where parent=0  and status=1 order by DateTime DESC';
     DoSql(ssql);
     sb1.Panels[2].Text:='讨论中问题';
end;

procedure TfrmMain.FormCreate(Sender: TObject);
var
    FileName:string;
    strConn:string;
    strlst:TStringList;
begin
       filename:=ExtractFilePath(paramstr(0))+'strconn.txt';

       if fileexists(filename) then
       begin
                strlst := TStringList.Create;
                strlst.LoadFromFile(FileName);
                strConn := strlst.Text;
                strlst.free;
       end
       else
                strConn := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=' + GetCurpath +'delphibbs.mdb;Persist Security Info=False';

       try
                DM1.InitDB(strConn);
       except
                ShowMessage('初始化数据库时出错！ ' + strConn);
       end;

       Init;
       btnAboutClick(self);
end;

procedure TfrmMain.TV1Change(Sender: TObject; Node: TTreeNode);
var
   ssql,roomid:string;
   oldcur:tcursor;
   Time:TDatetime;
begin
     if tv1.Selected =nil then exit;
     tv1.Refresh;
     sb1.Panels[1].Text:='';
     oldcur:=Screen.Cursor;
     screen.cursor :=crHourGlass;
     Time := now;
     sb1.Panels[0].Text := '正在查询数据……';

     DM1.GetRoomRecord(DM1.GetRoomID(TV1.Selected.Text));
     SetColumn;

//     这一行将极大地降低速度
     sb1.Panels[1].Text:= '记录数：' + inttostr(DM1.GetQuesCount) ;

     sb1.Refresh;

     sb1.Panels[3].Text:='查找耗时：' + formatdatetime('hh:nn:ss:zz',now-time);
     sb1.Panels[2].Text:='类别：' + TV1.Selected.Text;
     sb1.Panels[0].Text:='完成';
     screen.cursor :=oldcur;
end;

procedure TfrmMain.btnSearchClick(Sender: TObject);
var
   ssql,ssqlRe,TargetStr:string;
   oldcur:tcursor;
   Time:Tdatetime;
begin
     ssqlRe := '';
     with TfrmSearch.Create(self) do
     begin
          ShowModal;
          if Return = true then
          begin
               ssqlRe := SearchStr;
               TargetStr := Target;
          end;
          free;
     end;

     if ssqlRe = '' then  exit;

//     去掉这个注释将显示查询的sql字符串
//     ShowMessage(ssqlRe);

     time:=now;
     sb1.Panels[0].Text:='正在查询数据……';
     sb1.Panels[1].Text:='';
     sb1.Panels[2].Text:= TargetStr;
     sb1.Panels[3].Text:='';
     sb1.Refresh;
     oldcur:=Screen.Cursor;
     screen.cursor :=crHourGlass;

     ssql := ssqlRe ;

     DM1.Search(ssql);

     SetColumn;
     sb1.Panels[1].Text:='共'+ inttostr(DM1.GetQuesCount) + '条记录';
     sb1.Refresh;
     screen.Cursor:=oldcur;
     sb1.Panels[0].Text:='完成';
     sb1.Panels[3].Text:='查找耗时：' + formatdatetime('hh:nn:ss:zz',now-time);
end;

procedure TfrmMain.lbauthorClick(Sender: TObject);
begin
       apiexec('mailto:[e-mail]',SW_SHOWDEFAULT);
end;

procedure TfrmMain.Image1Click(Sender: TObject);
begin
     apiexec('http://onekey.yeah.net',SW_SHOWDEFAULT);
end;

procedure TfrmMain.ShowRecord(ID: integer);
var
   oldcur:tcursor;
   i:integer;
   QuesInfo:TQuerInfo;
begin
     oldcur := Screen.Cursor;
     screen.cursor :=crHourGlass;

     DM1.GetQuesContent(ID,QuesInfo);

     sb1.Panels[0].Text:='正在更新视图……';

     ShowHtml(IE,QuesInfo.Content);

     with QuesInfo do
     begin
         lblTitle.Caption:= '来自' + Userfrom + '：' + Title;

         LVInfo.Items.Clear;
         LVInfoAdd('标题',Title);
         LVInfoAdd('编号',ID);
         LVInfoAdd('提问者',Userfrom);
         LVInfoAdd('提问时间',RegTime);
         LVInfoAdd('最后回复时间',Time);
         LVInfoAdd('分数',Points);
         LVInfoAdd('状态',Status);
         LVInfoAdd('所属类别',RoomName);
        
         LVInfoAdd('阅读次数',GetTimes);
         LVInfoAdd('回复次数',ReplyTimes);

     end;

     PCContent.ActivePageIndex := 0;
     frmMain.FocusControl(IE);
     screen.Cursor:=oldcur;
     sb1.Panels[0].Text:='完成';
end;

procedure TfrmMain.dbgMainCellClick(Column: TColumn);
var
        RecordID:integer;
begin
//        try
        RecordID := dbgMain.DataSource.DataSet.Fieldbyname('ID').AsInteger;
        ShowRecord(RecordID);
{        Except
                ShowMessage('显示问题出错。');
        end;}
end;

procedure TfrmMain.btnExitClick(Sender: TObject);
begin
        Close;
end;

procedure TfrmMain.btnSetDBClick(Sender: TObject);
begin
{        if OpenDialog1.Execute then
        begin
                InitDB(OpenDialog1.FileName);
        end
        else
                Application.Terminate;
}
        if DM1.SetConnnection then
        begin
                Init;
        end;
end;

procedure TfrmMain.Init;
var
   TN1,TN2:TTreeNode;
   i:integer;
begin
       TV1.Items.Clear;
       tn1:=tv1.Items.Add(nil,'全部类别');
       tn1.ImageIndex:=1;

       with dm1 do
       begin
           for i := 0 to sltRooms.count - 1 do
           begin
             tn2:=tv1.Items.AddChild(tn1,sltRooms.Names[i]);
             tn2.ImageIndex:=1;
           end;
       end;

       tv1.FullExpand;
end;

procedure TfrmMain.btnPriorClick(Sender: TObject);
begin
        with dbgMain.DataSource.DataSet do
        begin
                if Active then
                begin
                        Prior;
                        ShowRecord(Fieldbyname('ID').AsInteger);
                end;
        end;

end;

procedure TfrmMain.btnNextClick(Sender: TObject);
begin
        with dbgMain.DataSource.DataSet do
        begin
                if Active then
                begin
                        Next;
                        ShowRecord(Fieldbyname('ID').AsInteger);
                end;
        end;

end;

procedure TfrmMain.btnAboutClick(Sender: TObject);
begin
       lblTitle.Caption := 'Rich Explorer简介';
       LVInfo.Items.Clear;
       IE.OleObject.navigate(ExtractFilePath(Application.ExeName) + 'readme.htm');

end;

procedure TfrmMain.cbbIDKeyPress(Sender: TObject; var Key: Char);
begin
     if (Key <> #13) or (cbbID.Text = '') then exit;
        cbbID.Items.Add(cbbID.Text);
        if cbbID.Items.Count > 20 then cbbID.Items.Delete(0);
     try
        ShowRecord(strtoint(cbbID.Text));
        Key := #0;
     except
        messagebox(Handle,'请填入正确的ID号！' ,'提醒',mb_ok or MB_ICONWARNING);
     end;


end;

procedure TfrmMain.LVInfoAdd(itemname, value: string);
var
        ListItem:TListItem;
begin
     with LVInfo do
     begin
        ListItem := Items.Add;
        ListItem.ImageIndex := 2;
        ListItem.Caption := itemname;
        ListItem.SubItems.Add(value);
     end;

end;

procedure TfrmMain.btnPrintClick(Sender: TObject);
begin
        try
//        IE.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT, EmptyParam,EmptyParam);
        IE.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER, EmptyParam,EmptyParam);
        except
        end;

end;


procedure TfrmMain.DoAdoSql(CurADODS: TADODataSet; SSql: string);
var
   oldcur:tcursor;
begin
     sb1.Panels[0].Text:='正在查询数据……';
     sb1.Refresh;
     oldcur:=Screen.Cursor;
     screen.cursor :=crHourGlass;
     try
        if CurADODS.Active = true then CurADODS.Close;
        CurADODS.CommandText := SSql;
        CurADODS.Open;
     finally
     screen.Cursor:=oldcur;
     end;
end;

procedure TfrmMain.btnSaveClick(Sender: TObject);
begin
        try
        IE.ExecWB(OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT, EmptyParam, EmptyParam);
        Except
        end;

end;

procedure TfrmMain.dbgMainDrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
        str:string;
        TheRect:TRect;
begin
if dbgMain.DataSource.DataSet.Active then
 begin
 if DataCol = 6 then
  begin
   Case Column.Field.AsInteger of
    0: Str:= '待答';
    1: Str:= '讨论中';
    2: Str:= '已答';
    else Str := '其它';
   end;
   TheRect := Rect;
   DrawText(dbgMain.Canvas.Handle,pChar(Str),Length(Str),TheRect,DT_VCENTER or DT_RIGHT or DT_SINGLELINE);
  end;
 end;
end;

procedure TfrmMain.SetColumn;
begin
        with dbgMain.DataSource.DataSet do
        begin
                Fields[0].DisplayLabel := '序号';
                Fields[1].DisplayLabel := '标题';
                Fields[2].DisplayLabel := '来自';
                Fields[3].DisplayLabel := '分数';
                Fields[4].DisplayLabel := '发表时间';
                Fields[5].DisplayLabel := '回复次数';
                Fields[6].DisplayLabel := '状态';
        end;
        with dbgMain do
        begin
                Columns[0].Width := 60;
                Columns[1].Width := 400;
                Columns[2].Width := 80;
                Columns[3].Width := 40;
                Columns[4].Width := 70;
                Columns[5].Width := 50;
        end;


end;

procedure TfrmMain.ShowHtml(Browser:TWebBrowser;content: string);
var
    vv: Variant;
    HTMLDocument: IHTMLDocument2;
begin
        vv := VarArrayCreate([0,0],varVariant);
        vv[0] := content;
        HTMLDocument := browser.Document as IHTMLDocument2;
        HTMLDocument.write(PSafeArray(TVarData(vv).VArray));
        HTMLDocument.charset := 'gb2312';
        HTMLDocument.close;

end;

procedure TfrmMain.mnuToolbarClick(Sender: TObject);
begin
        mnuToolbar.Checked := not mnuToolbar.Checked;
        CoolBar1.Visible := mnuToolbar.Checked;
end;

procedure TfrmMain.mnuTreeClick(Sender: TObject);
begin
        mnuTree.Checked := not mnuTree.Checked;
        palTree.Visible := mnuTree.Checked;
end;

procedure TfrmMain.mnuListClick(Sender: TObject);
begin
        mnuList.Checked := not mnuList.Checked;
        dbgMain.Visible := mnuList.Checked;
end;

procedure TfrmMain.mnuContentClick(Sender: TObject);
begin
        mnuContent.Checked := not mnuContent.Checked;
        PCContent.Visible := mnuContent.Checked;
end;

procedure TfrmMain.btnFullScreenClick(Sender: TObject);
begin
        mnuTreeClick(self);
        mnuListClick(self);
end;

initialization
  OleInitialize(nil);

finalization
  OleUninitialize;

end.