frmmain.pas

超市管理系统

procedure Tfrm_main.User_selectsetupdepot(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'增加') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_depotgoods,Frm_main_depotgoods);
   Frm_main_depotgoods.Dock(panel_main,BoundsRect);
   Frm_main_depotgoods.show;
end;

procedure TFrm_main.Panel_mainUnDock(Sender: TObject; Client: TControl;
  NewTarget: TWinControl; var Allow: Boolean);
begin
   if newtarget<>sender then
      ALLOW:=FALSE
   else
      Allow:=true;
end;

procedure TFrm_main.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
var
   I_temp,I_windowscount:integer;
   I_savedays,I_count:integer;
   TragetPath,DFilePath:string;
   FromBuf: Array [0..255] of Char;
   OpStruc: TSHFileOpStruct;
begin
   //有打开的数据窗口，则警告
   if Panel_main.DockClientCount> 0 then
   begin
      if messagedlg(Infmsg0005+#13+#13+Askmsg0003,mtConfirmation,mbOKCancel,0)=mrOK then
      begin
         I_windowscount:=panel_main.DockClientCount;
         for I_temp:=0 to I_windowscount-1 do
         begin
            try
               (panel_main.DockClients[0] as Tform).Close ;
               application.ProcessMessages ;
               //窗口未被正常关闭，退出
               if I_windowscount - (I_temp +1)<panel_main.DockClientCount then
               begin
                   canclose:=false;
                   exit;
               end;
            except
               canclose:=false;
            end;
         end;
         //以下是环循关闭法，可能不适用
         {while Panel_main.DockClientCount > 0 do
         begin
            try
               (Panel_main.DockClients[0] as Tform).Close;
               canclose:=true;
               application.ProcessMessages ;
            except
               canclose:=false;
            end;
         end;}
      end
      else
      begin
         canclose:=false;
         exit;
      end;
   end;
   if messagedlg('确定要退出'+application.Title +'吗？',mtconfirmation,[mbyes,mbCancel],0)=mryes then
   begin
      if S_autosave='1' then      //系统自动备份
      begin
         self.Hide ;
         application.CreateForm(tfrm_prograss,frm_prograss);
         frm_prograss.P_message.Caption :='自动备份正在处理数据，请稍候……';
         frm_prograss.show;
         frm_prograss.Update ;
         Application.ProcessMessages ;
         application.CreateForm(Tfrm_backup,frm_backup);
         frm_backup.B_showmessage:=false;     //不显示提示信息
         try
            I_savedays:=strtoint(S_savedays);
         except
            I_savedays:=5;
         end;
         if (I_savedays<1) or (I_savedays>30) then I_savedays:=5;
         TragetPath:=ExtractFileDir(Application.ExeName);
         if (StrLen(PChar(TragetPath)) <> 3) then
            TragetPath:=TragetPath+'\';

         with OpStruc do
         begin
            Wnd:= Handle;
            wFunc:= FO_COPY;
            pFrom:= @FromBuf;
            pTo:= @FromBuf;
            fFlags:= FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
            fAnyOperationsAborted:= False;
            hNameMappings:= nil;
            lpszProgressTitle:= nil;
         end;
         for I_count:= I_savedays to 100 do
         begin
            DFilePath:= TragetPath+'BACKUPDATA\'+formatdatetime('yyyymmdd',date-I_count);
            if DirectoryExists(DFilePath) then
            begin
               try
                  FillChar( FromBuf, Sizeof(FromBuf), 0 );
                  StrPCopy( FromBuf, Pchar(DFilePath) );
                  OpStruc.wFunc := FO_DELETE;
                  StrPCopy( FromBuf, Pchar(DFilePath) );
                  ShFileOperation( OpStruc );
               except
                  showmessage('系统在备份数据过程中发生一个未知错误，但这并不影响新数据的备份'+chr(13)+chr(13)
                     +'如果这个问题不解决，下次系统自动备份数据时可能也出现类似信息');
               end;
            end;
         end;
         if not DirectoryExists(TragetPath+'BACKUPDATA') then
         try
            forcedirectories(TragetPath+'BACKUPDATA');
         except
            showmessage('系统自动份备在创建目录时发生未知错误！');
            frm_backup.Free ;
            canclose:=true;
            frm_prograss.Free ;
            exit;
         end;
         frm_backup.Edit_path.Text :=TragetPath+'BACKUPDATA\'+formatdatetime('yyyymmdd',date);
         frm_backup.OKBtnClick(sender) ;
         frm_prograss.Free ;
      end;
      canclose:=true;
   end
   else
      canclose:=false;
end;

procedure TFrm_main.Menu_data_daysellClick(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'增加') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_daysell,Frm_main_daysell);
   Frm_main_daysell.Dock(panel_main,BoundsRect);
   Frm_main_daysell.show;
end;

