vrnavigator.pas

作工控的好控件

    R := Bounds(0, 0, ButtonWidth, ButtonHeight);
    if (Focused) and (Btn = FocusedButton) then
      DrawFrame3D(Bitmap.Canvas, R, FFocusColor, FFocusColor, 1)
    else DrawFrame3D(Bitmap.Canvas, R, FBorderColor, FBorderColor, 1);

    if Down then
      DrawFrame3D(Bitmap.Canvas, R, clBtnShadow, clBtnFace, 1)
    else DrawOutline3D(Bitmap.Canvas, R, Colors[0], Colors[1], 1);
  end;

  DestCanvas.Draw(BtnRect.Left, BtnRect.Top, Bitmap);
end;

procedure TVrNavigator.Paint;
var
  I: TVrButtonType;
  R: TRect;
begin
  CalcPaintParams;
  ClearBitmapCanvas;

  DestCanvas := BitmapCanvas;
  try
    with DestCanvas do
    begin
      R := ClientRect;
      FBevel.Paint(DestCanvas, R);
      for I := Low(Buttons) to High(Buttons) do
        if Buttons[I].Visible then DrawButton(I);
    end;
  finally
    DestCanvas := Self.Canvas;
  end;

  inherited Paint;
end;

procedure TVrNavigator.CalcPaintParams;
var
  Gap: Integer;
  Count: Integer;
begin
  ViewPort := ClientRect;
  FBevel.GetVisibleArea(ViewPort);
  Count := VisibleButtonCount;
  if Count > 0 then
  begin
    Gap := (Count - 1) * FSpacing;
    case FOrientation of
      voHorizontal:
        begin
          ButtonWidth := (WidthOf(ViewPort) - Gap) div Count;
          ButtonHeight := HeightOf(ViewPort);
          if Count > 1 then
            Width := (ViewPort.Left * 2) + (Count * ButtonWidth) + Gap;
        end;
      voVertical:
        begin
          ButtonWidth := WidthOf(ViewPort);
          ButtonHeight := (HeightOf(ViewPort) - Gap) div Count;
          if Count > 1 then
            Height := (ViewPort.Top * 2) + (Count * ButtonHeight) + Gap;
        end;
    end;
  end;
end;

procedure TVrNavigator.GetButtonRect(Btn: TVrButtonType; var R: TRect);
var
  X, Y: Integer;
  I: TVrButtonType;
begin
  X := ViewPort.Left;
  Y := ViewPort.Top;
  for I := Low(Buttons) to High(Buttons) do
  begin
    if Buttons[I].Visible then
    begin
      if I = Btn then Break;
      case FOrientation of
        voHorizontal: Inc(X, ButtonWidth + FSpacing);
        voVertical: Inc(Y, ButtonHeight + FSpacing);
      end;
    end;
  end;
  R := Bounds(X, Y, ButtonWidth, ButtonHeight);
end;

procedure TVrNavigator.SetFocusedButton(Btn: TVrButtonType);
var
  OrgBtn: TVrButtonType;
begin
  if FocusedButton <> Btn then
  begin
    OrgBtn := FocusedButton;
    FocusedButton := Btn;
    DrawButton(OrgBtn);
    DrawButton(FocusedButton);
  end;
end;

procedure TVrNavigator.DoMouseDown(XPos, YPos: Integer);
var
  I: TVrButtonType;
  BtnRect: TRect;
  Clicked: Boolean;
begin
  Clicked := false;
  for I := Low(Buttons) to High(Buttons) do
    if Buttons[I].Visible then
    begin
      GetButtonRect(I, BtnRect);
      if PtInRect(BtnRect, Point(XPos, YPos)) then
      begin
        if Buttons[I].Enabled then
        begin
          Clicked := True;
          Break;
        end else Exit;
      end;
    end;

  if not Clicked then Exit;

  CurrentButton := I;

  if TabStop then SetFocus;

  if CurrentButton <> FocusedButton then
    SetFocusedButton(CurrentButton);

  Pressed := True;
  Down := True;
  DrawButton(I);
  MouseCapture := True;
end;

procedure TVrNavigator.WMLButtonDown(var Message: TWMLButtonDown);
begin
  DoMouseDown(Message.XPos, Message.YPos);
