lbdbctrls.pas

天涯進銷存系統

    FDataLink.UpdateAction(Action);
end;

{ TLBDBNumberEdit }
constructor TLBDBNumberEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle - [csSetCaption]; 
  FDecimalPlaces := 2;
  FDisplayFormat := DefaultDisplayFormat;
end;

function TLBDBNumberEdit.DefaultDisplayFormat: string;
begin
  Result := '';
  if Result = '' then
    Result := DefaultCurrencyDisplayFormat;
end;

function TLBDBNumberEdit.DefaultMaxValue: Double;
begin
  Result := 0;
end;

function TLBDBNumberEdit.DefaultMinValue: Double;
begin
  Result := 0;
end;

procedure TLBDBNumberEdit.SetMinMaxValues(AMinValue, AMaxValue: Double);
begin
  SetEditMinMaxValues(AMinValue, AMaxValue);
end;

procedure TLBDBNumberEdit.KeyPress(var Key: Char);
begin
  if Key in ['.', ','] then Key := DecimalSeparator;
  if (Key in [#32 .. #255]) and not IsValidChar(Key) then
  begin
    Key := #0;
    MessageBeep(0);
  end;
  if Key <> #0 then inherited KeyPress(Key);
end;


function TLBDBNumberEdit.IsValidChar(Key: Char): Boolean;
var
  S: string;
  V: Double;
  StartPos, StopPos, DecPos: Integer;
begin
  Result := False;
  if not (Key in [DecimalSeparator,
    '-', '+', '0'..'9']) then Exit;
  S := Text;
  StartPos := SelStart;
  StopPos := SelStart + SelLength;
  System.Delete(S, SelStart + 1, StopPos - StartPos);
  if (Key = '-') and (S = '') then
  begin
    Result := True;
    Exit;
  end;
  System.Insert(Key, S, StartPos + 1);
  DecPos := Pos(DecimalSeparator, S);
  if (DecPos > 0) then
  begin
    StartPos := Pos('E', UpperCase(S));
    if (StartPos > DecPos) then
      DecPos := StartPos - DecPos - 1
    else DecPos := Length(S) - DecPos;
    if DecPos > DecimalPlaces then Exit;
  end;
  if StrToFloatEx(S, V) then
    Result := True;
{  try
    StrToFloat(S);
    Result := True;
  except
  end;}
end;


procedure TLBDBNumberEdit.SetEditDisplayFormat(const Value: string);
begin
  if FDisplayFormat <> Value then
  begin
    FDisplayFormat := Value;
  end;
end;

procedure TLBDBNumberEdit.SetEditMaxValue(Value: Double);
begin
  if Value < FMinValue then Value := FMinValue;
  if FMaxValue <> Value then
  begin
    FMaxValue := Value;
    SetValue(GetValue);
  end;
end;

procedure TLBDBNumberEdit.SetEditMinValue(Value: Double);
begin
  if Value > FMaxValue then Value := FMaxValue;
  if FMinValue <> Value then
  begin
    FMinValue := Value;
    SetValue(GetValue);
  end;
end;

class function TLBDBNumberEdit.StrToFloatEx(const S: string; var Value: Double): Boolean;
const
  MinDouble = 5.0e-324;
  MaxDouble = 1.7e+308;
var
  E: Extended;  
begin
  if not TextToFloat(PChar(S), E, fvExtended) or
    ((E <> 0) and ((Abs(E) < MinDouble) or (Abs(E) > MaxDouble))) then
  begin
    Value := 0;
    Result := False;
  end
  else
    begin
      Value := E;
      Result := True;
    end;  
end;

procedure TLBDBNumberEdit.SetEditMinMaxValues(AMinValue, AMaxValue: Double);
begin
  if AMinValue > AMaxValue then AMinValue := AMaxValue;
  FMinValue := AMinValue;
  FMaxValue := AMaxValue;
  SetValue(GetValue);
end;

function TLBDBNumberEdit.GetValue: Double;
begin
  if Text = '' then
    Result := 0
  else
    if not StrToFloatEx(Text, Result) then
      Result := MinValue;
end;

function TLBDBNumberEdit.IsDisplayFormatStored: Boolean;
begin
end;

function TLBDBNumberEdit.IsMaxValueStored: Boolean;
begin
end;

function TLBDBNumberEdit.IsMinValueStored: Boolean;
begin
end;

function TLBDBNumberEdit.IsValueStored: Boolean;
begin
  Result := GetValue <> 0.0;
end;

procedure TLBDBNumberEdit.SetDisplayFormat(const Value: string);
begin
  SetEditDisplayFormat(Value);
end;

procedure TLBDBNumberEdit.SetMaxValue(Value: Double);
begin
  SetEditMaxValue(Value);
end;

procedure TLBDBNumberEdit.SetMinValue(Value: Double);
begin
  SetEditMinValue(Value);
end;

procedure TLBDBNumberEdit.SetValue(Value: Double);
var
  S: string;
  PrevModified: Boolean;
begin
  if MaxValue <> MinValue then
  begin
    if Value < MinValue then Value := MinValue
    else if Value > MaxValue then Value := MaxValue;
  end;
  // TODO !!
  S := FloatToStrF(Value, ffGeneral{ffFixed}, 15, 0);
  PrevModified := Modified;
  try
    if Text <> S then Text := S;
  finally
    Modified := PrevModified;
  end;
end;

procedure TLBDBNumberEdit.WMPaste(var Message: TWMPaste);
var
  S: string;
begin
  S := Text;
  inherited;
  try
    StrToFloat(Text);
  except
    Text := S;
    SelectAll;
  end;
end;

procedure TLBDBNumberEdit.CMWinIniChange(var Message: TWMWinIniChange);
begin
  inherited;
  SysUtils.GetFormatSettings; // TODO?
  SetEditDisplayFormat(DefaultDisplayFormat);
end;

{ TLBDBCheckBox }

constructor TLBDBCheckBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FReadOnly := True;
  ControlStyle := ControlStyle + [csReplicatable];
  FValueCheck := STextTrue;
  FValueUncheck := STextFalse;
  FDataLink := TFieldDataLink.Create;
  FDataLink.Control := Self;
  FDataLink.OnDataChange := DataChange;
  FDataLink.OnEditingChange := EditingChange;
  FDataLink.OnUpdateData := UpdateData;
  FPaintControl := TPaintControl.Create(Self, 'BUTTON');
  FPaintControl.Ctl3DButton := True;
end;

destructor TLBDBCheckBox.Destroy;
begin
  FPaintControl.Free;
  FDataLink.Free;
  FDataLink := nil;
  inherited Destroy;
end;

procedure TLBDBCheckBox.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (FDataLink <> nil) and
    (AComponent = DataSource) then DataSource := nil;
end;

function TLBDBCheckBox.UseRightToLeftAlignment: Boolean;
begin
  Result := DBUseRightToLeftAlignment(Self, Field);
end;

function TLBDBCheckBox.GetFieldState: TCheckBoxState;
var
  Text: string;
begin
  if FDatalink.Field <> nil then
    if FDataLink.Field.IsNull then
      Checked := False
    else if FDataLink.Field.DataType = ftBoolean then
      if FDataLink.Field.AsBoolean then
        Checked := True
      else
        Checked := False
    else
    begin
      Checked := False;
      Text := FDataLink.Field.Text;
      if ValueMatch(FValueCheck, Text) then Checked := True else
        if ValueMatch(FValueUncheck, Text) then Checked := False;
    end
  else
    Result := cbUnchecked;
end;

procedure TLBDBCheckBox.DataChange(Sender: TObject);
begin
  GetFieldState;
end;

procedure TLBDBCheckBox.EditingChange(Sender: TObject);
begin
  FReadOnly := not FDataLink.Editing;
end;

procedure TLBDBCheckBox.UpdateData(Sender: TObject);
var
  Pos: Integer;
  S: string;
begin
    if FDataLink.Field.DataType = ftBoolean then
      FDataLink.Field.AsBoolean := FState
    else
    begin
      if FState then S := FValueCheck else S := FValueUncheck;
      Pos := 1;
      FDataLink.Field.Text := ExtractFieldName(S, Pos);
    end;
end;

function TLBDBCheckBox.ValueMatch(const ValueList, Value: string): Boolean;
var
  Pos: Integer;
begin
  Result := False;
  Pos := 1;
  while Pos <= Length(ValueList) do
    if AnsiCompareText(ExtractFieldName(ValueList, Pos), Value) = 0 then
    begin
      Result := True;
      Break;
    end;
end;


function TLBDBCheckBox.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TLBDBCheckBox.SetDataSource(Value: TDataSource);
begin
  if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
    FDataLink.DataSource := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

function TLBDBCheckBox.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;

procedure TLBDBCheckBox.SetDataField(const Value: string);
begin
  FDataLink.FieldName := Value;
end;

function TLBDBCheckBox.GetReadOnly: Boolean;
begin
//  FReadOnly:=FDataLink.ReadOnly;
  Result := FDataLink.ReadOnly;
end;

procedure TLBDBCheckBox.SetReadOnly(Value: Boolean);
begin
  FDataLink.ReadOnly := Value;
//  FReadOnly:=Value;
end;

function TLBDBCheckBox.GetField: TField;
begin
  Result := FDataLink.Field;
end;

procedure TLBDBCheckBox.KeyPress(var Key: Char);
begin
  inherited KeyPress(Key);
  case Key of
    #8, ' ':
      FDataLink.Edit;
    #27:
      FDataLink.Reset;
  end;
end;

procedure TLBDBCheckBox.SetValueCheck(const Value: string);
begin
  FValueCheck := Value;
  DataChange(Self);
end;

procedure TLBDBCheckBox.SetValueUncheck(const Value: string);
begin
  FValueUncheck := Value;
  DataChange(Self);
end;

procedure TLBDBCheckBox.WndProc(var Message: TMessage);
begin
  with Message do
    if (Msg = WM_CREATE) or (Msg = WM_WINDOWPOSCHANGED) or
      (Msg = CM_TEXTCHANGED) or (Msg = CM_FONTCHANGED) then
      FPaintControl.DestroyHandle;
  inherited;
end;

procedure TLBDBCheckBox.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if FReadOnly then Exit;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TLBDBCheckBox.MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FDataLink.Edit;
  if FReadOnly then Exit;
  inherited MouseUp(Button, Shift, X, Y);
  FState:=Checked;
  UpdateData(Self);
end;

procedure TLBDBCheckBox.WMPaint(var Message: TWMPaint);
begin
  if not (csPaintCopy in ControlState) then inherited else
  begin
    SendMessage(FPaintControl.Handle, BM_SETCHECK, Ord(GetFieldState), 0);
    SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
  end;
end;

procedure TLBDBCheckBox.CMExit(var Message: TCMExit);
begin
  try
    FDataLink.UpdateRecord;
  except
    SetFocus;
    raise;
  end;
  inherited;
end;

procedure TLBDBCheckBox.CMGetDataLink(var Message: TMessage);
begin
  Message.Result := Integer(FDataLink);
end;

function TLBDBCheckBox.ExecuteAction(Action: TBasicAction): Boolean;
begin
  Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
    FDataLink.ExecuteAction(Action);
end;

function TLBDBCheckBox.UpdateAction(Action: TBasicAction): Boolean;
begin
  Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
    FDataLink.UpdateAction(Action);
end;

end.