source: trunk/Packages/CevoComponents/DrawDlg.pas

unit DrawDlg;

interface

uses
  Classes, SysUtils, LCLIntf, LCLType, {$IFDEF UNIX}LMessages,{$ENDIF}
  Messages, ButtonBase, ButtonA, ButtonB, Area, ScreenTools
  {$IFDEF LCLGTK2}, Gtk2Globals{$ENDIF},
  {$IFDEF DPI}Dpi.Forms, Dpi.Common, Dpi.Graphics, Dpi.Controls{$ELSE}
  Forms, Graphics, Controls{$ENDIF};

type
  { TDrawDlg }

  TDrawDlg = class(TForm)
  private
    MoveFormPos: TPoint;
    MoveMousePos: TPoint;
    MoveActive: Boolean;
    procedure VisibleChangedHandler(Sender: TObject);
    procedure DoDeactivate(Sender: TObject);
  protected
    // Defines area to grip the window for moving (from top)
    TitleHeight: Integer;
    procedure InitButtons;
    procedure OnEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseLeave; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SmartInvalidate; virtual;
    procedure CenterToScreen; overload;
    procedure CenterToScreen(AWidth, AHeight: Integer); overload;
  end;

  { TBaseMessgDlg }

  TBaseMessgDlg = class(TDrawDlg)
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  protected
    Lines: Integer;
    TopSpace: Integer;
    procedure SplitText(Preview: Boolean);
    procedure CorrectHeight;
  public
    MessgText: string;
  end;

const
  Border = 3;
  MessageLineSpacing = 20;

procedure Register;


implementation

procedure Register;
begin
  RegisterNoIcon([TDrawDlg]);
  RegisterNoIcon([TBaseMessgDlg]);
end;

{ TDrawDlg }

constructor TDrawDlg.Create(AOwner: TComponent);
begin
  inherited;
  Color := clBlack;
  TitleHeight := 0;
  MoveActive := False;
  AddHandlerOnVisibleChanged(VisibleChangedHandler);
  {$IFDEF UNIX}
  OnDeactivate := DoDeactivate;
  {$ENDIF}
end;

destructor TDrawDlg.Destroy;
begin
  RemoveHandlerOnVisibleChanged(VisibleChangedHandler);
  inherited;
end;

procedure TDrawDlg.OnEraseBkgnd(var Msg: TMessage);
begin
  // Full area should be covered by Paint method
end;

procedure TDrawDlg.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
var
  MousePos1: TPoint;
  MousePos2: TPoint;
  NewFormPos: TPoint;
begin
  MousePos1 := Mouse.CursorPos;
  inherited;
  MousePos2 := Mouse.CursorPos;
  if not Assigned(OnMouseDown) or not Assigned(OnMouseMove) or not Assigned(OnMouseUp) then begin
    NewFormPos := ScreenToClient(Mouse.CursorPos);
    if (NewFormPos.X >= 0) and (NewFormPos.X < Width) and
      (NewFormPos.Y >= 0) and (NewFormPos.Y < Height) and
      (NewFormPos.Y < TitleHeight) then begin
      MoveMousePos := ClientToScreen(Point(X, Y));
      MoveFormPos := Point(Left, Top);
      // Activate move only if mouse position was not changed during inherited call
      if (MousePos1.X = MousePos2.X) and (MousePos1.Y = MousePos2.Y) then begin
        MoveActive := True;
      end;
    end else MoveActive := False;
  end;
end;

procedure TDrawDlg.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  MousePos: TPoint;
begin
  inherited;
  if MoveActive then begin
    MousePos := Mouse.CursorPos;
    SetBounds(MoveFormPos.X + MousePos.X - MoveMousePos.X,
      MoveFormPos.Y + MousePos.Y - MoveMousePos.Y, Width, Height);
  end;
end;

procedure TDrawDlg.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  MoveActive := False;
  inherited;
end;

procedure TDrawDlg.MouseLeave;
begin
  MoveActive := False;
  inherited;
end;

procedure TDrawDlg.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if Key = VK_ESCAPE then Close;
  inherited;
end;

procedure TDrawDlg.VisibleChangedHandler(Sender: TObject);
begin
  // LCL hides all StayOnTop forms during ShowModal.
  // Fix this to keep them visible.
  if (TFormStateType.fsModal in FormState) and Visible then
    Application.RestoreStayOnTop(True);

  MoveActive := False;

{$IFDEF LCLGTK2}
  // GTK2 bug workaround https://bugs.freepascal.org/view.php?id=35720
  {$IFDEF DPI}
  if Visible then LastMouse.WinControl := Self.NativeForm;
  {$ELSE}
  if Visible then LastMouse.WinControl := Self;
  {$ENDIF}
{$ENDIF}
end;

procedure TDrawDlg.DoDeactivate(Sender: TObject);
begin
  MoveActive := False;
end;

procedure TDrawDlg.InitButtons;
var
  cix: Integer;
  // ButtonDownSound, ButtonUpSound: string;
