.#goodsesfm.pas.1.36

来自「群星医药系统源码」· 36 代码 · 共 800 行 · 第 1/2 页

36
800 行
字号
12
  sUnitList.Free;
  sHypoKinds.Free;
  sDosetypeList.Free;
  Action:=CaFree;
end;

procedure TFmGoodses.ActExitExecute(Sender: TObject);
begin
  Close;
end;

procedure TFmGoodses.ActPrintExecute(Sender: TObject);
begin
  if not cdsGoodsPrices.Active then cdsGoodsPrices.Open;
  if not cdsGoodsBatchRebate.Active then cdsGoodsBatchRebate.Open;
  SelRepPrint(Name, [cdsGoodses, cdsGoodsPrices,cdsGoodsBatchRebate],
    '药品基本资料;药品单价表;商品批量折扣', ActDesignReport.Enabled);

//  SelRepPrint(Name, [cdsGoodses, cdsGoodsPrices,cdsGoodsBatchRebate],
//    '药品基本资料;药品单价表;销售相关信息;商品批量折扣;库存相关信息;采购相关相息', ActDesignReport.Enabled);
end;

procedure TFmGoodses.ActQueryExecute(Sender: TObject);
begin
//
end;

procedure TFmGoodses.cdsGoodsesBeforeGetRecords(Sender: TObject;
  var OwnerData: OleVariant);
var val: Variant;
begin
  val := OwnerData;
  OwnerData := VarArrayCreate([0,1], varVariant);
  OwnerData[0] := val;
  OwnerData[1] := vOwnerData;
end;

procedure TFmGoodses.cdsGoodsesAfterOpen(DataSet: TDataSet);
begin
  with DataSet as TckClientDataSet do begin
    if VarIsNull(vOwnerData) then begin
      last;
      vOwnerData:=Fieldbyname('GoodsID').Value;
    end;
  end;  
end;

procedure TFmGoodses.cdsGoodsesBeforeOpen(DataSet: TDataSet);
begin
  vOwnerData := null;
end;

procedure TFmGoodses.cdsGoodsesNewRecord(DataSet: TDataSet);
begin
  cdsGoodsesUsefulUnit.Value := '月';
end;

procedure TFmGoodses.ActMoreExecute(Sender: TObject);
Var
  abK:TBookMark;
begin
  Try
    If PacketRecs<0 Then
      CdsGoodses.PacketRecords:=-1
    Else
      CdsGoodses.PacketRecords:=PacketRecs;
    If (Not bTrueEof) Then
    Begin
      abK:=CdsGoodses.GetBookmark;
      if abk<>PublicMark Then
        Abk:=PublicMark;
      Try
        if (CdsGoodses.GetNextPacket<CdsGoodses.PacketRecords) Then
        Begin
          bTrueEof:=True;
          ActMore.Enabled:=False;
        End;
        CdsGoodses.Last;
        vOwnerData:=CdsGoodses.FieldByname('GoodsID').Value;
        CdsGoodses.GotoBookmark(abK);
        CdsGoodses.Next;
      Finally
        CdsGoodses.FreeBookmark(abK);
      End;
    End;
  Except
    On E:exception Do
      Messagebox(Handle,Pchar(E.Message),'',16);
  End;
end;

procedure TFmGoodses.Tab1TabChanged(Sender: TObject);
begin
  NoteBook1.PageIndex := Tab1.ActiveTab;
end;

procedure TFmGoodses.cdsGoodsesReconcileError(
  DataSet: TCustomClientDataSet; E: EReconcileError;
  UpdateKind: TUpdateKind; var Action: TReconcileAction);
begin
  Messagebox(Handle,Pchar(E.Message),'',16);
  Action:= raAbort;
end;

procedure TFmGoodses.CdsGoodsesPurchModeGetText(Sender: TField;
  var Text: String; DisplayText: Boolean);
begin
{  case Sender.AsInteger of
    0: Text := '购销';
    1: Text := '代销';
    else
      raise Exception.Create('指定了无效的采购方式！');
  end;
}
end;

