qcomctrlsex.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: QToolWin.pas, released on 2004-05-16

The Initial Developer of the Original Code is Andreas Hausladen
                                              [Andreas dott Hausladen att gmx dott de]
Copyright (C) 2004 Andreas Hausladen.
All Rights Reserved.

Contributor(s):

Known Issues:
----------------------------------------------------------------------------}
// $Id: QComCtrlsEx.pas,v 1.3 2004/11/06 22:12:35 asnepvangers Exp $

unit QComCtrlsEx;

interface

uses
  SysUtils, Classes, Contnrs, Types, Qt, QGraphics, QControls, QForms,
  QStdCtrls, QExtCtrls, QComboEdits, QWindows;

type
  TUDAlignButton = (udLeft, udRight);
  TUDOrientation = (udHorizontal, udVertical);
  TUDBtnType = (btNext, btPrev);
  TUpDownDirection = (updNone, updUp, updDown);
  TUDClickEvent = procedure (Sender: TObject; Button: TUDBtnType) of object;
  TUDChangingEvent = procedure (Sender: TObject; var AllowChange: Boolean) of object;
  TUDChangingEventEx = procedure (Sender: TObject; var AllowChange: Boolean;
    NewValue: SmallInt; Direction: TUpDownDirection) of object;

  TCustomUpDown = class(TCustomControl)
  private
    FArrowKeys: Boolean;
    FAssociate: TWidgetControl;
    FMin: SmallInt;
    FMax: SmallInt;
    FIncrement: Integer;
    FNewValue: SmallInt;
    FNewValueDelta: SmallInt;
    FPosition: SmallInt;
    FThousands: Boolean;
    FWrap: Boolean;
    FOnClick: TUDClickEvent;
    FAlignButton: TUDAlignButton;
    FOrientation: TUDOrientation;
    FOnChanging: TUDChangingEvent;
    FOnChangingEx: TUDChangingEventEx;

    FButtonDown: Integer;
    FMouseOverButton: Boolean;
    FRepeatTimer: TTimer;
    FForceAlign: Boolean;

    procedure SetAssociate(Value: TWinControl);
    function GetPosition: SmallInt;
    procedure SetMin(Value: SmallInt);
    procedure SetMax(Value: SmallInt);
    procedure SetPosition(Value: SmallInt);
    procedure SetAlignButton(Value: TUDAlignButton);
    procedure SetOrientation(Value: TUDOrientation);
    procedure SetArrowKeys(Value: Boolean);
    procedure SetThousands(Value: Boolean);
    function GetRepeatInterval: Integer;
    procedure SetRepeatInterval(Value: Integer);
    procedure SetForceAlign(const Value: Boolean);
  protected
    function AssociateHook(Sender: QObjectH; Event: QEventH): Boolean; virtual;
    procedure Paint; override;
    procedure UpdatePosition(Value: SmallInt); virtual;
    procedure UpdateAlignment; virtual;
    function ButtonRect(ButtonIndex: Integer): TRect; virtual;
    procedure RepeatTimer(Sender: TObject); virtual;
    procedure ChangePosition(ButtonIndex: Integer);
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X: Integer; Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure BoundsChanged; override;

    function DoCanChange(NewVal: SmallInt; Delta: SmallInt): Boolean; virtual;
    function CanChange: Boolean; dynamic;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Click(Button: TUDBtnType); reintroduce; dynamic;
    property AlignButton: TUDAlignButton read FAlignButton write SetAlignButton default udRight;
    property ArrowKeys: Boolean read FArrowKeys write SetArrowKeys default True;
    property Associate: TWidgetControl read FAssociate write SetAssociate;
    property Min: SmallInt read FMin write SetMin default 0;
    property Max: SmallInt read FMax write SetMax default 100;
    property Increment: Integer read FIncrement write FIncrement default 1;
    property Orientation: TUDOrientation read FOrientation write SetOrientation default udVertical;
    property Position: SmallInt read GetPosition write SetPosition default 0;
    property Thousands: Boolean read FThousands write SetThousands default True;
    property Wrap: Boolean read FWrap write FWrap default False;
    property OnChanging: TUDChangingEvent read FOnChanging write FOnChanging;
    property OnChangingEx: TUDChangingEventEx read FOnChangingEx write FOnChangingEx;
    property OnClick: TUDClickEvent read FOnClick write FOnClick;

    // exclusive for VisualCLX
    property RepeatInterval: Integer read GetRepeatInterval write SetRepeatInterval default 125;
    property ForceAlign: Boolean read FForceAlign write SetForceAlign default False;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  TUpDown = class(TCustomUpDown)
  published
    property AlignButton;
    property Anchors;
    property Associate;
    property ArrowKeys;
    property Enabled;
    property Hint;
    property Min;
    property Max;
    property Increment;
    property Constraints;
    property Orientation;
    property ParentShowHint;
    property PopupMenu;
    property Position;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Thousands;
    property Visible;
    property Wrap;
    property OnChanging;
    property OnChangingEx;
    property OnContextPopup;
    property OnClick;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

