Measure/DataModules/BGLDm.pas

unit BGLDm;

interface

uses
  SysUtils, Classes, DB, DBClient, Provider, ADODB, sdIDTree,
  sdDB;

type
  TBGLSelectInfo = class(TObject)
  private
    FB_Code: string;
    FName: string;
    FUnits: string;
    FPrice: Double;

    FIsOrg: Boolean;
    FTotalNum: Double;
    FNums: TStrings;
    FCodes: TStrings;
    procedure SetMergedCode(const Value: string);
    procedure SetMergedNum(const Value: string);
    function GetCount: Integer;
    function GetMergedCode: string;
    function GetMergedNum: string;
  public
    constructor Create(ARec: TsdDataRecord; ATotalNum: Double; AIsOrg: Boolean);
    destructor Destroy; override;
    procedure Clear;

    property MergedCode: string read GetMergedCode write SetMergedCode;
    property MergedNum: string read GetMergedNum write SetMergedNum;
    property Codes: TStrings read FCodes;
    property Nums: TStrings read FNums;
    property Count: Integer read GetCount;
    property TotalNum: Double read FTotalNum write FTotalNum;
    property IsOrg: Boolean read FIsOrg;

    property B_Code: string read FB_Code;
    property Name: string read FName;
    property Units: string read FUnits;
    property Price: Double read FPrice;
  end;

  TBGLData = class(TDataModule)
    atBGL: TADOTable;
    dspBGL: TDataSetProvider;
    cdsBGL: TClientDataSet;
    cdsBGLID: TIntegerField;
    cdsBGLCode: TWideStringField;
    cdsBGLName: TWideStringField;
    cdsBGLTotalPrice: TFloatField;
    cdsBGLPos_Reason: TMemoField;
    cdsBGLDirection: TMemoField;
    cdsBGLDrawingCode: TWideStringField;
    cdsBGLApprovalCode: TWideStringField;
    cdsBGLCreatePhaseID: TIntegerField;
    cdsBGLExecutionRate: TFloatField;

    cdsBGLView: TClientDataSet;
    cdsBGLViewID: TIntegerField;
    cdsBGLViewCode: TWideStringField;
    cdsBGLViewName: TWideStringField;
    cdsBGLViewTotalPrice: TFloatField;
    cdsBGLViewPos_Reason: TMemoField;
    cdsBGLViewDirection: TMemoField;
    cdsBGLViewDrawingCode: TWideStringField;
    cdsBGLViewApprovalCode: TWideStringField;
    cdsBGLViewCreatePhaseID: TIntegerField;
    cdsBGLViewExecutionRate: TFloatField;

    dsBGL: TDataSource;

    atBGBills: TADOTable;
    dspBGBills: TDataSetProvider;
    cdsBGBills: TClientDataSet;
    cdsBGBillsID: TIntegerField;
    cdsBGBillsBGID: TIntegerField;
    cdsBGBillsB_Code: TWideStringField;
    cdsBGBillsName: TWideStringField;
    cdsBGBillsUnits: TWideStringField;
    cdsBGBillsPrice: TFloatField;
    cdsBGBillsQuantity: TFloatField;
    cdsBGBillsTotalPrice: TFloatField;
    cdsBGBillsUsedQuantity: TFloatField;
    
    cdsBGBillsView: TClientDataSet;
    cdsBGBillsViewID: TIntegerField;
    cdsBGBillsViewBGID: TIntegerField;
    cdsBGBillsViewB_Code: TWideStringField;
    cdsBGBillsViewName: TWideStringField;
    cdsBGBillsViewUnits: TWideStringField;
    cdsBGBillsViewPrice: TFloatField;
    cdsBGBillsViewQuantity: TFloatField;
    cdsBGBillsViewTotalPrice: TFloatField;
    cdsBGBillsViewUsedQuantity: TFloatField;
    cdsBGLBGLType: TWideStringField;
    cdsBGLViewBGLType: TWideStringField;
    procedure cdsBGBillsViewAfterInsert(DataSet: TDataSet);
    procedure cdsBGBillsViewAfterPost(DataSet: TDataSet);
    procedure cdsBGBillsViewQuantityChange(Sender: TField);
    procedure cdsBGBillsViewBeforePost(DataSet: TDataSet);
    procedure cdsBGLViewBeforePost(DataSet: TDataSet);
    procedure cdsBGLViewBeforeDelete(DataSet: TDataSet);
    procedure cdsBGBillsViewBeforeDelete(DataSet: TDataSet);
    procedure cdsBGBillsViewAfterDelete(DataSet: TDataSet);
    procedure cdsBGLViewNewRecord(DataSet: TDataSet);
    procedure cdsBGBillsViewQuantitySetText(Sender: TField;
      const Text: String);
    procedure cdsBGBillsViewPriceSetText(Sender: TField;
      const Text: String);
    procedure cdsBGLViewCodeChange(Sender: TField);
  private
    FProjectData: TObject;

    procedure GatherBGLTotalPrice(ABGLID: Integer);
    procedure UpdateBGLTotalPrice(ABGLID: Integer; ADiffer: Double);

    procedure UpdateBGLExecutionRate(ABGLID: Integer);
    procedure ApplyBGL(ABGLInfo: TBGLSelectInfo); overload;

    procedure DeleteBGBills(ABGID: Integer);

    function CheckSameB_Code(ABGID: Integer; const AB_Code: string): Boolean;
    function CheckBGLUsed(ABGID: Integer): Boolean;

    function LocateBGL(const ACode: string): Boolean;
    function LocateBGBills(ABGID: Integer; const AB_Code: string): Boolean;
  public
    constructor Create(AProjectData: TObject);
    destructor Destroy; override;

    procedure Open(AConnection: TADOConnection);
    procedure Close;
    procedure Save;

    function AllBGLTotalPrice: Double;

    procedure AddBGL(const sCode: string);
    procedure ApplyBGL(AOrgBGL, ANewBGL: TBGLSelectInfo); overload;

    procedure BatchWritePos_Reason;

    property ProjectData: TObject read FProjectData;
  end;

