lbctrls.pas

天涯進銷存系統

      LineTo((width+X-2) div 2-5, Height div 2-3);
      MoveTo((width+X-2) div 2, Height div 2+3);
      LineTo((width+X-2) div 2-5, Height div 2-2);
      MoveTo((width+X-2) div 2, Height div 2+3);
      LineTo((width+X-2) div 2+5, Height div 2-2);
      MoveTo((width+X-2) div 2-1, Height div 2+2);
      LineTo((width+X-2) div 2+4, Height div 2-3);
      MoveTo((width+X-2) div 2, Height div 2+2);
      LineTo((width+X-2) div 2+4, Height div 2-2);
    end;
  end;
  end;
end;

procedure TLBComboBox.PaintBorder;
var
  DC: HDC;
  R: TRect;
  BtnFaceBrush, WindowBrush: HBRUSH;
begin
  DC := GetWindowDC(Handle);

  GetWindowRect(Handle, R);
  OffsetRect(R, -R.Left, -R.Top);
  Dec(R.Right, FButtonWidth + 1);
  try
    BtnFaceBrush := CreateSolidBrush(ColorToRGB(FBorderColor));
    WindowBrush := CreateSolidBrush(ColorToRGB(Color));

    FrameRect(DC, R, BtnFaceBrush);
    InflateRect(R, -1, -1);
    FrameRect(DC, R, WindowBrush);
    InflateRect(R, -1, -1);
    FrameRect(DC, R, WindowBrush);
  finally
    ReleaseDC(Handle, DC);
  end;
  DeleteObject(WindowBrush);
  DeleteObject(BtnFaceBrush);
end;

function TLBComboBox.GetSolidBorder: Boolean;
begin
  Result := ( (csDesigning in ComponentState) and Enabled) or
    (not(csDesigning in ComponentState) and
    (DroppedDown or (GetFocus = Handle) or (GetFocus = EditHandle)) );
end;

procedure TLBComboBox.SetSolidBorder;
var
  sb: Boolean;
begin
  sb := GetSolidBorder;
  if sb <> FSolidBorder then
  begin
    FSolidBorder := sb;
    RedrawBorders;
  end;
end;

procedure TLBComboBox.RedrawBorders;
begin
  PaintBorder;
  if Style <> csSimple then
    PaintButton;
end;

var
  MouseTimer: TTimer = nil;
  MouseInControl: TLBButton = nil;
  ControlCounter: Integer = 0;

  MouseInspControl: TLBSpeecButton = nil;

constructor TLBButton.Create (AOwner: TComponent);
begin
  inherited Create(AOwner);
  if MouseTimer = nil then
  begin
    MouseTimer := TTimer.Create(nil);
    MouseTimer.Enabled := False;
    MouseTimer.Interval := 100; // 10 times a second
  end;
  SetBounds(0, 0, 62, 19);
  ControlStyle := [csCaptureMouse, csOpaque, csDoubleClicks];
  ParentFont := True;
  ParentColor := True;
  FSpacing := 4;
  FMargin := -1;
  FLayout := blGlyphTop;
  FModalResult := mrNone;
  Inc(ControlCounter);
end;

destructor TLBButton.Destroy;
begin
  RemoveMouseTimer;
  Dec(ControlCounter);
  if ControlCounter = 0 then
  begin
    MouseTimer.Free;
    MouseTimer := nil;
  end;
  inherited Destroy;
end;

procedure TLBButton.Paint;
const
  Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
  FImageList: TImageList;
  PaintRect: TRect;
  Flags: Longint;
  FontHeight: integer;
  FAlignment: TAlignment;
