vendorform.pas

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

procedure TfrmVendor.btnOKClick(Sender: TObject);
begin
  if tblVendor.State in [dsInsert, dsEdit] then
    try tblVendor.post; DbiSaveChanges(tblVendor.handle);
    except
      on E: EDBEngineError do
        if E.Errors[E.ErrorCount - 1].ErrorCode = 9729 then begin   //Key violation (key already exists).
          with editVendorNo do begin Show; SetFocus; end;
          raise(exception.create('Vendor no. already exists'));
        end else raise;
    end;
  Close;
end;

procedure TfrmVendor.btnCancelClick(Sender: TObject);
begin
  tblVendor.DisableControls;
  if tblVendor.State in [dsInsert, dsEdit] then tblVendor.cancel;
  Close;
end;

procedure TfrmVendor.popWordWrapClick(Sender: TObject);
begin
  if popWordWrap.checked = true then begin
    popWordWrap.checked := false;
    memoNotes.WordWrap := false;
    memoNotes.ScrollBars := ssBoth;
  end else begin
    popWordWrap.checked := true;
    memoNotes.WordWrap := true;
    memoNotes.ScrollBars := ssVertical;
  end;
end;

procedure TfrmVendor.btnPhoneClick(Sender: TObject);
begin
  with frmDialer do begin
    NameToDial := tblVendorVendorName.value;
    NumberToDial := tblVendorPhone.value;
    ShowModal;
  end;
end;

procedure TfrmVendor.cboCurrencyKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if key = VK_Delete then begin
    tblVendor.Edit;
    tblVendorCurrencyID.AsVariant := null;
  end;
end;

procedure TfrmVendor.tblVendorAfterPost(DataSet: TDataSet);
begin
  frmVendors_cboFind_RequeryRequired := true;
  frmAPInvoices_cboFindVendor_RequeryRequired := true;
  try   //Refresh, etc.
    with frmVendors.qryVendor do begin close; open; end;
    frmVendors.qryVendor.Locate('VendorID', tblVendorVendorID.value, []);
  except; end;
end;

procedure TfrmVendor.tblVendorBeforePost(DataSet: TDataSet);
begin
  //if tblAddressLastName.AsString = '' then begin   //Occurs after table rule validation.
    //editLastName.SetFocus;
    //raise(exception.create('Last Name must be entered'));
  //end;

  dmLookUps.tblCurrency.Active := true;
  if dmLookUps.tblCurrency.Locate('CurrencyID', tblVendorCurrencyID.value, []) <> true then begin
    with cboCurrency do begin Show; SetFocus; end;
    raise(exception.create('Currency no longer exists'));   //Deleted by another user since this user selected.
  end;
end;

procedure TfrmVendor.btnCurrencyClick(Sender: TObject);
var
  aComponent: TComponent;
begin
  screen.cursor := crHourglass;
  aComponent := Application.FindComponent('frmCurrencies');
  if not Assigned (aComponent) then frmCurrencies := TfrmCurrencies.Create(Application);
  if frmCurrencies.WindowState = wsMinimized then frmCurrencies.WindowState := wsNormal;
  if frmCurrencies.visible = true then frmCurrencies.FormShow(sender)
  else frmCurrencies.Show;
  if not frmCurrencies.tblCurrency.Locate('CurrencyID', tblVendorCurrencyID.value, []) then frmCurrencies.tblCurrency.First;
  screen.cursor := crDefault;
end;

procedure TfrmVendor.btnDeleteClick(Sender: TObject);
begin
  tblVContact.delete;
  DbiSaveChanges(tblVContact.handle);
end;