implementation

uses
  ZhAPI, Math, ProjectData, BillsDm, Variants, UtilMethods;

{$R *.dfm}

{ TBGLSelectInfo }

procedure TBGLSelectInfo.Clear;
begin
  FCodes.Clear;
  FNums.Clear;
end;

constructor TBGLSelectInfo.Create(ARec: TsdDataRecord;
  ATotalNum: Double; AIsOrg: Boolean);
begin
  FB_Code := ARec.ValueByName('B_Code').AsString;
  FName := ARec.ValueByName('Name').AsString;
  FUnits := ARec.ValueByName('Units').AsString;
  FPrice := ARec.ValueByName('Price').AsFloat;

  FTotalNum := ATotalNum;
  FIsOrg := AIsOrg;

  FCodes := TStringList.Create;
  FCodes.Delimiter := ';';
  FNums := TStringList.Create;
  FNums.Delimiter := ';';
end;

destructor TBGLSelectInfo.Destroy;
begin
  FNums.Free;
  FCodes.Free;
  inherited;
end;

function TBGLSelectInfo.GetCount: Integer;
begin
  Result := Min(FCodes.Count, FNums.Count);
end;

function TBGLSelectInfo.GetMergedCode: string;
begin
  Result := FCodes.DelimitedText;
end;

function TBGLSelectInfo.GetMergedNum: string;
begin
  Result := FNums.DelimitedText;
end;

procedure TBGLSelectInfo.SetMergedCode(const Value: string);
begin
  if Value <> '' then
    FCodes.DelimitedText := Value
  else
    FCodes.Clear;
end;

procedure TBGLSelectInfo.SetMergedNum(const Value: string);
begin
  if Value <> '' then
    FNums.DelimitedText := Value
  else
    FNums.Clear;
end;

