bs1form.pas

功能全面的商业财会系统源码,清晰,很有参考价值.扩展性强.

  end;
  BS1Ini.Free;

  try
    session.netfiledir := strDatabaseName;   //Override path for BDE network control file.
    tblCompany.DatabaseName := strDatabaseName;
    tblCompany.Active := true;
  except
    //raise;
    Application.MessageBox(PChar('Database: ' + '''' + strDatabaseName + '''' + ' is not available.'), PChar(Application.Title), mb_OK + mb_DefButton1 + mb_IconStop);
    Application.Terminate;
    exit;
  end;

  UsersIni := TIniFile.Create(strDatabaseName + '\Users.ini');
  License := UsersIni.ReadString('General', 'License', '');
  RegisteredTo := UsersIni.ReadString('General', 'RegisteredTo', '');
  if License = ''            then MaxUsers := 1   //Demo version.
  else if License = 'b935k4' then MaxUsers := 1
  //else if License = 'a9tr24' then MaxUsers := 2
  else if License = 'c9kk42' then MaxUsers := 999
  //else if License = 'a3ab6y' then MaxUsers := 4
  //else if License = '285rer' then MaxUsers := 5
  //else if License = '298bb3' then MaxUsers := 6
  //else if License = 'k2w6tt' then MaxUsers := 7
  //else if License = '2h9gt5' then MaxUsers := 8
  //else if License = '9j5att' then MaxUsers := 9
  //else if License = 'f25xfs' then MaxUsers := 10
  else begin MaxUsers := 1; License := ''; end;   //Invalid license: set to demo version.
  CurrentUsers := UsersIni.ReadInteger('General', 'CurrentUsers', 0);
  if CurrentUsers <0 then CurrentUsers := 0;
  if CurrentUsers >0 then begin
    if ((CurrentUsers + 1) > MaxUsers) and (MaxUsers =1) then begin   //Reset count if can open table exclusively.
      try
        tblCompany.close;
        tblCompany.exclusive := true;
        tblCompany.open;
        CurrentUsers := 0;
        tblCompany.close;
        tblCompany.exclusive := false;
        tblCompany.open;
      except end;
    end;
    if ((CurrentUsers + 1) > MaxUsers) and (MaxUsers <10) then begin   //Don't bother checking if 10 or more licenses purchased.
      Application.MessageBox(PChar('Maximum number of users exceeded...' + #13 +
                                   'Your license allows ' + IntToStr(MaxUsers) + ' user(s) and there are already ' + IntToStr(CurrentUsers) + ' currently using this program.' + #13 + #13 +
                                   'If this information is incorrect you can fix it on ' + strDatabaseName + '\Users.ini'), PChar(Application.Title), mb_OK + mb_DefButton1 + mb_IconStop);
      Application.Terminate;
      exit;
    end;
  end;
  UsersIni.WriteInteger('General', 'CurrentUsers', CurrentUsers + 1);
  UsersIni.Free;

  FontFactor := PixelsPerInch/96;
  Left := 0;
  Top := 0;
  if mnuToolBar.checked = true then ClientHeight := panelToolbar.height else ClientHeight := 0;
  if mnuCompanyName.checked = true then ClientHeight := ClientHeight + Trunc(16*FontFactor);
  if mnuToolbar.checked = true then ClientWidth := Trunc(194*FontFactor)
  else if mnuCompanyName.checked = true then ClientWidth := Trunc(150*FontFactor)
  else ClientWidth := Trunc(118*FontFactor);

  SetToolBarButtons;
end;

procedure TfrmBS1.mnuToolbarClick(Sender: TObject);
var
  BS1ini: TIniFile;
begin
  if mnuToolbar.checked = false then begin
    mnuToolbar.checked := true;
    panelToolbar.visible := true;
  end else begin
    mnuToolbar.checked := false;
    panelToolbar.visible := false;
  end;
  BS1ini := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'BS1.ini');
  BS1ini.WriteBool('General', 'ViewToolbar', mnuToolbar.checked);
  BS1ini.Free;

  if mnuToolBar.checked = true then ClientHeight := panelToolbar.height else ClientHeight := 0;
  if mnuCompanyName.checked = true then ClientHeight := ClientHeight + Trunc(16*FontFactor);

  if mnuToolbar.checked = true then ClientWidth := Trunc(194*FontFactor)
  else if mnuCompanyName.checked = true then ClientWidth := Trunc(150*FontFactor)
  else ClientWidth := Trunc(118*FontFactor);
end;

procedure TfrmBS1.cboSystemClick(Sender: TObject);
var
  BS1ini: TIniFile;
begin
  SetToolBarButtons;
  BS1ini := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'BS1.ini');
  BS1ini.WriteString('General', 'System', cboSystem.text);
  BS1ini.Free;
end;

procedure TfrmBS1.mnuExitClick(Sender: TObject);
begin
  Close;
