unitmaintest.pas

评估系统

unit unitMainTest;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, DB, ADODB, DBCtrls, cxGraphics, cxControls,
  dxStatusBar, dxBar, dxBarExtDBItems, OleCtrls, SHDocVw,ComObj,
  dxBarExtItems, ExtCtrls;

type
  TfrmMain = class(TForm)
    dxBM: TdxBarManager;
    dxBarSubItem1: TdxBarSubItem;
    btnLogin: TdxBarButton;
    dxBarSubItem3: TdxBarSubItem;
    dxBarSubItem7: TdxBarSubItem;
    chkGov: TdxBarButton;
    chkTec: TdxBarButton;
    dxBarButton3: TdxBarButton;
    dxBarButton4: TdxBarButton;
    cmbCity: TdxBarLookupCombo;
    dxBarSubItem4: TdxBarSubItem;
    dxBarSubItem5: TdxBarSubItem;
    dxBarSubItem6: TdxBarSubItem;
    dxBarButton5: TdxBarButton;
    btnBE: TdxBarButton;
    wb: TWebBrowser;
    btnDBC: TdxBarButton;
    btnDBB: TdxBarButton;
    btnDBR: TdxBarButton;
    dxBarSubItem2: TdxBarSubItem;
    btnTool: TdxBarButton;
    btnData: TdxBarButton;
    btnAdd: TdxBarButton;
    btnDB: TdxBarButton;
    btnPerMan: TdxBarButton;
    btnUL: TdxBarButton;
    btnAddMan: TdxBarButton;
    btnDataBrow: TdxBarButton;
    dxPB: TdxBarProgressItem;
    dxTime: TdxBarEdit;
    timRec: TTimer;
    dxBE: TdxBarStatic;
    btnFor: TdxBarButton;
    btnBack: TdxBarButton;
    URLs: TdxBarCombo;
    btnRefresh: TdxBarButton;
    btnStop: TdxBarButton;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure cmbCityChange(Sender: TObject);
    procedure btnDBCClick(Sender: TObject);
    procedure btnDBBClick(Sender: TObject);
    procedure btnDBRClick(Sender: TObject);
    procedure btnToolClick(Sender: TObject);
    procedure dxBMBarVisibleChange(Sender: TdxBarManager; ABar: TdxBar);
    procedure btnLoginClick(Sender: TObject);
    procedure btnPerManClick(Sender: TObject);
    procedure btnDataBrowClick(Sender: TObject);
    procedure wbStatusTextChange(Sender: TObject; const Text: WideString);
    procedure wbProgressChange(Sender: TObject; Progress,
      ProgressMax: Integer);
    procedure FormResize(Sender: TObject);
    procedure timRecTimer(Sender: TObject);
    procedure dxTimeKeyPress(Sender: TObject; var Key: Char);
    procedure wbDocumentComplete(Sender: TObject; const pDisp: IDispatch;
      var URL: OleVariant);
    procedure wbBeforeNavigate2(Sender: TObject; const pDisp: IDispatch;
      var URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
      var Cancel: WordBool);
    procedure btnBackClick(Sender: TObject);
    procedure btnForClick(Sender: TObject);
    procedure URLsKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure wbDownloadBegin(Sender: TObject);
    procedure wbDownloadComplete(Sender: TObject);
    procedure btnStopClick(Sender: TObject);
    procedure btnRefreshClick(Sender: TObject);
    procedure URLsChange(Sender: TObject);
  private
    { Private declarations }
    evMemo: TList;
    userName:string;
    userID:integer;
    tR: integer;
    HistoryIndex: Integer;
    UpdateCombo :Boolean;
    HistoryList : TStringList;
    procedure FindAddress;
    procedure ReadMemo;
    procedure EnableWebBtn;
  public
    { Public declarations }
    level:integer;//用户级别
    FUpdateVisible : Boolean;
    procedure EnableControl(level: integer);
  end;

var
  frmMain: TfrmMain;

implementation