{ TBGLData }

constructor TBGLData.Create(AProjectData: TObject);
begin
  inherited Create(nil);
  FProjectData := AProjectData;
end;

destructor TBGLData.Destroy;
begin
  inherited;
end;

procedure TBGLData.Open(AConnection: TADOConnection);
begin
  atBGL.Connection := AConnection;
  cdsBGL.Open;
  cdsBGL.AddIndex('idxID', 'ID', []);
  cdsBGL.AddIndex('idxCode', 'Code', []);
  cdsBGL.IndexName := 'idxID';
  cdsBGLView.CloneCursor(cdsBGL, True);

  atBGBills.Connection := AConnection;
  cdsBGBills.Open;
  cdsBGBillsView.CloneCursor(cdsBGBills, True);
  cdsBGBills.IndexFieldNames := 'ID';
  cdsBGBillsView.MasterSource := dsBGL;
  cdsBGBillsView.MasterFields := 'ID';
  cdsBGBillsView.IndexFieldNames := 'BGID;ID';
end;

procedure TBGLData.Save;
begin
  cdsBGL.ApplyUpdates(0);
  cdsBGBills.ApplyUpdates(0);
end;

procedure TBGLData.cdsBGBillsViewAfterInsert(DataSet: TDataSet);
begin
  cdsBGBillsViewID.AsInteger := GetNewIDOfIndex(cdsBGBills);
  cdsBGBillsViewBGID.AsInteger := cdsBGLViewID.AsInteger;
end;

procedure TBGLData.AddBGL(const sCode: string);
begin
  cdsBGLView.DisableControls;
  cdsBGLView.Append;
  cdsBGLViewCode.AsString := sCode;
  cdsBGLView.Post;
  cdsBGLView.EnableControls;
end;

procedure TBGLData.cdsBGBillsViewAfterPost(DataSet: TDataSet);

  procedure DoB_CodeChange;
  var
    Rec: TsdDataRecord;
  begin
    cdsBGBillsViewB_Code.Tag := 0;
    cdsBGBillsView.Edit;
    with TProjectData(FProjectData).BillsData do
    begin
      Rec := sddBills.Locate('B_Code', cdsBGBillsViewB_Code.AsString);
      if Rec <> nil then
      begin
        cdsBGBillsViewName.AsString := Rec.ValueByName('Name').AsString;
        cdsBGBillsViewUnits.AsString := Rec.ValueByName('Units').AsString;
        cdsBGBillsViewPrice.AsString := Rec.ValueByName('Price').AsString;
      end;
    end;
    cdsBGBillsView.Post;
  end;

  procedure ClearChangeTag;
  begin
    cdsBGBillsViewB_Code.Tag := 0;
    cdsBGBillsViewName.Tag := 0;
    cdsBGBillsViewUnits.Tag := 0;
    cdsBGBillsViewPrice.Tag := 0;
    cdsBGBillsViewQuantity.Tag := 0;
  end;

var
  fTotalPrice, Differ: Double;
begin
  if (cdsBGBillsViewB_Code.Tag = 1) then
    DoB_CodeChange;

  if (cdsBGBillsViewPrice.Tag = 1) or
      (cdsBGBillsViewQuantity.Tag = 1) then
  begin
    cdsBGBillsViewPrice.Tag := 0;
    cdsBGBillsViewQuantity.Tag := 0;
    fTotalPrice := TotalPriceRoundTo(cdsBGBillsViewPrice.AsFloat * cdsBGBillsViewQuantity.AsFloat);
    UpdateBGLTotalPrice(cdsBGBillsViewBGID.AsInteger, fTotalPrice - cdsBGBillsViewTotalPrice.AsFloat);
    UpdateBGLExecutionRate(cdsBGBillsViewBGID.AsInteger);
    cdsBGBillsView.Edit;
    cdsBGBillsViewTotalPrice.AsFloat := fTotalPrice;
    cdsBGBillsView.Post;
  end;

  ClearChangeTag;