end;

procedure TfrmBS1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  UsersIni: TIniFile;
  CurrentUsers: integer;
  zFileName, zParams, zDir: array[0..79] of Char;
begin
  if mnuConfirmExit.checked = true then
    if MessageDlg('Close application?', mtConfirmation, [mbYes, mbNo], 0) = mrYes then Action := caFree
    else Action := caNone;

  if Action <> caNone then begin
    UsersIni := TIniFile.Create(strDatabaseName + '/Users.ini');
    CurrentUsers := UsersIni.ReadInteger('General', 'CurrentUsers', 0);
    if CurrentUsers <1 then CurrentUsers := 1;
    UsersIni.WriteInteger('General', 'CurrentUsers', CurrentUsers - 1);
    UsersIni.Free;
    if MessageDlg('Back up?' + '   (To ' + strDatabaseName + '\backup)', mtConfirmation, [mbYes, mbNo], 0) = mrYes then begin
      ShellExecute(Application.MainForm.Handle, nil,
      StrPCopy(zFileName, 'xcopy'),   {filename}
      StrPCopy(zParams, ' ' + strDatabaseName + '\*.* ' + strDatabaseName + '\backup\'),   {command line perameters}
      StrPCopy(zDir, ''),   {default directory}
      SW_HIDE);   {SW_SHOW Normal window.  or SW_SHOWMINIMIZED, SW_HIDE, etc}
    end;
  end;
end;

procedure TfrmBS1.mnuCompanyNameClick(Sender: TObject);
var
  BS1ini: TIniFile;
begin
  if mnuCompanyName.checked = false then begin
    mnuCompanyName.checked := true;
    panelCompanyName.visible := true;
  end else begin
    mnuCompanyName.checked := false;
    panelCompanyName.visible := false;
  end;
  BS1ini := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'BS1.ini');
  BS1ini.WriteBool('General', 'ViewCompanyName', mnuCompanyName.checked);
  BS1ini.Free;

  if mnuToolBar.checked = true then ClientHeight := panelToolbar.height else ClientHeight := 0;
  if mnuCompanyName.checked = true then ClientHeight := ClientHeight + Trunc(16*FontFactor);

  if mnuToolbar.checked = true then ClientWidth := Trunc(194*FontFactor)
  else if mnuCompanyName.checked = true then ClientWidth := Trunc(150*FontFactor)
  else ClientWidth := Trunc(118*FontFactor);
end;

procedure TfrmBS1.mnuVendorsClick(Sender: TObject);
var
  aComponent: TComponent;
begin
  screen.cursor := crHourglass;
  aComponent := Application.FindComponent('frmVendors');
  if Assigned (aComponent) then try frmVendors.qryVendor.close; frmVendors.qryVendor.open; except; end
  else frmVendors := TfrmVendors.Create(Application);

  aComponent := Application.FindComponent('frmVendorsFilter');
  if Assigned (aComponent) then try frmVendorsFilter.btnResetClick(sender); except; end;
  frmVendors.mnuFilter.Checked := false;
  frmVendors.qryVendor.Filtered := false;
  frmVendors.tblVendor.Filtered := false;
  
  if frmVendors.WindowState = wsMinimized then frmVendors.WindowState := wsNormal;
  if frmVendors.visible = true then frmVendors.FormShow(sender)
  else frmVendors.Show;
  screen.cursor := crDefault;
end;

procedure TfrmBS1.mnuCustomersClick(Sender: TObject);
var
  aComponent: TComponent;
begin
  screen.cursor := crHourglass;
  aComponent := Application.FindComponent('frmCustomers');
  if Assigned (aComponent) then try frmCustomers.qryCustomer.close; frmCustomers.qryCustomer.open; except; end
  else frmCustomers := TfrmCustomers.Create(Application);

  aComponent := Application.FindComponent('frmCustomersFilter');
  if Assigned (aComponent) then try frmCustomersFilter.btnResetClick(sender); except; end;
  frmCustomers.mnuFilter.Checked := false;
  frmCustomers.qryCustomer.Filtered := false;
  frmCustomers.tblCustomer.Filtered := false;

  if frmCustomers.WindowState = wsMinimized then frmCustomers.WindowState := wsNormal;
  if frmCustomers.visible = true then frmCustomers.FormShow(sender)
  else frmCustomers.Show;
  screen.cursor := crDefault;
end;

procedure TfrmBS1.mnuAccountsClick(Sender: TObject);
var
  aComponent: TComponent;