procedure TFmGoodses.CdsGoodsesPurchModeSetText(Sender: TField;
  const Text: String);
begin
{  if Text='购销' then
    Sender.AsInteger := 0
  else if Text='代销' then
    Sender.AsInteger := 1
  else
    raise Exception.Create('指定了无效的采购方式！');
}
end;

procedure TFmGoodses.cdsGoodsBatchRebateNewRecord(DataSet: TDataSet);
begin
  CdsGoodsBatchRebateGoodsID.Value:=CdsGoodsesGoodsID.Value;
end;

procedure TFmGoodses.cdsGoodsesAfterGetRecords(Sender: TObject;
  var OwnerData: OleVariant);
begin
  PublicMark:=CdsGoodses.GetBookmark;
end;

procedure TFmGoodses.cdsGoodsPricesNewRecord(DataSet: TDataSet);
begin
  CdsGoodsPricesGoodsID.Value:=CdsGoodsesGoodsID.Value;
end;

procedure TFmGoodses.cdsGoodsesAfterScroll(DataSet: TDataSet);
begin
  if ckAutoViewPrice.Checked or chkAutoShowBatRebate.Checked then begin
    Timer1.Enabled := false;
    Timer1.Interval:= 300;
    Timer1.Enabled := true;
  end;
end;

procedure TFmGoodses.Timer1Timer(Sender: TObject);
begin
  Timer1.Enabled := false;
  if ckAutoViewPrice.Checked and (Notebook1.ActivePage = 'GoodsPrices') then
    ActViewPrice.Execute;
  if chkAutoShowBatRebate.Checked and (NoteBook1.ActivePage = 'GoodsBatchRebate') then
    ActViewBatchRebate.Execute;
end;

procedure TFmGoodses.ActViewPriceExecute(Sender: TObject);
begin
  //在主表为空或处于新增状态时，不能显示记录，否则出现排序错。
  if (cdsGoodses.IsEmpty)or(cdsGoodses.State = dsInsert) then Exit;
  with cdsGoodsPrices do begin
    Params.Items[0].Value := cdsGoodsesGoodsID.Value;
    if Active then
      Refresh
    else
      Open;
  end;
end;

procedure TFmGoodses.ActViewBatchRebateExecute(Sender: TObject);
begin
  //在主表为空或处于新增状态时，不能显示记录，否则出现排序错。
  if (cdsGoodses.IsEmpty)or(cdsGoodses.State = dsInsert) then Exit;
  with cdsGoodsBatchRebate do begin
    Params.Items[0].Value := cdsGoodsesGoodsID.Value;
    if Active then
      Refresh
    else
      Open;
  end;
end;

procedure TFmGoodses.ActAddBatchRebateExecute(Sender: TObject);
var ID,N,U1,U2: string;
begin
  if cdsGoodses.IsEmpty then Exit;
  with cdsGoodsBatchRebate do begin
    Params.Items[0].Value := cdsGoodsesGoodsID.Value;
    if Active then close;
    Open;
    ID := cdsGoodsesGoodsID.Value;
    N := cdsGoodsesName.Value;
    U1 := cdsGoodsesUnit1.Value;
    U2 := cdsGoodsesUnit2.Value;
    if TFmEditBatchRebate.Execute('新增批量折扣',ID,N,U1,U2,TClientDataSet(cdsGoodsBatchRebate)) then
    begin
      Post;
      if ApplyUpdates(0)>0 then
        MessageBox(Handle,'更新数据出错!',nil,MB_ICONHAND);
    end;
  end;
end;

procedure TFmGoodses.ActEdtBatchRebateExecute(Sender: TObject);
var ID,N,U1,U2: string;
begin
  if cdsGoodses.IsEmpty then Exit;
  if (cdsGoodsBatchRebate.IsEmpty)or(dbgBatchRebate.SelectedField = nil) then exit;
  with cdsGoodsBatchRebate do begin
    Params.Items[0].Value := cdsGoodsesGoodsID.Value;
    ID := cdsGoodsesGoodsID.Value;
    N := cdsGoodsesName.Value;
    U1 := cdsGoodsesUnit1.Value;
    U2 := cdsGoodsesUnit2.Value;
    if TFmEditBatchRebate.Execute('修改批量折扣',ID,N,U1,U2,TClientDataSet(cdsGoodsBatchRebate),true) then
    begin
      Post;
      if ApplyUpdates(0)>0 then
        MessageBox(Handle,'更新数据出错!',nil,MB_ICONHAND);
    end;
  end;