end;

procedure TBGLData.cdsBGBillsViewQuantityChange(Sender: TField);
begin
  Sender.Tag := 1;
end;

procedure TBGLData.GatherBGLTotalPrice(ABGLID: Integer);
var
  fGather: Double;
begin
  cdsBGBills.Filter := 'BGID = ' + IntToStr(ABGLID);
  cdsBGBills.Filtered := True;
  try
    fGather := 0;
    cdsBGBills.First;
    while not cdsBGBills.Eof do
    begin
      fGather := fGather + cdsBGBillsTotalPrice.AsFloat;
      cdsBGBills.Next;
    end;
    if cdsBGL.FindKey([ABGLID]) then
    begin
      cdsBGL.Edit;
      cdsBGLTotalPrice.AsFloat := fGather;
      cdsBGL.Post;
    end;
  finally
    cdsBGBills.Filtered := False;
  end;
end;

procedure TBGLData.UpdateBGLTotalPrice(ABGLID: Integer; ADiffer: Double);
begin
  if cdsBGL.FindKey([ABGLID]) then
  begin
    cdsBGL.Edit;
    cdsBGLTotalPrice.AsFloat := cdsBGLTotalPrice.AsFloat + ADiffer;
    cdsBGL.Post;
  end;
end;

procedure TBGLData.ApplyBGL(AOrgBGL, ANewBGL: TBGLSelectInfo);
begin
  ApplyBGL(AOrgBGL);
  ApplyBGL(ANewBGL);
end;

procedure TBGLData.ApplyBGL(ABGLInfo: TBGLSelectInfo);
var
  I: Integer;
  fNum: Double;
begin
  for I := 0 to ABGLInfo.Count - 1 do
    if LocateBGL(ABGLInfo.Codes[I]) and
        LocateBGBills(cdsBGLID.AsInteger, ABGLInfo.B_Code) then
    begin
      cdsBGBills.Edit;
      fNum := QuantityRoundTo(StrToFloatDef(ABGLInfo.Nums[I], 0));
      if ABGLInfo.IsOrg then
        cdsBGBillsUsedQuantity.AsFloat := QuantityRoundTo(cdsBGBillsUsedQuantity.AsFloat - fNum)
      else
        cdsBGBillsUsedQuantity.AsFloat := QuantityRoundTo(cdsBGBillsUsedQuantity.AsFloat + fNum);
      cdsBGBills.Post;
      UpdateBGLExecutionRate(cdsBGBillsBGID.AsInteger);
    end;
end;

procedure TBGLData.cdsBGBillsViewBeforePost(DataSet: TDataSet);

  procedure DisplayErrorMessage(const AHint: string);
  begin
    cdsBGBillsViewB_Code.Tag := 0;
    cdsBGBillsViewName.Tag := 0;
    cdsBGBillsViewUnits.Tag := 0;
    cdsBGBillsViewPrice.Tag := 0;
    cdsBGBillsViewQuantity.Tag := 0;
    ErrorMessage(AHint);
    Abort;
  end;

begin
  if (cdsBGBillsViewB_Code.Tag = 1) or
      (cdsBGBillsViewName.Tag = 1) or
      (cdsBGBillsViewUnits.Tag = 1) or
      (cdsBGBillsViewPrice.Tag = 1) then
  begin
    if cdsBGBillsViewUsedQuantity.AsFloat <> 0 then
      DisplayErrorMessage('变更令已被应用至清单，不可修改！');
  end;

  if (cdsBGBillsViewQuantity.Tag = 1) then
  begin
    if (cdsBGBillsViewUsedQuantity.AsFloat <> 0) and
       (cdsBGBillsViewQuantity.AsFloat < cdsBGBillsViewUsedQuantity.AsFloat) then
      DisplayErrorMessage('变更清单的清单数量应大于已变更数量！');
  end;

  if cdsBGBillsViewB_Code.Tag = 1 then
    if CheckSameB_Code(cdsBGBillsViewBGID.AsInteger, cdsBGBillsViewB_Code.AsString) then
    begin
      DisplayErrorMessage('不允许存在同编号变更清单！');
    end;