uses unitDM,unitEvlo,unitDataType,unitInput,unitLogin,unitSysMan,unitBrow;

{$R *.dfm}

procedure CompactAccess(dbName: string; JetId: string = '4.0');   //压缩
var
  AVariant: Variant;
begin
  if FileExists(dbName + '.tmp') then DeleteFile(DbName + '.tmp');
  AVariant := CreateOleObject('JRO.JetEngine');
  AVariant.CompactDataBase('Provider=Microsoft.Jet.OLEDB.' + JetId + ';Data Source=' + dbName ,
  'Provider=Microsoft.Jet.OLEDB.' + JetId + ';Data Source=' + dbName + '.tmp');
  DeleteFile(DbName);
  ReNameFile(dbName + '.tmp', DbName);
end;

procedure TfrmMain.FindAddress;
var
  Flags: OLEVariant;
begin
  Flags:=0;
  UpdateCombo:=True;
  wb.Navigate(WideString(URLs.Text),Flags,Flags,Flags,Flags); 
end;

procedure TfrmMain.EnableControl(level:integer);
begin
  case level of
   0://系统管理员
   begin
     btnUL.Enabled :=true;
     btnPerMan.Enabled := true;
     btnBE.Enabled:=true;
     dxBarButton3.Enabled:=true;
     btnAddMan.Enabled:=true;
     btnDBC.Enabled:=true;
     btnDBB.Enabled:=true;
     btnDBR.Enabled:=true;
     btnLogin.Enabled:=false;
   end;
   1://数据录入员
   begin
     btnUL.Enabled :=true;
     btnPerMan.Enabled := false;
     btnBE.Enabled:=false;
     dxBarButton3.Enabled:=true;
     btnAddMan.Enabled:=false;
     btnDBC.Enabled:=false;
     btnDBB.Enabled:=false;
     btnDBR.Enabled:=false;
     btnLogin.Enabled:=false;
   end;
   2://未登录人员
   begin
     btnUL.Enabled :=false;
     btnPerMan.Enabled := false;
     btnBE.Enabled:=false;
     dxBarButton3.Enabled:=false;
     btnAddMan.Enabled:=false;
     btnDBC.Enabled:=false;
     btnDBB.Enabled:=false;
     btnDBR.Enabled:=false;
     btnLogin.Enabled:=true;
   end;
  end;
end;

procedure TfrmMain.ReadMemo;
var
  FFieldName : array of string;
  MyRec: PDes;
  i,j: integer;
  atab: TADOTable;
begin
  atab:=TADOTable.Create(self);
  atab.Connection := DM.AC ;
  atab.TableName := 'e_GovernmentMemo';
  if not atab.Active then atab.Active:=true;
  i:= atab.FieldCount;
  setlength(FFieldName,i);
  for j:=0 to i-1 do
    FFieldName[j]:=atab.Fields[j].FieldName;
  atab.First;
  while not atab.Eof do
  begin
    new(MyRec);
    myRec^.FID  := Atab.Fields.FieldByName(FFieldName[0]).asinteger;
    myRec^.FPID := Atab.Fields.FieldByName(FFieldName[1]).asinteger;
    myrec^.FFID := Atab.Fields.FieldByName(FFieldName[2]).asstring;
    myrec^.FFNa := Atab.Fields.FieldByName(FFieldName[3]).asstring;
    myrec^.FVal := Atab.Fields.FieldByName(FFieldName[4]).asstring;
    myrec^.FFTa := Atab.Fields.FieldByName(FFieldName[5]).asstring;
    myrec^.FFEv := Atab.Fields.FieldByName(FFieldName[6]).asstring;
    myrec^.FFFt := Atab.Fields.FieldByName(FFieldName[7]).asboolean;
    myrec^.FFWe := Atab.Fields.FieldByName(FFieldName[8]).asfloat;
    myrec^.FFCo := Atab.Fields.FieldByName(FFieldName[9]).asstring;
    myrec^.FFDj := Atab.Fields.FieldByName(FFieldName[10]).asstring;
    evMemo.Add(myRec);
    atab.Next;
  end;
  atab.Free;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  evMemo:=TList.Create;
  HistoryList := TStringList.Create;
  ReadMemo;
  historyList.Add ('file://'+extractfilepath(Application.ExeName)+'index.html');
  wb.Navigate(historyList.Strings[0]);
  FUpdateVisible := True;
  enablecontrol(2);