end;

procedure TFmGoodses.ActDelBatchRebateExecute(Sender: TObject);
begin
  if cdsGoodses.IsEmpty then Exit;
  if (cdsGoodsBatchRebate.IsEmpty)or(dbgBatchRebate.SelectedField = nil) then exit;
  if MessageBox(Handle,'真的要删除批量折扣记录吗?','提示',MB_YESNO or MB_ICONQUESTION)=IDNO then exit;
  cdsGoodsBatchRebate.Delete;
  if cdsGoodsBatchRebate.ApplyUpdates(0)>0 then
      MessageBox(Handle,'更新数据出错!',nil,MB_ICONHAND);
end;

procedure TFmGoodses.ActChkBatchRebateExecute(Sender: TObject);
var iMin: integer;
    sID, sRet: string;
begin
  with cdsGoodsBatchRebate do begin
    if (not Active)or(IsEmpty) then exit;
    sID := FieldByName('GoodsID').AsString;
    if SvrGoodses.AppServer.CheckBatchRebate(iClientID,sID,iMin,sRet) then
      MessageBox(Handle,PChar(sRet),'提示',MB_ICONINFORMATION)
    else begin
      Locate('BatMinQty',iMin,[]);
      MessageBox(Handle,PChar(sRet),nil,MB_ICONHAND);
    end;
  end;
end;

procedure TFmGoodses.ActModifyPriceExecute(Sender: TObject);
begin
  if cdsGoodses.IsEmpty then Exit;
  if cdsGoodsPrices.Params.Items[0].Value<>cdsGoodsesGoodsID.Value then
    ActViewPrice.Execute;
  if ShowPopupData(self, cdsGoodsPrices, '', '药品价格设定', 'GoodsID,ModeNo,ModeName,')=mrOK then begin
    if cdsGoodsPrices.ApplyUpdates(0)>0 then
      Application.MessageBox('数据更新失败！', '消息', MB_ICONINFORMATION);
  end else begin
    cdsGoodsPrices.CancelUpdates;
  end;
end;

procedure TFmGoodses.ActViewPriceModesExecute(Sender: TObject);
begin
  IFmMain.OnAction(Sender);
end;

procedure TFmGoodses.cdsGoodsesCalcFields(DataSet: TDataSet);
var iRate1, iRate2: Integer;
begin
  iRate1 := cdsGoodsesConvRate1.Value;
  iRate2 := cdsGoodsesConvRate2.Value;
  if (iRate1=iRate2) then
    cdsGoodsesConvRate.AsString := ''
  else
    cdsGoodsesConvRate.AsString := IntToStr(iRate1)+'/'+IntToStr(iRate2);
end;

procedure TFmGoodses.Button1Click(Sender: TObject);
begin
  DataExportFrm.ExportData([cdsGoodses, cdsGoodsPrices], '商品资料,商品价格设定', '');
end;

procedure TFmGoodses.dbgGoodsesDblClick(Sender: TObject);
begin
  if ckViewPriceOnDbclick.Checked then
    ActViewPrice.Execute
  else
    ActModify.Execute;
end;

procedure TFmGoodses.BtnPopMenuClick(Sender: TObject);
var tp:TPoint;
begin
	tp.x:=BtnPopMenu.left;
	tp.y:=BtnPopMenu.Top+BtnPopMenu.Height+1;
	tp:=ClientToScreen(tp);
	TopPopmenu.Popup(tp.x,tp.Y);
end;