end;

procedure TBGLData.cdsBGLViewBeforePost(DataSet: TDataSet);
var
  iIncrement: Integer;
  sNewCode: string;
begin
  // 变更令号不可为空
  if cdsBGLViewCode.AsString = '' then
  begin
    cdsBGLViewCode.Tag := 0;
    if cdsBGL.FindKey([cdsBGLViewID.AsInteger]) then
      if cdsBGLCode.AsString <> '' then
        WarningMessage('变更令号不允许为空，如需删除，请点击右键进行删除。');
    DataSet.Cancel;
    Abort;
  end;

  if cdsBGLViewCode.Tag = 1 then
  begin
    cdsBGLViewCode.Tag := 0;

    if CheckBGLUsed(cdsBGLViewID.AsInteger) then
    begin
      ErrorMessage('当前变更令下变更清单已被应用到清单，不可修改！');
      Abort;
    end;

    sNewCode := cdsBGLViewCode.AsString;
    if Pos(';', sNewCode) > 0 then
    begin
      ErrorMessage('变更令号不可输入'';''，请使用其他符号代替！');
      Abort;
    end;

    // 相同变更令号应递增[1],[2]...
    iIncrement := 1;
    while LocateBGL(sNewCode) and (cdsBGLID.AsInteger <> cdsBGLViewID.AsInteger) do
    begin
      sNewCode := Format('%s[%d]', [cdsBGLViewCode.AsString, iIncrement]);
      Inc(iIncrement);
    end;
    if cdsBGLViewCode.AsString <> sNewCode then
    begin
      cdsBGLViewCode.AsString := sNewCode;
      cdsBGLViewCode.Tag := 0;
    end;
  end;
end;

procedure TBGLData.DeleteBGBills(ABGID: Integer);
begin
  cdsBGBills.Filter := 'BGID = ' + IntToStr(ABGID);
  cdsBGBills.Filtered := True;
  try
    cdsBGBills.First;
    while not cdsBGBills.Eof do
      cdsBGBills.Delete;
  finally
    cdsBGBills.Filtered := False;
  end;
end;

procedure TBGLData.cdsBGLViewBeforeDelete(DataSet: TDataSet);
begin
  if CheckBGLUsed(cdsBGLViewID.AsInteger) then
    raise Exception.Create('变更令下变更清单已被应用到清单，不可删除！');
  DeleteBGBills(cdsBGLViewID.AsInteger);
end;

function TBGLData.CheckSameB_Code(ABGID: Integer;
  const AB_Code: string): Boolean;
begin
  Result := False;
  cdsBGBills.Filter := 'BGID = ' + IntToStr(ABGID);
  cdsBGBills.Filtered := True;
  try
    cdsBGBills.First;
    while (not cdsBGBills.Eof) and (not Result) do
    begin
      Result := Result or SameText(cdsBGBillsB_Code.AsString, AB_Code);
      cdsBGBills.Next;
    end;
  finally
    cdsBGBills.Filtered := False;
  end;
end;

procedure TBGLData.cdsBGBillsViewBeforeDelete(DataSet: TDataSet);
begin
  if cdsBGBillsViewUsedQuantity.AsFloat <> 0 then
    raise Exception.Create('变更清单已被应用至清单，不可删除！');
end;

function TBGLData.CheckBGLUsed(ABGID: Integer): Boolean;
begin
  Result := False;
  cdsBGBills.Filter := 'BGID = ' + IntToStr(ABGID);
  cdsBGBills.Filtered := True;
  try
    cdsBGBills.First;
    while (not cdsBGBills.Eof) and (not Result) do
    begin
      Result := Result or (cdsBGBillsUsedQuantity.AsFloat <> 0);
      cdsBGBills.Next;
    end;
  finally
    cdsBGBills.Filtered := False;
  end;