end;

procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  HistoryList.Free;
  evMemo.Free;
end;

procedure TfrmMain.Button1Click(Sender: TObject);
begin
  CreEvMana(evMemo,'e_GovernmentMemo');
end;

procedure TfrmMain.Button2Click(Sender: TObject);
begin
  if cmbCity.KeyValue=null then
    messagebox(handle,'请首先选择要评估的网站！','提示 ',MB_OK)
  else
    CreInput(evMemo,'e_Government',cmbCity.KeyValue,cmbCity.Text,userName,userID);
end;

procedure TfrmMain.cmbCityChange(Sender: TObject);
var
  s:string;
begin
  tr:=0;
  timRec.Enabled := true;
  HistoryList.Clear;
  HistoryIndex:=-1;
//  historyList.Add ('file://'+extractfilepath(Application.ExeName)+'index.html');
//  historyList.Add (s);
  s:= Dm.atab0.Fields.FieldByName('webscience').AsString;
  URLs.Text :=s;
  UpdateCombo :=  true;
  wb.Navigate(s);
end;

procedure TfrmMain.btnDBCClick(Sender: TObject);
var
  dbname: string;
begin
  if DM.AC.Connected = true then DM.AC.Connected := false;
  sleep(500);
  dbname := ExtractFilePath(Application.ExeName)+'object.mdb';
  CompactAccess(dbname);
  MessageBox(handle,'数据库压缩成功！','提示',mb_IconInformation+mb_ok);
  if DM.AC.Connected = false then DM.AC.Connected:=true;
  if DM.atab0.Active = false then DM.atab0.Active := true;
end;

procedure TfrmMain.btnDBBClick(Sender: TObject);
var
  dbname: string;
begin
  if DM.AC.Connected = true then DM.AC.Connected := false;
  dbname := ExtractFilePath(Application.ExeName)+ 'object.bak';
  if FileExists(dbname) then DeleteFile(dbname);
  CopyFile(Pchar('object.mdb'), Pchar(dbname), true);
  MessageBox(handle, '数据库备份成功!', '提示', mb_IconInformation + mb_Ok);
  if dm.ac.Connected = false then dm.ac.Connected := true;
  if DM.atab0.Active = false then DM.atab0.Active := true;
end;

procedure TfrmMain.btnDBRClick(Sender: TObject);
var
  dbname, dbbname: string;
begin
  if MessageBox(self.Handle, '确认要还原数据么? ', '提示', mb_IconQuestion + mb_YesNo) = idYes then
  begin
    if dm.ac.Connected = true then dm.ac.Connected := false;
    dbname := ExtractFilePath(Application.ExeName)+ 'object.mdb';
    dbbname := ExtractFilePath(Application.ExeName)+ 'object.bak';
    if not FileExists(dbbname) then
      MessageBox(self.Handle, '没有备份数据,不能还原', '提示', mb_IconInformation + mb_Ok)
    else
    begin
      CopyFile(Pchar(dbbname), Pchar(dbname), true);
      MessageBox(handle, '数据库还原成功!', '提示', mb_IconInformation + mb_Ok);
    end;
    if dm.ac.Connected = false then dm.ac.Connected := true;
    if DM.atab0.Active = false then DM.atab0.Active := true;
  end;
end;

procedure TfrmMain.btnToolClick(Sender: TObject);
begin
  FUpdateVisible := False;
  dxBM.Bars[TdxBarButton(Sender).Tag].Visible := TdxBarButton(Sender).Down;
  FUpdateVisible := True;
end;

procedure TfrmMain.dxBMBarVisibleChange(Sender: TdxBarManager;
  ABar: TdxBar);
