main.pas

一个详细功能齐全的档案管理信息系统 跟大家分享一下。这是老师给的光盘里带的

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, DB, ADODB, DBTables, StdCtrls, Mask, DBCtrls, Grids, DBGrids,Registry,
  ExtCtrls, ComCtrls, Buttons, ToolWin, ActnList, ImgList, Menus,shellapi,IniFiles,
  StdActns, AppEvnts;
type TUser=record
        Index:integer;
        Name:string[20];
        Passwd:string[20];
     end;

type
  TfMain = class(TForm)
    ImageList: TImageList;
    ActManage: TActionList;
    ActuserManage: TAction;
    ActDaType: TAction;
    ActOpen: TAction;
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    N8: TMenuItem;
    ActLinkSet: TAction;
    ActChangePwd: TAction;
    ActChangeZH: TAction;
    ActExit: TAction;
    Timer1: TTimer;
    ApplicationEvents1: TApplicationEvents;
    W: TMenuItem;
    Actions: TActionList;
    ActReLogin: TAction;
    Action1: TAction;
    ActOpenControlPanel: TAction;
    ActWindowArrange: TWindowArrange;
    ActWindowCascade: TWindowCascade;
    ActWindowTileHorizontal: TWindowTileHorizontal;
    ActWindowTileVertical: TWindowTileVertical;
    ActWindowClose: TWindowClose;
    ActWindowMinimizeAll: TWindowMinimizeAll;
    M1: TMenuItem;
    C1: TMenuItem;
    A1: TMenuItem;
    T1: TMenuItem;
    ileVertically1: TMenuItem;
    N10: TMenuItem;
    C2: TMenuItem;
    ActDmanage: TAction;
    N9: TMenuItem;
    N11: TMenuItem;
    N12: TMenuItem;
    Actunit: TAction;
    ActQuery: TAction;
    N14: TMenuItem;
    ActOut: TAction;
    N15: TMenuItem;
    ActIn: TAction;
    N16: TMenuItem;
    ActPlaceAdd: TAction;
    Action21: TMenuItem;
    Label1: TLabel;
    N17: TMenuItem;
    Nowstatus: TStatusBar;
    procedure FormCreate(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure DBOrderGrid1TitleClick(Column: TColumn);
    procedure ActDaTypeExecute(Sender: TObject);
    procedure ActChangePwdExecute(Sender: TObject);
    procedure ActChangeZHExecute(Sender: TObject);
    procedure ActLinkSetExecute(Sender: TObject);
    procedure ActExitExecute(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure ActuserManageExecute(Sender: TObject);
    procedure ActunitExecute(Sender: TObject);
    procedure ActQueryExecute(Sender: TObject);
    procedure ActOutExecute(Sender: TObject);
    procedure ActInExecute(Sender: TObject);
    procedure ActDmanageExecute(Sender: TObject);
    procedure ActPlaceAddExecute(Sender: TObject);
  protected
  private
    { Private declarations }
    NameAndPwd:TUser;
    function  GetUserPwd(var aUserpwd:Tuser):boolean;
    procedure SetUserPwd(aUserpwd:Tuser);
    procedure ChangePwd(var aUser,aNewpassword :string);
    procedure ChangeZh(var aNewUser,aOldUser :string);
    procedure SetCurrentUser(aUserCount:string);
    function GetLastuser:string;
    function CheckUser(var username,password :string):boolean;
    function GetQuanx(var user:string) :string;
  private
    procedure CloseWindows;
  public
    { Public declarations }
  end;
const
        LabelPwd='Pwd';
        LabelReg='software\IDMS\1.0';
        Currentuser='Currentuser';
        LabelConnectStr='ConnectionString';
        LabelConnectReg='software\IDMS\1.0';
        rsPlaceSetConnectionString= '请将数据库连接参数设置好!!';
var
  fMain: TfMain;
  nowuser :string;
implementation

uses pwd, cover, ChangePwd,ChangeZH,dm,basedata,ItemData_GZ,SelectForm,quyupz,
  CarKind, Factype, GBset, Carinfo;

{$R *.dfm}

procedure TfMain.FormCreate(Sender: TObject);
var
  EndDate,StartDate:string;
  aUserName,aPassword,Quanx,Actname:string;
  i,j:integer;

begin
  inherited;
  //fcover:=nil;
  //fcover:=Tfcover.Create(fcover);
  //fcover.show;
  StartDate:=FormatDateTime('yyyy-MM-dd',Date);
  EndDate:=FormatDateTime('yyyy-MM-dd',Date);
  try
        fdm.canuser.Active:=true;
  except
        //fcover.Close;
        if MessageDlg('数据库连接错！'#13'请重新设置。',mtCustom, [mbYes,mbNo], 0)=mrYes then
        begin
         SetConnectStr(PromptDataSource(Handle, GetConnectStr));
         Application.Terminate;
        end else
        begin
           Application.Terminate;
           Exit;
        end;
  end;
  //fcover.Close;
  for i:=0 to 2 do
  begin
        fpwd:=nil;
        fpwd:=Tfpwd.Create(fpwd);
        if fpwd.InputUserPassword(aUserName, aPassword) then
        begin
          if not checkuser(aUserName,aPassword) then
            begin
              MessageDlg('帐号不存在或密码错误！'#13'注意帐号和密码都分大小写',mtInformation, [mbYes], 0);
              if i<2 then continue;
                application.Terminate;
                exit;
              end else
              begin
              if aUsername<>GetLastuser then
               SetCurrentUser(aUsername);  //写在用客户账号（方便下次登录）
               {if uppercase(aUserName)<>'ADMIN' then
               begin
                 Quanx:=getquanx(aUserName);
                 for j:=0 to ActManage.ActionCount-1 do
                   begin
                     Actname:=ActManage.Actions[j].Name;
                     if pos(Actname,Quanx)=0 then
                     begin
                       with ActManage.Actions[j] as TcustomAction do
                       begin
                         visible:=false;
                       end;
                     end;
                   end;
               end;  }
               break;
              end;
        end else
        begin
                Application.Terminate;
                exit;
        end;
  end;
  nowstatus.Panels[0].Text:='当前用户:'+aUserName;
  nowstatus.Panels[1].Text:='登录时间:'+Formatdatetime('yyyy-mm-dd hh:nn:ss',now());
end;

function TfMain.GetQuanx(var user:string) :string;
begin
  with fdm.Canuser do
  begin
    close;
    Sql.Clear;
    Sql.Add('select * from logouser where usercount like '''+user+''' ');
    open;
    Result:= FieldByname('quanxian').AsString;
  end;
end;
function TfMain.CheckUser(var username,password :string):boolean;
begin
result:=false;
  with fdm.Canuser do
  begin
    close;
    sql.Clear;
    sql.Add('select * from UsersInfo where Username like '''+username+''' and Password like '''+password+''' ');
    open;
  end;
  result:=fdm.Canuser.RecordCount>0;
  if result then
  nowuser:=username;
end;
function TfMain.GetUserPwd(var aUserpwd:Tuser):boolean;
var
  Reg: TRegistry;
begin
  Result:=True;
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.OpenKey(LabelReg, True) then
    begin
      if Not Reg.ValueExists(LabelPwd) then
      begin
        Result:=False;
        Exit;
      end;
      if Reg.ReadBinaryData(LabelPwd,aUserpwd,sizeof(Tuser))<>sizeof(Tuser) then
      Result:=False;
    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;

end;
procedure TfMain.SetCurrentUser(aUserCount:string);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  Try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.OpenKey(LabelReg, True) then
    begin
      Reg.WriteString(Currentuser,aUserCount);
    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;
function TfMain.GetLastuser:string;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  Try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.OpenKey(LabelReg, True) then
    begin
      if Not Reg.ValueExists(Currentuser) then
        Result:=''
      else
        Result:=Reg.ReadString(Currentuser);
    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;
procedure TfMain.SetUserPwd(aUserpwd:Tuser);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.OpenKey(LabelReg, True) then
    begin
      if Not Reg.ValueExists(LabelPwd) then
      Reg.WriteBinaryData(LabelPwd,aUserpwd,sizeof(aUserpwd));
    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;
end;

procedure TfMain.ChangeZh(var aNewUser,aOldUser :string);
var
Sqlstr :string;
begin
  Sqlstr :=Format('update UsersInfo set usercount=''%s'' where usercount like ''%s'' ',[aNewUser,aOldUser]);
  Execsql(Sqlstr);
  Showmessage('修改成功！请牢记！');
end;
procedure TfMain.ChangePwd(var aUser,aNewpassword :string);
var
Sqlstr :string;
begin
  Sqlstr :=Format('update UsersInfo set password=''%s'' where usercount like ''%s'' ',[aNewpassword,aUser]);
  Execsql(Sqlstr);
  Showmessage('修改成功！请牢记！');
end;

procedure TfMain.N3Click(Sender: TObject);
begin
ShellAbout (    handle,
                '2002版2.1',
                'D&C Corp.',
                application.Icon.Handle
                );
end;

procedure TfMain.DBOrderGrid1TitleClick(Column: TColumn);
begin
     fdm.AdoBase.Sort:=Column.FieldName;
end;

procedure TfMain.ActDaTypeExecute(Sender: TObject);
var
  s:string;
begin
  fquyu := nil;
  fquyu := Tfquyu.Create(fquyu);
  fquyu.Show;
end;

procedure TfMain.ActChangePwdExecute(Sender: TObject);
var
  aOldPwd,aNewPwd:string;
begin
  fChangePwd:=nil;
  fChangePwd:=TfChangePwd.Create(fChangePwd);
  if fChangePwd.InputNewPwd(aOldPwd, aNewPwd) then
  begin
      if not checkuser(nowuser,aOldPwd) then
      begin
          MessageDlg('旧密码不符，请重新操作，输入正确的旧密码',mtCustom, [mbYes], 0);
          exit;
      end else
      begin
        changepwd(nowuser,aNewPwd);
      end;
  end;
end;

procedure TfMain.ActChangeZHExecute(Sender: TObject);
var
  aOldZh,aOldPwd,aNewZh:string;
begin
  fChangeZh:=nil;
  fChangeZh:=TfChangeZh.Create(fChangeZh);
  if fChangeZh.InputNewZh(aOldZh,aOldPwd,aNewZh) then
  begin
      if not checkuser(aOldZh,aOldPwd) then
      begin
          MessageDlg('旧密码不符，请重新操作，输入正确的旧密码',mtCustom, [mbYes], 0);
          exit;
      end else
      begin
        if uppercase(aOldZh)<>'ADMIN' then
          changeZh(aNewZh,aOldZh)
        else
          showmessage('超级用户不能更改账户');
      end;
  end;
end;

procedure TfMain.ActLinkSetExecute(Sender: TObject);
begin
  SetConnectStr(PromptDataSource(Handle, GetConnectStr));
  //ActRelog.Execute;
end;

procedure TfMain.ActExitExecute(Sender: TObject);
begin
  Application.Terminate;
end;

procedure TfMain.CloseWindows;
var i: Integer;
begin
  Try
    i := 0;
    While MDIChildCount >1 do
    begin
      if not (MDIChildren[i] is TfBaseData) then
        i:= 0
      else
        i:= 1;

      MDIChildren[i].Close;
      MDIChildren[i].Free;
    end;

    if MDIChildCount = 1 then
      if MDIChildren[0] is TfBaseData then
      begin
        MDIChildren[0].Close;
        MDIChildren[0].Free;
      end;
  Except

  end;
end;
procedure TfMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  CloseWindows;
end;

procedure TfMain.ActuserManageExecute(Sender: TObject);
begin
  fItemdata_GZ:=nil;
  fItemdata_GZ:=TfItemdata_GZ.Create(fItemdata_GZ);
  fItemdata_GZ.Show;
end;

procedure TfMain.ActunitExecute(Sender: TObject);
begin
  funit := nil;
  funit := Tfunit.Create(funit);
  funit.Show;
end;

procedure TfMain.ActQueryExecute(Sender: TObject);
begin
  fCarKind := nil;
  fCarKind := TfCarKind.Create(fCarKind);
  fCarKind.Show;
end;

procedure TfMain.ActOutExecute(Sender: TObject);
begin
  fFactype := nil;
  fFactype := TfFactype.Create(fFactype);
  fFactype.Show;
end;

procedure TfMain.ActInExecute(Sender: TObject);
begin
  fBaseData := nil;
  fBaseData := TfBaseData.Create(fBaseData);
  fBaseData.Show;
end;

procedure TfMain.ActDmanageExecute(Sender: TObject);
begin
  fGBset := nil;
  fGBset := TfGBset.Create(fGBset);
  fGBset.Show;
end;

procedure TfMain.ActPlaceAddExecute(Sender: TObject);
begin
  funit := nil;
  funit := Tfunit.Create(funit);
  funit.Show;
end;

end.