begin
  FAlignment:=taCenter;
    if not Enabled then
    begin
      FState := bsDisabled;
      FDragging := False;
    end
    else
      if FState = bsDisabled then
        if FDown  then
          FState := bsExclusive
        else
          FState := bsUp;

    // DrawBorder
    with Canvas do
    begin
      Pen.Color:=Rgb(0, 60, 115);
      Brush.Color:=Rgb(247, 243, 239);
      RoundRect(0, 0, Width,Height, 5, 5);
      Pen.Color:=Rgb(123, 150, 173);
      Rectangle(0,1,2,2);
      Rectangle(1,0,2,2);
      Rectangle(0,Height-1,2,Height-2);
      Rectangle(1,Height,2,Height-2);
      Rectangle(Width-2,0,Width-1,2);
      Rectangle(Width-2,1,Width,2);
      Rectangle(Width,Height-1,Width-2,Height-2);
      Rectangle(Width-1,Height,Width-2,Height-2);

      Pen.Color:=Rgb(198, 207, 222);
      MoveTo(2,1);
      LineTo(2,2);
      MoveTo(1,2);
      LineTo(2,2);
      MoveTo(Width-3,1);
      LineTo(Width-3,2);
      MoveTo(Width-2,2);
      LineTo(Width-3,2);

      Pen.Color:=Rgb(165, 174, 181);
      MoveTo(2,Height-2);
      LineTo(2,Height-3);
      MoveTo(1,Height-3);
      LineTo(2,Height-3);
      MoveTo(Width-3,Height-2);
      LineTo(Width-3,Height-3);
      MoveTo(Width-2,Height-3);
      LineTo(Width-3,Height-3);

      Pen.Color:=Rgb(214, 211, 198);
      MoveTo(3,Height-2);
      LineTo(Width-3,Height-2);

      Pen.Color:=Rgb(231, 223, 214);
      MoveTo(2,Height-3);
      LineTo(Width-2,Height-3);

      Pen.Color:=Rgb(239, 231, 222);
      MoveTo(Width-2,3);
      LineTo(Width-2,Height-3);

      Pen.Color:=Rgb(239, 235, 231);
      MoveTo(1,Height-4);
      LineTo(Width-1,Height-4);

      Pen.Color:=Rgb(255, 255, 255);
      MoveTo(3,1);
      LineTo(Width-3,1);
    end;
    case FState of
      bsUp:
        if FMouseInControl then
        with Canvas do
        begin
          Pen.Color:=Rgb(206,231, 255);
          Canvas.MoveTo(2, 1);
          Canvas.LineTo(Width-2, 1);
          Pen.Color:=Rgb(107, 130, 239);
          MoveTo(2,Height-2);
          LineTo(Width-2,Height-2);
          Pen.Color:=Rgb(140, 174, 231);
          MoveTo(1,Height-3);
          LineTo(Width-1,Height-3);
          Pen.Color:=Rgb(181, 207, 247);
          MoveTo(Width-2,2);
          LineTo(Width-2,Height-3);
          MoveTo(1,2);
          LineTo(1,Height-3);
        end;
      bsDown, bsExclusive:
      begin
        with Canvas do
        begin
          Pen.Color:=Rgb(255,243, 206);
          Canvas.MoveTo(2, 1);
          Canvas.LineTo(Width-2, 1);
          Pen.Color:=Rgb(231, 150, 0);
          MoveTo(2,Height-2);
          LineTo(Width-2,Height-2);
          Pen.Color:=Rgb(255, 178, 49);
          MoveTo(1,Height-3);
          LineTo(Width-1,Height-3);
          Pen.Color:=Rgb(255, 219, 140);
          MoveTo(Width-2,2);
          LineTo(Width-2,Height-3);
          MoveTo(1,2);
          LineTo(1,Height-3);
        end;
      end;
    end;
   FontHeight := Canvas.TextHeight('W');
  Canvas.Font := Font;
  PaintRect := Rect(2, 0, Width, Height);
  with PaintRect do
  begin
    Top := ((Bottom + Top) - FontHeight) div 2;
    Bottom := Top + FontHeight;
  end;
  Flags := DT_EXPANDTABS or DT_VCENTER or Alignments[FAlignment];
  Flags := DrawTextBiDiModeFlags(Flags);
  DrawText(Canvas.Handle, PChar(Caption), -1, PaintRect, Flags);
end;

procedure TLBButton.UpdateTracking;
var
  P: TPoint;
begin
  if Enabled then
  begin
    GetCursorPos(P);
    FMouseInControl := not (FindDragTarget(P, True) = Self);
    if FMouseInControl then
      MouseLeave
    else
      MouseEnter;
  end;
end;

procedure TLBButton.Loaded;
begin
  inherited Loaded;
  Invalidate;
end;