procedure TfrmVendor.btnNewClick(Sender: TObject);
begin
  if (tblVendor.State = dsInsert) then begin
    if MessageDlg('New vendor must be saved before entering contacts...' + #13 + 'Save now?', mtConfirmation, [mbYes, mbNo], 0) = mrYes then
      try tblVendor.post; DbiSaveChanges(tblVendor.handle);
      except
        on E: EDBEngineError do
          if E.Errors[0].ErrorCode = 9729 then begin   //Key violation (key already exists).
            with editVendorNo do begin Show; SetFocus; end;
            raise(exception.create('Vendor no. already exists'));
          end else raise;
      end
    else raise(EAbort.create(''));  //Silent Exception: "abort;" replaced by "raise etc" since abort conflicts with BDE (required by DbiSaveChanges).
  end;
  screen.cursor := crHourglass;
  application.createform (TfrmVContact,frmVContact);
  frmVContact.tblVContact.Insert;
  frmVContact.tblVContactVendorID.value := tblVendorVendorID.value;
  frmVContact.Show;
  screen.cursor := crDefault;
end;

procedure TfrmVendor.btnEditClick(Sender: TObject);
begin
  if tblVContactContactID.AsVariant = null then btnNewClick(sender)   //Can happen if no contacts yet.
  else begin
    screen.cursor := crHourglass;
    application.createform (TfrmVContact,frmVContact);
    if frmVContact.tblVContact.Locate('ContactID', tblVContactContactID.value, []) = true then frmVContact.Show
    else tblVContact.refresh;   //Contact was deleted.
    screen.cursor := crDefault;
  end;
end;

procedure TfrmVendor.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
  if key = #13 then begin
    btnEditClick(Sender);
    Key := #0;   //Cancel Enter key.
  end;
end;

procedure TfrmVendor.tblVContactBeforeDelete(DataSet: TDataSet);
begin
  if MessageDlg('Delete ' + '''' + tblVContactFullName.AsString + '''' + '?',mtConfirmation,mbOKCancel,0) <> mrOK then raise(EAbort.create(''));  //Silent Exception: "abort;" replaced by "raise etc" since abort conflicts with BDE (required by DbiSaveChanges).
end;

procedure TfrmVendor.tblVContactCalcFields(DataSet: TDataSet);
begin
  if (tblVContactFirstName.Value <> '') and (tblVContactLastName.Value <> '') then tblVContactFullName.AsString := tblVContactFirstName.AsString + ' ' + tblVContactLastName.AsString
  else                                                                             tblVContactFullName.AsString := tblVContactFirstName.AsString + tblVContactLastName.AsString;
end;

procedure TfrmVendor.tblVendorNewRecord(DataSet: TDataSet);
var
  x: integer;
begin
  x := 0;
  while x < 150 do begin   //Loop if VendCtl table is locked.
    with tblVendCtl do begin
      try
        Open;
        Edit;
        if (tblVendCtlNextVendorNo.Value < 1001) or (tblVendCtlNextVendorNo.Value > 10000000) then tblVendCtlNextVendorNo.Value := 1001;   //Start auto-assigned numbers here.
        tblVendorVendorNo.Value := tblVendCtlNextVendorNo.AsString;
        tblVendCtlNextVendorNo.Value := tblVendCtlNextVendorNo.Value + 1;
        if tblVendCtlNextVendorID.Value = 0 then tblVendCtlNextVendorID.Value := 10000;   //Start at 10000 in case upgraded from v1.0 or 1.1 where autoincrement ID didn't use NextID on ctl table.
        tblVendorVendorID.Value := tblVendCtlNextVendorID.value;
        tblVendCtlNextVendorID.Value := tblVendCtlNextVendorID.Value + 1;
        Post;
      except end;
      DbiSaveChanges(tblVendCtl.handle);
      Close;
      if tblVendorVendorNo.value <> '' then break;
      x := x+1;
    end;
  end;

  if frmBS1.tblCompanyDefaultCurrencyID.value > 0 then tblVendorCurrencyID.value := frmBS1.tblCompanyDefaultCurrencyID.value;
  tblVendorSuspended.value := false;
end;

procedure TfrmVendor.PageControl1Change(Sender: TObject);
begin
  //screen.cursor := crHourglass;
  case PageControl1.ActivePage.PageIndex of
    //1: tblCurrency.Active := true;   //Data Module used instead.
    2: tblVContact.Active := true;
  end;
  //screen.cursor := crDefault;
end;

procedure TfrmVendor.popPhoneClick(Sender: TObject);
begin
  with frmDialer do begin
    NameToDial := tblVContactFullName.value;
    NumberToDial := tblVContactBusinessPhone.value;
    ShowModal;
  end;
end;

procedure TfrmVendor.tblVendorCurrencyIDValidate(Sender: TField);
begin
  with qryAPInv do begin
    close; open;
    if Fields[0].value > 0 then raise(exception.create('Currency cannot be changed... ' + #13 + 'Invoice(s) already exist'));
  end;
end;

procedure TfrmVendor.btnEmailClick(Sender: TObject);
var
  zFileName, zParams, zDir: array[0..79] of Char;
begin
  ShellExecute(Application.MainForm.Handle, nil,
  StrPCopy(zFileName, 'mailto:' + tblVendorEMail.value),   {filename}
  StrPCopy(zParams, ' '),   {command line perameters}
  StrPCopy(zDir, ''),   {default directory}
  SW_SHOW);   {SW_SHOW Normal window.  or SW_SHOWMINIMIZED, SW_HIDE, etc}
end;

procedure TfrmVendor.btnWebPageClick(Sender: TObject);
var
  zFileName, zParams, zDir: array[0..79] of Char;
begin
  ShellExecute(Application.MainForm.Handle, nil,
  StrPCopy(zFileName, 'http://' + tblVendorWebPage.value),   {filename}
  StrPCopy(zParams, ' '),   {command line perameters}
  StrPCopy(zDir, ''),   {default directory}
  SW_SHOW);   {SW_SHOW Normal window.  or SW_SHOWMINIMIZED, SW_HIDE, etc}
end;

procedure TfrmVendor.tblVendorWebPageSetText(Sender: TField;
  const Text: string);
begin
  if Text = '' then tblVendorWebPage.AsVariant := null else begin   //Remove leading "http://".
    if pos('http://', Text) >0 then tblVendorWebPage.value := copy(Text,8,22)
    else tblVendorWebPage.value := Text;
  end;
end;

procedure TfrmVendor.dsVContactDataChange(Sender: TObject; Field: TField);
begin
  if tblVContactBusinessPhone.AsString = '' then popPhone.Enabled := False
  else popPhone.Enabled := True;
  if tblVContactEMail.AsString = '' then popEMail.Enabled := False
  else popEMail.Enabled := True;
end;

procedure TfrmVendor.popEMailClick(Sender: TObject);
var
  zFileName, zParams, zDir: array[0..79] of Char;
begin
  ShellExecute(Application.MainForm.Handle, nil,
  StrPCopy(zFileName, 'mailto:' + tblVContactEMail.value),   {filename}
  StrPCopy(zParams, ' '),   {command line perameters}
  StrPCopy(zDir, ''),   {default directory}
  SW_SHOW);   {SW_SHOW Normal window.  or SW_SHOWMINIMIZED, SW_HIDE, etc}
end;

end.