begin
   if FUpdateVisible and HandleAllocated then
    case ABar.Index of
      1: btnTool.Down := ABar.Visible;
      2: btnData.Down := ABar.Visible;
      3: btnAdd.Down := ABar.Visible;
      4: btnDB.Down := ABar.Visible;
    end;
end;

procedure TfrmMain.btnLoginClick(Sender: TObject);
var
  isAD: Boolean;
begin
  frmLoginCr(userName,userID,isAD);
  if userID=0 then
  begin
    level:=2;
    userName:='未登录';
  end
  else
    if isAD then
      level:=0
    else
      level:=1;
  Enablecontrol(level);
  if level<>2 then
    Caption:=frmCaption+'-'+userName+'(已登录)'
  else
    Caption:=frmCaption+'-'+userName;
end;

procedure TfrmMain.btnPerManClick(Sender: TObject);
begin
  frmCreate(0);
end;

procedure TfrmMain.btnDataBrowClick(Sender: TObject);
begin
  form2.show;
end;

procedure TfrmMain.wbStatusTextChange(Sender: TObject;
  const Text: WideString);
begin
  dxBE.Caption := Text;
end;

procedure TfrmMain.wbProgressChange(Sender: TObject; Progress,
  ProgressMax: Integer);
begin
  if ProgressMax= Progress then
  begin
    dxPB.Visible := ivNever;
  end
  else
  begin
    dxPB.Visible := ivAlways;
    dxPB.Max := ProgressMax;
    dxPB.Position := Progress;
  end;
end;

procedure TfrmMain.FormResize(Sender: TObject);
begin
  dxBE.Width := Width-300;
  URLs.Width := Width-300;
end;

procedure TfrmMain.timRecTimer(Sender: TObject);
begin
  tR:=tR+1;
  dxTime.Text := format('%d.%d s',[(tR div 10),(tr mod 10)]);
end;

procedure TfrmMain.dxTimeKeyPress(Sender: TObject; var Key: Char);
begin
  Key:=#0;
end;

procedure TfrmMain.wbDocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
  timRec.Enabled := false;
end;

procedure TfrmMain.wbBeforeNavigate2(Sender: TObject;
  const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
var
  newIndex: integer;
begin
  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;

  if UpdateCombo then
  begin
    UpdateCombo:=false;
    newIndex:=URLs.Items.IndexOf(URL); //定位

    if NewIndex=-1 then
      URLs.Items.Insert(0,URL)
      //URLs.Items.Add(URL)
    else
      URLs.Items.Move(newIndex,0);//改变位置
  end;

  URLs.Text := URL;

  EnableWebBtn;

end;

procedure TfrmMain.btnBackClick(Sender: TObject);
begin
  URLs.Text := HistoryList[HistoryIndex-1];
  FindAddress;
end;

procedure TfrmMain.btnForClick(Sender: TObject);
begin
  URLs.Text := HistoryList[HistoryIndex+1];
  FindAddress;
end;

procedure TfrmMain.URLsKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key=VK_Return then
    FindAddress;
end;

procedure TfrmMain.wbDownloadBegin(Sender: TObject);
begin
  btnStop.Enabled := true;
//  URLs.Items.Insert(0,wb.LocationURL);  
end;

procedure TfrmMain.wbDownloadComplete(Sender: TObject);
begin
  btnStop.Enabled := false;
end;

procedure TfrmMain.btnStopClick(Sender: TObject);
begin
  wb.Stop ;
end;

procedure TfrmMain.btnRefreshClick(Sender: TObject);
begin
  FindAddress;
end;

procedure TfrmMain.URLsChange(Sender: TObject);
begin
  //FindAddress;
end;

procedure TfrmMain.EnableWebBtn;
begin
  if HistoryList.Count > 0 then
  begin
    btnFor.Enabled := historyIndex < HistoryList.Count -1;
    btnBack.Enabled := HistoryIndex > 0;
  end
  else
  begin
    btnFor.Enabled := false;
    btnBack.Enabled := false;
  end;
end;

end.