procedure TFrm_main.Menu_data_jhlrClick(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'增加') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_scjh,Frm_main_scjh);
   Frm_main_scjh.Dock(panel_main,BoundsRect);
   Frm_main_scjh.show;
end;

procedure TFrm_main.Menu_data_jhthClick(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'增加') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_scjhth,Frm_main_scjhth);
   Frm_main_scjhth.Dock(panel_main,BoundsRect);
   Frm_main_scjhth.show;
end;

procedure TFrm_main.Menu_tools_setupClick(Sender: TObject);
begin
   if Panel_main.DockClientCount> 0 then
   begin
      messagedlg(Infmsg0005,mtInformation,[mbok],0);
      exit;
   end;
   if not Checkrights(USERRIGHTS,'系统设置') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_setup,Frm_setup);
   Frm_setup.showmodal;
   frm_setup.Free;
end;

procedure TFrm_main.Menu_data_xsthClick(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'增加') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_scxsth,Frm_main_scxsth);
   Frm_main_scxsth.Dock(panel_main,BoundsRect);
   Frm_main_scxsth.show;
end;

procedure TFrm_main.Menu_data_depotjhClick(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'增加') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_depotjh,Frm_main_depotjh);
   Frm_main_depotjh.Dock(panel_main,BoundsRect);
   Frm_main_depotjh.show;
end;

procedure TFrm_main.Menu_data_depotthClick(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'增加') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_depotth,Frm_main_depotth);
   Frm_main_depotth.Dock(panel_main,BoundsRect);
   Frm_main_depotth.show;
end;

procedure TFrm_main.Menu_ywcx_ywyxstjClick(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'查看') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_query_ywyxstj,Frm_main_query_ywyxstj);
   Frm_main_query_ywyxstj.Dock(panel_main,BoundsRect);
   Frm_main_query_ywyxstj.show;
end;

procedure TFrm_main.Menu_ywcx_ywyxsmxClick(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'查看') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_query_ywyxsmx,Frm_main_query_ywyxsmx);
   Frm_main_query_ywyxsmx.Dock(panel_main,BoundsRect);
   Frm_main_query_ywyxsmx.show;
end;

procedure TFrm_main.Panel_mainMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
var
   I_temp:integer;
begin
   if Panel_main.DockClientCount > 0 then
   begin
      Panel_main.Color :=$00DDDDDD;
      for I_temp:=0 to Panel_main.DockClientCount -1 do
      begin
         if (Panel_main.DockClients[I_temp] as Tform).Showing then exit; 
      end;
      Panel_main.DockClients[0].Show ;
   end
   else
      Panel_main.Color :=clTeal;
end;

procedure TFrm_main.Panel_mainConstrainedResize(Sender: TObject;
  var MinWidth, MinHeight, MaxWidth, MaxHeight: Integer);
begin
   if Panel_main.DockClientCount > 0 then
      Panel_main.Color :=$00DDDDDD
   else
      Panel_main.Color :=clTeal;
end;

procedure TFrm_main.Menu_ywcx_scxstjClick(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'查看') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_query_scxstj,Frm_main_query_scxstj);
   Frm_main_query_scxstj.Dock(panel_main,BoundsRect);
   Frm_main_query_scxstj.show;
end;

procedure TFrm_main.Menu_ywcx_scxsmxClick(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'查看') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_query_scxsmx,Frm_main_query_scxsmx);
   Frm_main_query_scxsmx.Dock(panel_main,BoundsRect);
   Frm_main_query_scxsmx.show;
end;

procedure TFrm_main.Menu_ywcx_cpxstjClick(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'查看') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_query_spxstj,Frm_main_query_spxstj);
   Frm_main_query_spxstj.Dock(panel_main,BoundsRect);
   Frm_main_query_spxstj.show;
end;

procedure TFrm_main.Menu_ywcx_cpxsmxClick(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'查看') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_query_spxsmx,Frm_main_query_spxsmx);
   Frm_main_query_spxsmx.Dock(panel_main,BoundsRect);
   Frm_main_query_spxsmx.show;
end;

procedure TFrm_main.Timer_systemTimer(Sender: TObject);
begin
   StatusBar_main.Panels.Items[2].Text :='现在时间：'+DateTimeToStr(now);
   if statusbar_main.Panels.Items[0].Text ='' then
        statusbar_main.Panels.Items[0].Text:='准备好';
end;

procedure TFrm_main.Menu_ywcx_scjhtjClick(Sender: TObject);
begin
   if not Checkrights(USERRIGHTS,'查看') then
   begin
      messagedlg(Errormsg0006+'0007',mterror,[mbok],0);
      exit;
   end;
   application.CreateForm(TFrm_main_query_scjhtj,Frm_main_query_scjhtj);
   Frm_main_query_scjhtj.Dock(panel_main,BoundsRect);
   Frm_main_query_scjhtj.show;
end;

procedure TFrm_main.Menu_ywcx_scjhmxClick(Sender: TObject);