lbctrls.pas

天涯進銷存系統

    destructor Destroy; override;
  published
    property Caption;
    property Checked: Boolean read FChecked write SetChecked default False;
    property Color default $00E1EAEB;
    property Enabled;
    property Font;
    property Hint;
    property ParentColor;
    property ParentFont;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;


  TLBSpeecButtonActionLink = class(TControlActionLink)
  protected
    FClient: TLBSpeecButton;
    procedure AssignClient(AClient: TObject); override;
    function IsCheckedLinked: Boolean; override;
    function IsGroupIndexLinked: Boolean; override;
    procedure SetGroupIndex(Value: Integer); override;
    procedure SetChecked(Value: Boolean); override;
  end;

  TLBEditButton=class(TLBSpeecButton)
  private
    FLBEdit: TLBEdit;
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure Paint;Override;
  public
    constructor Create (AOwner: TComponent); override;
  published
    property LBEdit: TLBEdit read FLBEdit write FLBEdit;
  end;

  type
    TScrollType = (Up, Down);

  TLBListBox = class(TCustomControl)
  private
    cWheelMessage: Cardinal;
    ScrollType: TScrollType;
    firstItem: Integer;
    maxItems: Integer;
    FSorted: Boolean;
    FItems: TStringList;
    FItemsRect: TList;
    FItemsHeight: Integer;
    FSelected: set of Byte;
    FMultiSelect: Boolean;
    FScrollBars: Boolean;
    FUseAdvColors: Boolean;
    FAdvColorBorder: TAdvColors;
    FArrowColor: TColor;
    FBorderColor: TColor;
    FItemsRectColor: TColor;
    FItemsSelectColor: TColor;
    procedure SetColors (Index: Integer; Value: TColor);
    procedure SetAdvColors (Index: Integer; Value: TAdvColors);
    procedure SetUseAdvColors (Value: Boolean);
    procedure SetSorted (Value: Boolean);
    procedure SetItems (Value: TStringList);
    procedure SetItemsRect;
    procedure SetItemsHeight (Value: Integer);
    function GetSelected (Index: Integer): Boolean;
    procedure SetSelected (Index: Integer; Value: Boolean);
    function GetSelCount: Integer;
    procedure SetScrollBars (Value: Boolean);
    procedure WMSize (var Message: TWMSize); message WM_SIZE;
    procedure CMEnabledChanged (var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMSysColorChange (var Message: TMessage); message CM_SYSCOLORCHANGE;
    procedure CMParentColorChanged (var Message: TWMNoParams); message CM_PARENTCOLORCHANGED;
    procedure ScrollTimerHandler (Sender: TObject);
    procedure ItemsChanged (Sender: TObject);
    procedure WMMouseWheel(var Message: TMessage); message WM_MOUSEWHEEL;
  protected
    procedure CalcAdvColors;
    procedure DrawScrollBar (canvas: TCanvas);
    procedure Paint; override;
    procedure Loaded; override;
    procedure MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure WndProc (var Message: TMessage); override;
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    property Selected [Index: Integer]: Boolean read GetSelected write SetSelected;
    property SelCount: Integer read GetSelCount;
  published
    property Align;
    property Items: TStringList read FItems write SetItems;
    property ItemHeight: Integer read FItemsHeight write SetItemsHeight default 17;
    property MultiSelect: Boolean read FMultiSelect write FMultiSelect default false;
    property ScrollBars: Boolean read FScrollBars write SetScrollBars default false;
    property Color default $00E1EAEB;
    property ColorArrow: TColor index 0 read FArrowColor write SetColors default clBlack;
    property ColorBorder: TColor index 1 read FBorderColor write SetColors default $008396A0;
    property ColorItemsRect: TColor index 2 read FItemsRectColor write SetColors default clWhite;
    property ColorItemsSelect: TColor index 3 read FItemsSelectColor write SetColors default $009CDEF7;
    property AdvColorBorder: TAdvColors index 0 read FAdvColorBorder write SetAdvColors default 40;
    property UseAdvColors: Boolean read FUseAdvColors write SetUseAdvColors default false;
    property Sorted: Boolean read FSorted write SetSorted default false;
    property Font;
    property ParentFont;
    property ParentColor;
    property Enabled;
    property Visible;
    property PopupMenu;
    property ShowHint;

    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
  end;


var
  ScrollTimer: TTimer = nil;

const
  FTimerInterval = 600; 
  FScrollSpeed = 100;

function DefaultCurrencyDisplayFormat: string;
  
implementation

{$R LBCheckBox.res}

function DefaultCurrencyDisplayFormat: string;
var
  CurrStr: string;
  I: Integer;
  C: Char;
begin
  if CurrencyDecimals > 0 then
  begin
    SetLength(Result, CurrencyDecimals);
    FillChar(Result[1], Length(Result), '0');
  end
  else
    Result := '';
  Result := ',0.' + Result;
  CurrStr := '';
  for I := 1 to Length(CurrencyString) do
  begin
    C := CurrencyString[I];
    if C in [',', '.'] then CurrStr := CurrStr + '''' + C + ''''
    else CurrStr := CurrStr + C;
  end;
  if Length(CurrStr) > 0 then
    case CurrencyFormat of
      0: Result := CurrStr + Result; { '$1' }
      1: Result := Result + CurrStr; { '1$' }
      2: Result := CurrStr + ' ' + Result; { '$ 1' }
      3: Result := Result + ' ' + CurrStr; { '1 $' }
    end;
  Result := Format('%s;-%s', [Result, Result]);
end;

constructor TLBEdit.Create (AOwner: TComponent);
begin
  inherited;
  ParentFont := True;
  FBorderColor := clBackground;
  FParentColor := True;
  FEnterTab :=True;
  AutoSize := False;
  Ctl3D := False;
  BorderStyle := bsNone;
  ControlStyle := ControlStyle - [csFramed];
  SetBounds(0, 0, 121, 19);
end;

procedure TLBEdit.SetParentColor (Value: Boolean);
begin
  if Value <> FParentColor then
  begin
    FParentColor := Value;
    if FParentColor then
    begin
      RedrawBorder(0);
    end;
  end;
end;

procedure TLBEdit.CMSysColorChange (var Message: TMessage);
begin
  RedrawBorder(0);
end;

procedure TLBEdit.CMParentColorChanged (var Message: TWMNoParams);
begin
  RedrawBorder(0);
end;


procedure TLBEdit.KeyDown(var Key: Word;  Shift: TShiftState);
begin
  inherited KeyDown(Key, Shift);
end;

procedure TLBEdit.SetColors (Index: Integer; Value: TColor);
begin
  case Index of
    1: FBorderColor := Value;
  end;
  if Index = 2 then
    FParentColor := False;
  RedrawBorder(0);
end;

procedure TLBEdit.SetEnterTab(Value: Boolean);
begin
  FEnterTab:= Value;
end;

procedure TLBEdit.CMMouseEnter (var Message: TMessage);
begin
  inherited;
  if (GetActiveWindow <> 0) then
  begin
    MouseInControl := True;
    RedrawBorder(0);
  end;
end;

procedure TLBEdit.CMMouseLeave (var Message: TMessage);
begin
  inherited;
  MouseInControl := False;
  RedrawBorder(0);
end;

procedure TLBEdit.NewAdjustHeight;
var
  DC: HDC;
  SaveFont: HFONT;
  Metrics: TTextMetric;
begin
  DC := GetDC(0);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Metrics);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);

  Height := Metrics.tmHeight + 6;