procedure TLBButton.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) and Enabled then
  begin
    if not FDown then
    begin
      FState := bsDown;
      Invalidate;
    end;
    FDragging := True;
  end;
end;

procedure TLBButton.MouseMove (Shift: TShiftState; X, Y: Integer);
var
  NewState: TButtonState;
  P: TPoint;
begin
  inherited;

  // mouse is in control ?
  P := ClientToScreen(Point(X, Y));
  if (MouseInControl <> Self) and (FindDragTarget(P, True) = Self) then
  begin
    if Assigned(MouseInControl) then
      MouseInControl.MouseLeave;
    // the application is active ?
    if (GetActiveWindow <> 0) then
    begin
      if MouseTimer.Enabled then
        MouseTimer.Enabled := False;
      MouseInControl := Self;
      MouseTimer.OnTimer := MouseTimerHandler;
      MouseTimer.Enabled := True;
      MouseEnter;
    end;
  end;

  if FDragging then
  begin
    if not FDown then
      NewState := bsUp
    else
      NewState := bsExclusive;
    if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
      if FDown then
        NewState := bsExclusive
      else
        NewState := bsDown;
    if NewState <> FState then
    begin
      FState := NewState;
      Invalidate;
    end;
  end;
end;

procedure TLBButton.MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  DoClick: Boolean;
begin
  inherited MouseUp(Button, Shift, X, Y);
  if FDragging then
  begin
    FDragging := False;
    DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
    if FGroupIndex = 0 then
    begin
      // Redraw face in-case mouse is captured
      FState := bsUp;
      FMouseInControl := False;
      if DoClick and not (FState in [bsExclusive, bsDown]) then
        Invalidate;
    end
    else
    begin
      if DoClick then
      begin
        SetDown(not FDown);
        if FDown then Repaint;
      end
      else
      begin
        if FDown then FState := bsExclusive;
        Repaint;
      end;
    end;
    if DoClick then Click else MouseLeave;
    UpdateTracking;
  end;
end;

procedure TLBButton.Click;
begin
  if Parent <> nil then
    GetParentForm(self).ModalResult := FModalResult;
  inherited Click;
end;



procedure TLBButton.SetDown (Value: Boolean);
begin
  if Value <> FDown then
  begin
    if FDown and (not FAllowAllUp) then Exit;
    FDown := Value;
    if Value then
    begin
      if FState = bsUp then Invalidate;
      FState := bsExclusive
    end
    else
    begin
      FState := bsUp;
      Repaint;
    end;
  end;
end;


procedure TLBButton.SetLayout (Value: TButtonLayout);
begin
  if FLayout <> Value then
  begin
    FLayout := Value;
    Invalidate;
  end;
end;

procedure TLBButton.SetGroupIndex (Value: Integer);
begin
  if FGroupIndex <> Value then
  begin
    FGroupIndex := Value;
   // UpdateExclusive;
  end;
end;

procedure TLBButton.SetMargin (Value: Integer);
begin
  if (Value <> FMargin) and (Value >= -1) then
  begin
    FMargin := Value;
    Invalidate;
  end;
end;

procedure TLBButton.SetSpacing (Value: Integer);
begin
  if Value <> FSpacing then
  begin
    FSpacing := Value;
    Invalidate;
  end;
end;

procedure TLBButton.SetAllowAllUp (Value: Boolean);
begin
  if FAllowAllUp <> Value then
  begin
    FAllowAllUp := Value;
  end;
end;

procedure TLBButton.WMLButtonDblClk (var Message: TWMLButtonDown);
begin
  inherited;
  if FDown then DblClick;
end;

procedure TLBButton.CMEnabledChanged (var Message: TMessage);
begin
  inherited;
  if not Enabled then
  begin
    FMouseInControl := False;
    FState := bsDisabled;
    RemoveMouseTimer;
  end;
  UpdateTracking;
  Invalidate;
end;


procedure TLBButton.CMDialogChar (var Message: TCMDialogChar);
begin
  with Message do
    if IsAccel(CharCode, Caption) and Enabled then
    begin
      Click;
      Result := 1;
    end else
      inherited;
end;

procedure TLBButton.CMFontChanged (var Message: TMessage);