qcomctrlsex.pas

East make Tray Icon in delphi

procedure TCustomUpDown.SetMax(Value: SmallInt);
begin
  if Value <> FMax then
  begin
    FMax := Value;
    UpdatePosition(Position);
  end;
end;

procedure TCustomUpDown.SetMin(Value: SmallInt);
begin
  if Value <> FMin then
  begin
    FMin := Value;
    UpdatePosition(Position);
  end;
end;

procedure TCustomUpDown.SetOrientation(Value: TUDOrientation);
begin
  if Value <> FOrientation then
  begin
    FOrientation := Value;
    Invalidate;
  end;
end;

procedure TCustomUpDown.SetPosition(Value: SmallInt);
begin
  if Value <> FPosition then
  begin
    if (Max > Min) and (Value > Max) and Wrap then
      Value := Min;
    if (Max > Min) and (Value < Min) and Wrap then
      Value := Max;
    UpdatePosition(Value);
  end;
end;

procedure TCustomUpDown.UpdatePosition(Value: SmallInt);
begin
  if Value < Min then
    Value := Min;
  if (Max > Min) and (Value > Max) then
    Value := Max;

  if DoCanChange(Value, Value - FPosition) then
  begin
    FPosition := Value;

    if Associate is TCustomEdit then
    begin
      if Thousands then
        TCustomEdit(Associate).Text := IncludeThousands(IntToStr(FPosition))
      else
        TCustomEdit(Associate).Text := IntToStr(FPosition);
    end;
  end;
end;

procedure TCustomUpDown.SetThousands(Value: Boolean);
var
  Pos: Integer;
begin
  if Value <> FThousands then
  begin
    Pos := Position;
    FThousands := Value;
    UpdatePosition(Pos);
  end;
end;

function TCustomUpDown.ButtonRect(ButtonIndex: Integer): TRect;
begin
  Result := Rect(0, 0, 0, 0);
  if Orientation = udVertical then
  begin
    case ButtonIndex of
      0: Result := Rect(0, 0, Width, Height div 2);
      1: Result := Rect(0, Height div 2, Width, Height);
    end;
  end
  else
  begin
    case ButtonIndex of
      0: Result := Rect(0, 0, Width div 2, Height);
      1: Result := Rect(Width div 2, 0, Width, Height);
    end;
  end;
end;

procedure TCustomUpDown.Paint;
const
  BtnType: array[0..1, TUDOrientation] of Integer = (
    (DFCS_SCROLLLEFT, DFCS_SCROLLUP),
    (DFCS_SCROLLRIGHT, DFCS_SCROLLDOWN)
  );
var
  Flags, BtnFlags: Integer;
  R: TRect;
  Pixmap: QPixmapH;
  Painter: QPainterH;
  i: Integer;
begin
  Pixmap := QPixmap_create(Width, Height, -1, QPixmapOptimization_DefaultOptim);
  Painter := QPainter_create(Pixmap);
  try
    Flags := 0;
    if not Enabled then
      Flags := DFCS_INACTIVE;

    for i := 0 to 1 do
    begin
      R := ButtonRect(i);
      BtnFlags := 0;
      if (FButtonDown = i) and FMouseOverButton then
        BtnFlags := BtnFlags or DFCS_PUSHED;
      DrawFrameControl(Painter, R, DFC_SCROLL, BtnType[i, Orientation] or Flags or BtnFlags);
    end;
  finally
    QPainter_destroy(Painter);
    Canvas.Start;
    QPainter_drawPixmap(Canvas.Handle, 0, 0, Pixmap, 0, 0, Width, Height);
    Canvas.Stop;
  end;
end;