end;

procedure TVrNavigator.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  DoMouseDown(Message.XPos, Message.YPos);
end;

procedure TVrNavigator.WMMouseMove(var Message: TWMMouseMove);
var
  P: TPoint;
  R: TRect;
begin
  if Pressed then
  begin
    P := Point(Message.XPos, Message.YPos);
    GetButtonRect(CurrentButton, R);
    if PtInRect(R, P) <> Down then
    begin
      Down := not Down;
      DrawButton(CurrentButton);
    end;
  end;
end;

procedure TVrNavigator.DoClick(Button: TVrButtonType);
begin
  ButtonClick(CurrentButton);
end;

procedure TVrNavigator.WMLButtonUp(var Message: TWMLButtonUp);
begin
  MouseCapture := False;
  if Pressed then
  begin
    Pressed := False;
    if Down then
    begin
      Down := False;
      DrawButton(CurrentButton);  {raise button before calling code}
      DoClick(CurrentButton);
    end;
  end;
end;

procedure TVrNavigator.WMSetFocus(var Message: TWMSetFocus);
begin
  inherited;
  DrawButton(FocusedButton);
end;

procedure TVrNavigator.WMKillFocus(var Message: TWMKillFocus);
begin
  DrawButton(FocusedButton);
  inherited;
end;

procedure TVrNavigator.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  Message.Result := DLGC_WANTARROWS;
end;

procedure TVrNavigator.KeyUp(var Key: Word; Shift: TShiftState);
begin
  case Key of
    VK_SPACE:
      if Down then
        if Buttons[FocusedButton].Enabled then
        begin
          Down := false;
          DrawButton(CurrentButton);
          DoClick(CurrentButton);
        end;
  end;
end;

procedure TVrNavigator.KeyDown(var Key: Word; Shift: TShiftState);
var
  NewFocus: TVrButtonType;
begin
  case Key of
    VK_RIGHT:
      if not Down then
      begin
        NewFocus := FocusedButton;
        repeat
          if NewFocus < High(Buttons) then
            NewFocus := Succ(NewFocus);
        until (NewFocus = High(Buttons)) or (Buttons[NewFocus].Visible);
        if Buttons[NewFocus].Visible then
          SetFocusedButton(NewFocus);
      end;
    VK_LEFT:
      if not Down then
      begin
        NewFocus := FocusedButton;
        repeat
          if NewFocus > Low(Buttons) then
            NewFocus := Pred(NewFocus);
        until (NewFocus = Low(Buttons)) or (Buttons[NewFocus].Visible);
        if Buttons[NewFocus].Visible then
          SetFocusedButton(NewFocus);
      end;
    VK_SPACE:
      begin
        if Buttons[FocusedButton].Enabled then
        begin
          CurrentButton := FocusedButton;
          Down := True;
          DrawButton(CurrentButton);
        end;
      end;
  end;
end;

procedure TVrNavigator.ButtonClick(Button: TVrButtonType);
begin
  if Assigned(FOnButtonClick) then FOnButtonClick(Self, Button);
end;

{ TVrMediaButton }

constructor TVrMediaButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque] - [csSetCaption];
  Height := 15;
  Width := 40;
  TabStop := false;
  FFocusColor := clBlue;
  FBorderColor := clBlack;
  FButtonType := btPause;
  FEnGlyphs := TBitmap.Create;
  FDiGlyphs := TBitmap.Create;
  LoadBitmaps;
end;

destructor TVrMediaButton.Destroy;
begin
  FEnGlyphs.Free;
  FDiGlyphs.Free;
  inherited Destroy;
end;

procedure TVrMediaButton.LoadBitmaps;
begin
  FEnGlyphs.Handle := LoadBitmap(hInstance, 'EN_IMAGES');
  FDiGlyphs.Handle := LoadBitmap(hInstance, 'DI_IMAGES');
  MaskColor := clOlive;
end;

procedure TVrMediaButton.SetButtonType(Value: TVrButtonType);
begin
  if FButtonType <> Value then
  begin
    FButtonType := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrMediaButton.SetFocusColor(Value: TColor);