begin
  screen.cursor := crHourglass;
  aComponent := Application.FindComponent('frmGLAccounts');
  if not Assigned (aComponent) then frmGLAccounts := TfrmGLAccounts.Create(Application);

  aComponent := Application.FindComponent('frmGLAccountsFilter');
  if Assigned (aComponent) then try frmGLAccountsFilter.btnResetClick(sender); except; end;
  frmGLAccounts.mnuFilter.Checked := false;
  frmGLAccounts.qryGLAccnt.Filtered := false;
  frmGLAccounts.tblGLAccnt.Filtered := false;

  if frmGLAccounts.WindowState = wsMinimized then frmGLAccounts.WindowState := wsNormal;
  if frmGLAccounts.visible = true then frmGLAccounts.FormShow(sender)
  else frmGLAccounts.Show;
  screen.cursor := crDefault;
end;

procedure TfrmBS1.mnuAPInvoicesClick(Sender: TObject);
var
  aComponent: TComponent;
begin
  screen.cursor := crHourglass;
  aComponent := Application.FindComponent('frmAPInvoices');
  if Assigned (aComponent) then try frmAPInvoices.qryAPInv.close; frmAPInvoices.qryAPInv.open; except; end
  else frmAPInvoices := TfrmAPInvoices.Create(Application);

  aComponent := Application.FindComponent('frmAPInvoicesFilter');
  if Assigned (aComponent) then try frmAPInvoicesFilter.btnResetClick(sender); except; end;
  frmAPInvoices.mnuFilter.Checked := false;
  frmAPInvoices.qryAPInv.Filtered := false;

  {frmAPInvoices.Show;
  if frmAPInvoices.WindowState = wsMinimized then begin
    frmAPInvoices.WindowState := wsNormal;
    frmAPInvoices.FormShow(sender);
  end;}
  if frmAPInvoices.WindowState = wsMinimized then frmAPInvoices.WindowState := wsNormal;
  if frmAPInvoices.visible = true then frmAPInvoices.FormShow(sender)
  else frmAPInvoices.Show;
  screen.cursor := crDefault;
end;

procedure TfrmBS1.mnuYourCompanyClick(Sender: TObject);
var
  aComponent: TComponent;
begin
  screen.cursor := crHourglass;
  aComponent := Application.FindComponent('frmCompany');
  if not Assigned (aComponent) then frmCompany := TfrmCompany.Create(Application);
  if frmCompany.WindowState = wsMinimized then frmCompany.WindowState := wsNormal;
  if frmCompany.visible = true then frmCompany.FormShow(sender)
  else frmCompany.Show;
  screen.cursor := crDefault;
end;

procedure TfrmBS1.FormShow(Sender: TObject);
begin
  //if tblCompany.RecordCount = 0 then mnuYourCompanyClick(sender);
  if tblCompanyCompanyName.value = 'Sample Data' then begin
    screen.cursor := crHourglass;
    application.createform (TfrmWelcome,frmWelcome);
    screen.cursor := crDefault;
    frmWelcome.ShowModal;
  end;

  if tblCompany.RecordCount = 0 then begin
    screen.cursor := crHourglass;
    application.createform (TfrmGettingStarted,frmGettingStarted);
    screen.cursor := crDefault;
    frmGettingStarted.ShowModal;
  end;
end;

procedure TfrmBS1.mnuChequesClick(Sender: TObject);
var
  aComponent: TComponent;
begin
  screen.cursor := crHourglass;
  aComponent := Application.FindComponent('frmAPCheques');
  if Assigned (aComponent) then try frmAPCheques.qryAPCheq.close; frmAPCheques.qryAPCheq.open; except; end
  else frmAPCheques := TfrmAPCheques.Create(Application);

  aComponent := Application.FindComponent('frmAPChequesFilter');
  if Assigned (aComponent) then try frmAPChequesFilter.btnResetClick(sender); except; end;
  frmAPCheques.mnuFilter.Checked := false;
  frmAPCheques.qryAPCheq.Filtered := false;

  if frmAPCheques.WindowState = wsMinimized then frmAPCheques.WindowState := wsNormal;
  if frmAPCheques.visible = true then frmAPCheques.FormShow(sender)
  else frmAPCheques.Show;
  screen.cursor := crDefault;
end;

procedure TfrmBS1.mnuPaymentsClick(Sender: TObject);
var
  aComponent: TComponent;
begin
  screen.cursor := crHourglass;
  aComponent := Application.FindComponent('frmARPayments');
  if Assigned (aComponent) then try frmARPayments.qryARPmt.close; frmARPayments.qryARPmt.open; except; end
  else frmARPayments := TfrmARPayments.Create(Application);

  aComponent := Application.FindComponent('frmARPaymentsFilter');
  if Assigned (aComponent) then try frmARPaymentsFilter.btnResetClick(sender); except; end;
  frmARPayments.mnuFilter.Checked := false;
  frmARPayments.qryARPmt.Filtered := false;

  if frmARPayments.WindowState = wsMinimized then frmARPayments.WindowState := wsNormal;
  if frmARPayments.visible = true then frmARPayments.FormShow(sender)
  else frmARPayments.Show;
  screen.cursor := crDefault;
end;

procedure TfrmBS1.mnuBudgetClick(Sender: TObject);
var