implementation

uses
  Math;

function ExcludeThousands(const Text: string): string;
var
  Len, i: Integer;
begin
  Result := Text;
  Len := Length(Result);
  if Len > 4 then
  begin
    i := Len - 3;
    while (i > 1) do
    begin
      if Result[i] = ThousandSeparator then
        Delete(Result, i, 1);
      Dec(i, 2);
    end;
  end;
end;

function IncludeThousands(const Text: string): string;
var
  Len, i: Integer;
begin
  Result := Text;
  Len := Length(Result);
  if Len > 3 then
  begin
    i := Len - 2;
    while (i > 1) do
    begin
      Insert(ThousandSeparator, Result, i);
      Dec(i, 3);
    end;
  end;
end;

{ TCustomUpDown }

constructor TCustomUpDown.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle - [csDoubleClicks];
  FThousands := True;
  FButtonDown := -1;
  FPosition := 0;
  FMin := 0;
  FMax := 100;
  FIncrement := 1;

  FAlignButton := udRight;
  FOrientation := udVertical;
  Width := GetSystemMetrics(SM_CXVSCROLL);
  Height := GetSystemMetrics(SM_CYVSCROLL) - 2; // is SM_CYVSCROLL wrong or is it just Qt
  Height := Height + (Height div 2);

  FRepeatTimer := TTimer.Create(Self);
  FRepeatTimer.Interval := 125;
  FRepeatTimer.OnTimer := RepeatTimer;
  InputKeys := InputKeys + [ikArrows];
  FArrowKeys := False;
end;

destructor TCustomUpDown.Destroy;
begin
  inherited Destroy;
end;

function TCustomUpDown.CanChange: Boolean;
var
  Direction: TUpDownDirection;
begin
  Result := True;
  Direction := updNone;

  if (FNewValue < Min) and (FNewValueDelta < 0) or
     (FNewValue > Max) and (FNewValueDelta > 0) then
    Direction := updNone
  else if FNewValueDelta < 0 then
    Direction := updDown
  else if FNewValueDelta > 0 then
    Direction := updUp;

  if Assigned(FOnChanging) then
    FOnChanging(Self, Result);
  if Assigned(FOnChangingEx) then
    FOnChangingEx(Self, Result, FNewValue, Direction);
end;

procedure TCustomUpDown.Click(Button: TUDBtnType);
begin
  if Assigned(FOnClick) then
    FOnClick(Self, Button);
end;

function TCustomUpDown.DoCanChange(NewVal, Delta: SmallInt): Boolean;
begin
  FNewValue := NewVal;
  FNewValueDelta := Delta;
  Result := CanChange;
end;

function TCustomUpDown.GetPosition: SmallInt;
var
  ErrCode: Integer;
begin
  if Associate is TCustomEdit then
  begin
    if Thousands then
      Val(ExcludeThousands(TCustomEdit(Associate).Text), Result, ErrCode)
    else
      Val(TCustomEdit(Associate).Text, Result, ErrCode);
    if ErrCode = 0 then
      FPosition := Result;
  end;
  Result := FPosition;
end;

procedure TCustomUpDown.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  if (Operation = opRemove) and (AComponent = Associate) then
    Associate := nil;
  inherited Notification(AComponent, Operation);
end;

procedure TCustomUpDown.SetAlignButton(Value: TUDAlignButton);
begin
  if Value <> FAlignButton then
  begin
    FAlignButton := Value;
    UpdateAlignment;
  end;
end;

procedure TCustomUpDown.SetArrowKeys(Value: Boolean);
begin
  if Value <> FArrowKeys then
  begin
    if Value then
      InputKeys := InputKeys + [ikArrows]
    else
      InputKeys := InputKeys - [ikArrows];
    FArrowKeys := Value;
  end;
end;

procedure TCustomUpDown.SetAssociate(Value: TWinControl);
begin
  if Value <> FAssociate then
  begin
    if FAssociate <> nil then
      FAssociate.RemoveFreeNotification(Self);
    FAssociate := Value;
    if FAssociate <> nil then
    begin
      FAssociate.FreeNotification(Self);
      UpdateAlignment;
      UpdatePosition(Position);
    end;
  end;
end;