end;

procedure TBGLData.cdsBGBillsViewAfterDelete(DataSet: TDataSet);
begin
  GatherBGLTotalPrice(cdsBGLViewID.AsInteger);
  UpdateBGLExecutionRate(cdsBGLViewID.AsInteger);
end;

procedure TBGLData.BatchWritePos_Reason;
begin
  cdsBGL.First;
  while not cdsBGL.Eof do
  begin
    cdsBGL.Edit;
    cdsBGLPos_Reason.AsString := cdsBGLName.AsString;
    cdsBGL.Post;
    cdsBGL.Next;
  end;
end;

procedure TBGLData.cdsBGLViewNewRecord(DataSet: TDataSet);
begin
  cdsBGLViewID.AsInteger := GetNewIDOfIndex(cdsBGL);
  cdsBGLViewCreatePhaseID.AsInteger := TProjectData(FProjectData).PhaseIndex;
end;

procedure TBGLData.UpdateBGLExecutionRate(ABGLID: Integer);

  function GetBGLExecutionTotalPrice: Double;
  var
    cdsTemp: TClientDataSet;
  begin
    Result := 0;
    cdsTemp := TClientDataSet.Create(nil);
    try
      cdsTemp.CloneCursor(cdsBGBills, True);
      cdsTemp.Filter := Format('BGID = %d', [ABGLID]);
      cdsTemp.Filtered := True;
      cdsTemp.First;
      while not cdsTemp.Eof do
      begin
        Result := Result + TotalPriceRoundTo(
            cdsTemp.FieldByName('UsedQuantity').AsFloat * cdsTemp.FieldByName('Price').AsFloat);
        cdsTemp.Next;
      end;
    finally
      cdsTemp.Free;
    end;
  end;

begin
  if cdsBGL.FindKey([ABGLID]) then
  begin
    cdsBGL.Edit;
    if cdsBGLTotalPrice.AsFloat <> 0 then
      cdsBGLExecutionRate.AsFloat := AdvRoundTo(GetBGLExecutionTotalPrice/cdsBGLTotalPrice.AsFloat*100)
    else
      cdsBGLExecutionRate.AsFloat := 0;
    cdsBGL.Post;
  end;
end;

function TBGLData.AllBGLTotalPrice: Double;
begin
  Result := 0;
  cdsBGL.First;
  while not cdsBGL.Eof do
  begin
    Result := Result + cdsBGLTotalPrice.AsFloat;
    cdsBGL.Next;
  end;
end;

procedure TBGLData.cdsBGBillsViewQuantitySetText(Sender: TField;
  const Text: String);
begin
  Sender.AsFloat := QuantityRoundTo(StrToFloatDef(Text, 0));
end;

procedure TBGLData.cdsBGBillsViewPriceSetText(Sender: TField;
  const Text: String);
begin
  Sender.AsFloat := PriceRoundTo(StrToFloatDef(Text, 0));
end;

procedure TBGLData.cdsBGLViewCodeChange(Sender: TField);
begin
  Sender.Tag := 1;
end;

procedure TBGLData.Close;
begin
  cdsBGL.IndexName := '';
  cdsBGL.Close;
  cdsBGBills.Close;
end;

function TBGLData.LocateBGL(const ACode: string): Boolean;
begin
  cdsBGL.IndexName := 'idxCode';
  try
    Result := cdsBGL.FindKey([ACode]);
  finally
    cdsBGL.IndexName := 'idxID';
  end;
end;

function TBGLData.LocateBGBills(ABGID: Integer;
  const AB_Code: string): Boolean;
begin
  Result := False;
  cdsBGBills.First;
  while (not cdsBGBills.Eof) do
  begin
    if (cdsBGBillsBGID.AsInteger = ABGID) and
       SameText(cdsBGBillsB_Code.AsString, AB_Code) then
    begin
      Result := True;
      Break;
    end;
    cdsBGBills.Next;
  end;
end;

end.