begin
  // ButtonDownSound := Sounds.Lookup('BUTTON_DOWN');
  // ButtonUpSound := Sounds.Lookup('BUTTON_UP');
  for cix := 0 to ComponentCount - 1 do
    if Components[cix] is TButtonBase then
    begin
      TButtonBase(Components[cix]).Graphic := HGrSystem.Data;
      // if ButtonDownSound <> '*' then
      // DownSound := GetSoundsDir + DirectorySeparator + ButtonDownSound + '.wav';
      // if ButtonUpSound <> '*' then
      // UpSound := GetSoundsDir + DirectorySeparator + ButtonUpSound + '.wav';
      if Components[cix] is TButtonA then
        TButtonA(Components[cix]).Font := UniFont[ftButton];
      if Components[cix] is TButtonB then
        TButtonB(Components[cix]).Mask := HGrSystem.Mask;
    end;
end;

procedure TDrawDlg.SmartInvalidate;
var
  I: Integer;
  R0, R1: HRgn;
begin
  R0 := CreateRectRgn(0, 0, Width, Height);
  for I := 0 to ControlCount - 1 do
    if not (Controls[I] is TArea) and Controls[I].Visible then begin
      with Controls[I].BoundsRect do
        R1 := CreateRectRgn(Left, Top, Right, Bottom);
      CombineRgn(R0, R0, R1, RGN_DIFF);
      DeleteObject(R1);
    end;
  InvalidateRgn(Handle, R0, False);
  DeleteObject(R0);
end;

procedure TDrawDlg.CenterToScreen;
begin
  BoundsRect := Bounds(
    Screen.PrimaryMonitor.Left + (Screen.PrimaryMonitor.Width - Width) div 2,
    Screen.PrimaryMonitor.Top + (Screen.PrimaryMonitor.Height - Height) div 2,
    Width, Height);
end;

procedure TDrawDlg.CenterToScreen(AWidth, AHeight: Integer);
begin
  BoundsRect := Bounds(
    Screen.PrimaryMonitor.Left + (Screen.PrimaryMonitor.Width - AWidth) div 2,
    Screen.PrimaryMonitor.Top + (Screen.PrimaryMonitor.Height - AHeight) div 2,
    Width, Height);
end;

{ TBaseMessgDlg }

procedure TBaseMessgDlg.FormCreate(Sender: TObject);
begin
  Left := Screen.PrimaryMonitor.Left + (Screen.PrimaryMonitor.Width - Width) div 2;
  Canvas.Font.Assign(UniFont[ftNormal]);
  Canvas.Brush.Style := TBrushStyle.bsClear;
  MessgText := '';
  TopSpace := 0;
  TitleHeight := Screen.PrimaryMonitor.Height;
  if csDesigning in ComponentState then Exit;
  InitButtons;
end;

procedure TBaseMessgDlg.FormPaint(Sender: TObject);
var
  I, cix: Integer;
begin
  if csDesigning in ComponentState then Exit;
  PaintBackground(Canvas, 3 + Border, 3 + Border, Width - (6 + 2 * Border),
    Height - (6 + 2 * Border), Width, Height);
  for I := 0 to Border do
    Frame(Canvas, I, I, Width - 1 - I, Height - 1 - I, $000000, $000000);
  Frame(Canvas, Border + 1, Border + 1, Width - (2 + Border),
    Height - (2 + Border), MainTexture.ColorBevelLight,
    MainTexture.ColorBevelShade);
  Frame(Canvas, 2 + Border, 2 + Border, Width - (3 + Border),
    Height - (3 + Border), MainTexture.ColorBevelLight,
    MainTexture.ColorBevelShade);
  SplitText(False);

  for cix := 0 to ControlCount - 1 do
    if (Controls[cix].Visible) and (Controls[cix] is TButtonBase) then
      BtnFrame(Canvas, Controls[cix].BoundsRect, MainTexture);
end;

procedure TBaseMessgDlg.SplitText(Preview: Boolean);
var
  Start, Stop, OrdinaryStop, LinesCount: Integer;
  S: string;
begin
  Start := 1;
  LinesCount := 0;
  while Start < Length(MessgText) do
  begin
    Stop := Start;
    while (Stop < Length(MessgText)) and (MessgText[Stop] <> '\') and
      (BiColorTextWidth(Canvas, Copy(MessgText, Start, Stop - Start + 1)) <
      Width - 56) do
      Inc(Stop);
    if Stop <> Length(MessgText) then
    begin
      OrdinaryStop := Stop;
      repeat
        Dec(OrdinaryStop)
      until (MessgText[OrdinaryStop + 1] = ' ') or
        (MessgText[OrdinaryStop + 1] = '\');
      if (OrdinaryStop + 1 - Start) * 2 >= Stop - Start then
        Stop := OrdinaryStop;
    end;
    if not Preview then
    begin
      S := Copy(MessgText, Start, Stop - Start + 1);
      LoweredTextOut(Canvas, -1, MainTexture,
        (Width - BiColorTextWidth(Canvas, S)) div 2,
        19 + Border + TopSpace + LinesCount * MessageLineSpacing, S);
    end;
    Start := Stop + 2;
    Inc(LinesCount);
  end;
  if Preview then
    Lines := LinesCount;
end;

procedure TBaseMessgDlg.CorrectHeight;
var
  I: Integer;
  NewHeight: Integer;
  NewTop: Integer;
begin
  NewHeight := 72 + Border + TopSpace + Lines * MessageLineSpacing;
  NewTop := Screen.PrimaryMonitor.Top + (Screen.PrimaryMonitor.Height - NewHeight) div 2;
  BoundsRect := Bounds(Left, NewTop, Width, NewHeight);
  for I := 0 to ControlCount - 1 do
    Controls[I].Top := NewHeight - (34 + Border);
end;

end.