end;

procedure TLBEdit.Loaded;
begin
  inherited;
  if not(csDesigning in ComponentState) then
    NewAdjustHeight;
end;

procedure TLBEdit.CMEnabledChanged (var Message: TMessage);
const
  EnableColors: array[Boolean] of TColor= (clBtnFace, clWindow);
begin
  inherited;
  Color := EnableColors[Enabled];
  RedrawBorder(0);
end;

procedure TLBEdit.CMFontChanged (var Message: TMessage);
begin
  inherited;
  if not((csDesigning in ComponentState) and (csLoading in ComponentState)) then
    NewAdjustHeight;
end;

procedure TLBEdit.WMSetFocus (var Message: TWMSetFocus);
begin
  inherited;
{  if not(csDesigning in ComponentState) then
    RedrawBorder(0);}
end;

procedure TLBEdit.WMKillFocus (var Message: TWMKillFocus);
begin
  inherited;
  if not(csDesigning in ComponentState) then
    RedrawBorder(0);
end;

procedure TLBEdit.WMNCCalcSize (var Message: TWMNCCalcSize);
begin
  inherited;
  InflateRect(Message.CalcSize_Params^.rgrc[0], -3, -3);
end;

procedure TLBEdit.WMNCPaint (var Message: TMessage);
begin
  inherited;
  RedrawBorder(HRGN(Message.WParam));
end;

procedure TLBEdit.RedrawBorder (const Clip: HRGN);
var
  DC: HDC;
  R, R1, R2: TRect;
  BtnFaceBrush, WindowBrush, FocusBrush: HBRUSH;
begin
  DC := GetWindowDC(Handle);
  try
    GetWindowRect(Handle, R);
    OffsetRect(R, -R.Left, -R.Top);
    BtnFaceBrush := CreateSolidBrush(ColorToRGB(FBorderColor));
    WindowBrush := CreateSolidBrush(ColorToRGB(Color));
    FocusBrush := CreateSolidBrush(ColorToRGB(Color));
    if (not(csDesigning in ComponentState) and
      (Focused or (MouseInControl and not(Screen.ActiveControl is TLBEdit)))) then
    begin
      FrameRect(DC, R, BtnFaceBrush);
      InflateRect(R, -1, -1);
      FrameRect(DC, R, FocusBrush);
      InflateRect(R, -1, -1);
      FrameRect(DC, R, FocusBrush);
    end
    else
    begin
      { non Focus }
      FrameRect(DC, R, BtnFaceBrush);
      InflateRect(R, -1, -1);
      FrameRect(DC, R, WindowBrush);
      InflateRect(R, -1, -1);
      FrameRect(DC, R, WindowBrush);
    end;
  finally
    ReleaseDC(Handle, DC);
  end;
  DeleteObject(WindowBrush);
  DeleteObject(BtnFaceBrush);
  DeleteObject(FocusBrush);
end;


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

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

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

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

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

procedure TLBNumberEdit.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 TLBNumberEdit.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 TLBNumberEdit.SetEditDisplayFormat(const Value: string);
begin
  if FDisplayFormat <> Value then
  begin
    FDisplayFormat := Value;
  end;
end;

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

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