begin
  if FFocusColor <> Value then
  begin
    FFocusColor := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrMediaButton.SetBorderColor(Value: TColor);
begin
  if FBorderColor <> Value then
  begin
    FBorderColor := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrMediaButton.Paint;
var
  R: TRect;
  GW, GH, HRes: Integer;
  Colors: array[0..1] of TColor;
  BX, BY: Integer;
  Glyph: TBitmap;
begin
  if Down then
  begin
    Colors[0] := clBtnFace;
    Colors[1] := clBtnHighlight;
  end
  else
  begin
    Colors[0] := clBtnHighlight;
    Colors[1] := clBtnShadow;
  end;

  HRes := ClientHeight div 10;
  if HRes < 2 then HRes := 2;
  R := ClientRect;
  InflateRect(R, -2, -2);
  DrawGradient(BitmapCanvas, R, Colors[0], Colors[1], voVertical, HRes);

  if Enabled then
    Glyph := FEnGlyphs else Glyph := FDiGlyphs;

  GH := Glyph.Height;
  GW := Glyph.Width div 10;
  BX := (Width div 2) - (GW div 2);
  BY := (Height div 2) - (GH div 2);
  if Down then Inc(BY);
  BitmapCanvas.Brush.Style := bsClear;
  BitmapCanvas.BrushCopy(Bounds(BX, BY, GW, GH),
    Glyph, Bounds(ord(ButtonType) * GW, 0, GW, GH), MaskColor);

  R := ClientRect;
  if HasFocus then
    DrawFrame3D(BitmapCanvas, R, FFocusColor, FFocusColor, 1)
  else DrawFrame3D(BitmapCanvas, R, FBorderColor, FBorderColor, 1);

  if Down then
    DrawFrame3D(BitmapCanvas, R, clBtnShadow, clBtnFace, 1)
  else DrawOutline3D(BitmapCanvas, R, Colors[0], Colors[1], 1);

  inherited Paint;
end;

procedure TVrMediaButton.DoMouseDown(XPos, YPos: Integer);
var
  P: TPoint;
begin
  P := Point(XPos, YPos);
  if PtInRect(ClientRect, P) then
  begin
    Pressed := True;
    Down := True;
    MouseCapture := true;
    UpdateControlCanvas;
  end;
end;

procedure TVrMediaButton.WMLButtonDown(var Message: TWMLButtonDown);
begin
  inherited;
  DoMouseDown(Message.XPos, Message.YPos);
  if TabStop then SetFocus;
end;

procedure TVrMediaButton.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  inherited;
  DoMouseDown(Message.XPos, Message.YPos);
end;

procedure TVrMediaButton.WMMouseMove(var Message: TWMMouseMove);
var
  P: TPoint;
begin
  inherited;
  if Pressed then
  begin
    P := Point(Message.XPos, Message.YPos);
    if PtInRect(ClientRect, P) <> Down then
    begin
      Down := not Down;
      UpdateControlCanvas;
    end;
  end;
end;

procedure TVrMediaButton.WMLButtonUp(var Message: TWMLButtonUp);
var
  DoClick: Boolean;
begin
  MouseCapture := false;
  DoClick := Pressed and Down;
  Down := False;
  Pressed := false;
  if DoClick then UpdateControlCanvas;
  inherited;
end;

procedure TVrMediaButton.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  UpdateControlCanvas;
end;

procedure TVrMediaButton.WMSetFocus(var Message: TWMSetFocus);
begin
  HasFocus := true;
  UpdateControlCanvas;
  inherited;
end;

procedure TVrMediaButton.WMKillFocus(var Message: TWMKillFocus);
begin
  HasFocus := false;
  UpdateControlCanvas;
  inherited;
end;

procedure TVrMediaButton.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited KeyDown(Key, Shift);
  if (not Down) and (Key = VK_SPACE) then DoMouseDown(0, 0);
end;

procedure TVrMediaButton.KeyUp(var Key: Word; Shift: TShiftState);
begin
  inherited KeyUp(Key, Shift);
  if Key = VK_SPACE then
  begin
    MouseCapture := false;
    if Pressed and Down then
    begin
      Down := False;
      UpdateControlCanvas;
      inherited Click;
    end;
    Pressed := False;
  end;
end;


end.