procedure TCustomUpDown.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  i: Integer;
begin
  if Button = mbLeft then
  begin
    for i := 0 to 1 do
      if PtInRect(ButtonRect(i), Point(X, Y)) then
      begin
        MouseCapture := True;
        FMouseOverButton := True;
        FButtonDown := i;
        ChangePosition(FButtonDown);

        FRepeatTimer.Tag := 1;
        FRepeatTimer.Enabled := True;
        Exit;
      end;
  end;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TCustomUpDown.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if (Button = mbLeft) and (FButtonDown <> -1) then
  begin
    FRepeatTimer.Enabled := False;
    FButtonDown := -1;
    MouseCapture := False;
    Paint;
  end;
  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TCustomUpDown.RepeatTimer(Sender: TObject);
begin
  if FRepeatTimer.Tag = 1 then
  begin
    FRepeatTimer.Tag := 0;
    Exit;
  end;
  if (FButtonDown <> -1) then
  begin
    FMouseOverButton := PtInRect(ButtonRect(FButtonDown), ScreenToClient(Mouse.CursorPos));
    if FMouseOverButton then
      ChangePosition(FButtonDown)
    else
      Paint;
  end;
end;

function TCustomUpDown.GetRepeatInterval: Integer;
begin
  Result := FRepeatTimer.Interval;
end;

procedure TCustomUpDown.SetRepeatInterval(Value: Integer);
begin
  if Value < 10 then
    Value := 10;
  FRepeatTimer.Interval := Value;
end;

function TCustomUpDown.AssociateHook(Sender: QObjectH;
  Event: QEventH): Boolean;
begin
  Result := False;
  if (Associate <> nil) and (Associate.HandleAllocated) then
  begin
    if Sender = Associate.Handle then
    begin
      case QEvent_type(Event) of
        QEventType_KeyPress:
          begin
            if QKeyEvent_key(QKeyEventH(Event)) = Key_Up then
            begin
              FMouseOverButton := True;
              FButtonDown := 0;
              ChangePosition(FButtonDown);
              FButtonDown := -1;
              Result := True;
            end
            else
            if QKeyEvent_key(QKeyEventH(Event)) = Key_Down then
            begin
              FMouseOverButton := True;
              FButtonDown := 1;
              ChangePosition(FButtonDown);
              FButtonDown := -1;
              Result := True;
            end;
          end;
        QEventType_KeyRelease:
          begin
            if not (QKeyEvent_isAutoRepeat(QKeyEventH(Event))) then
            begin
              if QKeyEvent_key(QKeyEventH(Event)) = Key_Up then
              begin
                FButtonDown := -1;
                Paint;
                Result := True;
              end
              else
              if QKeyEvent_key(QKeyEventH(Event)) = Key_Down then
              begin
                FButtonDown := -1;
                Paint;
                Result := True;
              end;
            end;
          end;
      end;
    end;
  end;
end;

procedure TCustomUpDown.ChangePosition(ButtonIndex: Integer);
begin
  if Orientation = udVertical then
  begin
    case ButtonIndex of
      0:
        begin
          Position := Position + Increment;
          Click(btNext);
        end;
      1:
        begin
          Position := Position - Increment;
          Click(btPrev);
        end;
    end;
  end
  else
  begin
    case ButtonIndex of
      0:
        begin
          Position := Position - Increment;
          Click(btPrev);
        end;
      1:
        begin
          Position := Position + Increment;
          Click(btNext);
        end;
    end;
  end;
  Paint;
end;

procedure TCustomUpDown.UpdateAlignment;
begin
  if Associate = nil then
    Exit;

  if AlignButton = udRight then
  begin
    Top := Associate.Top;
    Left := Associate.BoundsRect.Right + 1;
  end
  else // udLeft
  begin
    Top := Associate.Top;
    Left := Associate.Left - 1 - Width;
  end;
end;

procedure TCustomUpDown.BoundsChanged;
begin
  inherited BoundsChanged;
  if ForceAlign then
    UpdateAlignment;
end;

procedure TCustomUpDown.SetForceAlign(const Value: Boolean);
begin
  FForceAlign := Value;
  if FForceAlign then
    UpdateAlignment;
end;

end.