procedure TFmGoodses.ActFieldsLayoutExecute(Sender: TObject);
begin
  SetFieldsLayOut(LocSetting^.FieldLayoutCfgFile, Name,
                  [dbgGoodses,dbgGoodsPrices,dbgBatchRebate],
                  '药品资料;药品价格设定;批量销售折扣');
end;

procedure TFmGoodses.ActDataExportExecute(Sender: TObject);
begin
	ExportData([cdsGoodses, cdsGoodsPrices, cdsGoodsBatchRebate],
             '药品资料;药品价格设定;批量销售折扣', '');
end;

procedure TFmGoodses.cdsGoodsesUnit2Change(Sender: TField);
begin
  if (cdsGoodsesUnit2.AsString='') and not cdsGoodsesUnit2.IsNull then
    cdsGoodsesUnit2.AsVariant := null;
end;

procedure TFmGoodses.edQuickSearchChange(Sender: TObject);
const
  MatchFields : array[0..4] of string=('GoodsId','Pym','Name','BarCode','BarCode2');
var
  i: integer;
begin
  If not chkAutoMatch.Checked then exit;
  i :=0;
  while (i<5)and(not cdsGoodses.Locate(MatchFields[i],edQuickSearch.Text,[loCaseInsensitive ,loPartialKey])) do
    inc(i);
end;

procedure TFmGoodses.edQuickSearchKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
const
  MatchFields : array[0..4] of string=('GoodsId','Pym','Name','BarCode','BarCode2');
var
  i: integer;
begin
  i :=0;
  If Key=13 then
  while (i<5)and(not cdsGoodses.Locate(MatchFields[i],edQuickSearch.Text,[loCaseInsensitive ,loPartialKey])) do
    inc(i);
  if (key=VK_UP)or(key=VK_DOWN) then begin
    PostMessage(dbgGoodses.Handle,WM_KEYDOWN,Key,0);
    key :=0;
  end;
end;

procedure TFmGoodses.FormActivate(Sender: TObject);
begin
  edQuickSearch.SetFocus;
end;

procedure TFmGoodses.dbgGoodsesKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if key=13 then edQuickSearch.SetFocus;
end;

procedure TFmGoodses.cdsGoodsBatchRebateBeforeRefresh(DataSet: TDataSet);
begin
  with cdsGoodsBatchRebate do
  if ApplyUpdates(0)>0 then CancelUpdates;
end;

procedure TFmGoodses.cdsGoodsBatchRebatePostError(DataSet: TDataSet;
  E: EDatabaseError; var Action: TDataAction);
begin
  if  E.Message = 'Key violation.' then
    MessageBox(Handle,'不能增加重复的批量折扣规则!',nil,MB_ICONHAND);
  Action := daAbort;
  TClientDataSet(DataSet).CancelUpdates;
end;

procedure TFmGoodses.mnAutoPinYinClick(Sender: TObject);
var i: Integer;
begin
  i := Application.MessageBox('确定自动生成拼音码吗？'#13#13'要为所有的药品重新生成拼音码请按[是]'#13'要为所有未指定拼音码的药品生成拼音码请按[否]'#13'按[取消]放弃此操作！', '消息', MB_ICONQUESTION+MB_YESNOCANCEL);
  if i=IDCANCEL then Exit;
  SetGressHint('正在自动生成拼音码，请稍候...');
  try
    SvrGoodses.AppServer.AutoBuildPym(iClientID, i=IDYES);
    cdsGoodses.Refresh;
  finally
    FreeGressForm;
  end;
end;

initialization
  RegisterClass(TFmGoodses);
finalization
  UnRegisterClass(TFmGoodses);
end.
12

.#goodsesfm.pas.1.36 - 源码说明

本页面展示了「群星医药系统源码」中的 .#goodsesfm.pas.1.36 源码文件，采用 36 编程语言编写，共 800 行代码。您可以在线阅读完整代码内容，也可以返回资源详情页下载完整源码包进行本地学习和开发。

虫虫开发者社区收录了大量与医药系统相关的技术资源，包括源代码、技术文档、电路图等，是电子工程师和嵌入式开发者的专业学习平台。

⌨️ 快捷键说明

复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?