{=======================================}
{             RSC SISTEMAS              }
{        SOLUÇÕES TECNOLÓGICAS          }
{         rscsistemas.com.br            }
{          +55 92 4141-2737             }
{      contato@rscsistemas.com.br       }
{                                       }
{ Desenvolvidor por:                    }
{   Roniery Santos Cardoso              }
{     ronierys2@hotmail.com             }
{     +55 92 984391279                  }
{                                       }
{                                       }
{ Versão Original RSC SISTEMAS          }
{ Versão: 3.0.0                         }
{                                       }
{                                       }
{=======================================}

unit Rsc.Vcl.Dialogs;

interface

  uses
    System.UITypes
    ,System.Types
    ,System.Classes
    ,System.SysUtils
    ,System.Math

    ,VCL.Forms
    ,Vcl.StdCtrls
    ,Vcl.Consts
    ,Vcl.Graphics
    ,Vcl.ExtCtrls
    ,Vcl.Controls

    ,Winapi.Windows
    ,Winapi.Messages

    ;

{ Message dialog }

type

  TMsgDlgType = System.UITypes.TMsgDlgType;
  {$NODEFINE TMsgDlgType}

  TMsgDlgBtn = System.UITypes.TMsgDlgBtn;
  {$NODEFINE TMsgDlgBtn}
  TMsgDlgButtons = System.UITypes.TMsgDlgButtons;
  {$NODEFINE TMsgDlgButtons}

  {$HPPEMIT OPENNAMESPACE}
  {$HPPEMIT 'using System::Uitypes::TMsgDlgBtn;'}
  {$HPPEMIT 'using System::Uitypes::TMsgDlgButtons;'}
  {$HPPEMIT 'using System::Uitypes::TMsgDlgType;'}
  {$HPPEMIT CLOSENAMESPACE}


const

{ Message dialog }
  mtWarning	= System.UITypes.TMsgDlgType.mtWarning;
  mtError	= System.UITypes.TMsgDlgType.mtError;
  mtInformation	= System.UITypes.TMsgDlgType.mtInformation;
  mtConfirmation	= System.UITypes.TMsgDlgType.mtConfirmation;
  mtCustom	= System.UITypes.TMsgDlgType.mtCustom;

  mbYes	= System.UITypes.TMsgDlgBtn.mbYes;
  mbNo	= System.UITypes.TMsgDlgBtn.mbNo;
  mbOK	= System.UITypes.TMsgDlgBtn.mbOK;
  mbCancel	= System.UITypes.TMsgDlgBtn.mbCancel;
  mbAbort	= System.UITypes.TMsgDlgBtn.mbAbort;
  mbRetry	= System.UITypes.TMsgDlgBtn.mbRetry;
  mbIgnore	= System.UITypes.TMsgDlgBtn.mbIgnore;
  mbAll	= System.UITypes.TMsgDlgBtn.mbAll;
  mbNoToAll	= System.UITypes.TMsgDlgBtn.mbNoToAll;
  mbYesToAll	= System.UITypes.TMsgDlgBtn.mbYesToAll;
  mbHelp	= System.UITypes.TMsgDlgBtn.mbHelp;
  mbClose	= System.UITypes.TMsgDlgBtn.mbClose;


  mbYesNo = [mbYes, mbNo];
  mbYesNoCancel = [mbYes, mbNo, mbCancel];
  mbYesAllNoAllCancel = [mbYes, mbYesToAll, mbNo, mbNoToAll, mbCancel];
  mbOKCancel = [mbOK, mbCancel];
  mbAbortRetryIgnore = [mbAbort, mbRetry, mbIgnore];
  mbAbortIgnore = [mbAbort, mbIgnore];


function CreateMessageDialogRsc(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons): TForm; overload;
function CreateMessageDialogRsc(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; DefaultButton: TMsgDlgBtn): TForm; overload;


procedure ShowMessageRsc(const Msg: string); overload; inline;
procedure ShowMessagePosRsc(const Msg: string; X, Y: Integer); overload; inline;


function MessageDlgRsc(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; overload; inline;
function MessageDlgPosRsc(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer; overload; inline;
function MessageDlgPosHelpRsc(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
  const HelpFileName: string): Integer; overload;


type
  TMessageForm = class(TForm)
  private
    Message: TLabel;
    FTitle:  TLabel;
    FPnlTitle:  TPanel;
    FShap:  TShape;
    procedure HelpButtonClick(Sender: TObject);
    procedure OnTitleMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  protected
    procedure CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure WriteToClipBoard(Text: String);
    function GetFormText: String;
  public
    constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
  end;


implementation

{ TMessageForm }

constructor TMessageForm.CreateNew(AOwner: TComponent; Dummy: Integer);
var
  LPPI: Integer;
begin
  inherited CreateNew(AOwner, Dummy);
//  Font.Assign(Screen.MessageFont);

  FShap :=  TShape.Create(Self);
  with  FShap do
  begin
    Parent  :=  Self;
    Align :=  alClient;
    Brush.Style :=  bsSolid;
    Brush.Color :=  clWhite;
    Pen.Color :=  clHighlight;
    Pen.Style :=  psSolid;
    Pen.Width :=  2;
    Shape :=  stRectangle;
  end;

  FPnlTitle  :=  TPanel.Create(Self);
  with  FPnlTitle  do
  begin
    Name              := 'PnlTitle';
    Parent            := Self;
    BevelOuter        :=  TPanelBevel.bvNone;
    ParentColor       :=  False;
    ParentBackground  :=  False;
    Color             :=  clHighlight;
    Align             :=  TAlign.alTop;
    Width             :=  30;
    Caption           :=  EmptyStr;
    Visible           :=  True;
    Padding.Left      :=  10;
    Padding.Right     :=  10;
    Padding.Top       :=  3;
    Padding.Bottom    :=  3;
    OnMouseDown       :=  OnTitleMouseDown;
  end;

  FTitle  :=  TLabel.Create(Self);
  with FTitle do
  begin
    Name              :=  'LblTitle';
    Parent            :=  FPnlTitle;
    BevelOuter        :=  TPanelBevel.bvNone;
    ParentColor       :=  False;
    ParentBackground  :=  False;
    Align             :=  TAlign.alClient;
    Alignment         :=  taCenter;
    AlignWithMargins  :=  True;
    Layout            :=  TTextLayout.tlCenter;
    Width             :=  30;
    Caption           :=  EmptyStr;
    Visible           :=  True;
    Font.Color        :=  clWhite;
    Font.Size         :=  14;
    OnMouseDown       :=  OnTitleMouseDown;
  end;

  LPPI := Screen.PixelsPerInch;
  if Screen.ActiveForm <> nil then
    LPPI := Screen.ActiveForm.CurrentPPI
  else
    if Application.MainForm <> nil then
      LPPI := Application.MainForm.CurrentPPI;
  ScaleForPPI(LPPI);
end;

procedure TMessageForm.CustomKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Shift = [ssCtrl]) and (Key = Word('C')) then
  begin
//    Beep;
    WriteToClipBoard(GetFormText);
  end;
end;

function TMessageForm.GetFormText: String;
var
  DividerLine, ButtonCaptions: string;
  I: integer;
begin
  DividerLine := StringOfChar('-', 27) + sLineBreak;
  for I := 0 to ComponentCount - 1 do
    if Components[I] is TButton then
      ButtonCaptions := ButtonCaptions + TButton(Components[I]).Caption +
        StringOfChar(' ', 3);
  ButtonCaptions := StringReplace(ButtonCaptions,'&','', [rfReplaceAll]);
  Result := Format('%s%s%s%s%s%s%s%s%s%s', [DividerLine, Caption, sLineBreak,
    DividerLine, Message.Caption, sLineBreak, DividerLine, ButtonCaptions,
    sLineBreak, DividerLine]);
end;

procedure TMessageForm.HelpButtonClick(Sender: TObject);
begin
  Application.HelpContext(HelpContext);
end;

procedure TMessageForm.OnTitleMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
const
   sc_DragMove = $f012;
begin
  ReleaseCapture;
  Perform(wm_SysCommand, sc_DragMove, 0);
end;

procedure TMessageForm.WriteToClipBoard(Text: String);
var
  Data: THandle;
{$IF DEFINED(CLR)}
  DataPtr: IntPtr;
  Buffer: TBytes;
{$ELSE}
  DataPtr: Pointer;
{$ENDIF}
begin
  if OpenClipBoard(0) then
  begin
    try

{$IF DEFINED(CLR)}
      Buffer := PlatformBytesOf(Text);
      SetLength(Buffer, Length(Buffer) + Marshal.SystemDefaultCharSize);
      Data := GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE, Length(Buffer));
{$ELSE}
      Data := GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE, ByteLength(Text) + SizeOf(Char));
{$ENDIF}
      try
        DataPtr := GlobalLock(Data);
        try
{$IF DEFINED(CLR)}
          Marshal.Copy(Buffer, 0, DataPtr, Length(Buffer));
{$ELSE}
          Move(PChar(Text)^, DataPtr^, ByteLength(Text) + SizeOf(Char));
          EmptyClipBoard;
          SetClipboardData(CF_UNICODETEXT, Data);
{$ENDIF}
        finally
          GlobalUnlock(Data);
        end;
{$IF DEFINED(CLR)}
        EmptyClipBoard;
        if Marshal.SystemDefaultCharSize > 1 then
          SetClipboardData(CF_UNICODETEXT, Data)
        else
          SetClipboardData(CF_TEXT, Data)
{$ENDIF}
      except
        GlobalFree(Data);
        raise;
      end;
    finally
      CloseClipBoard;
    end;
  end
  else
    raise Exception.CreateRes({$IFNDEF CLR}@{$ENDIF}SCannotOpenClipboard);
end;


var
{$IF DEFINED(CLR)}
  Captions: array[TMsgDlgType] of string = (SMsgDlgWarning, SMsgDlgError,
    SMsgDlgInformation, SMsgDlgConfirm, '');
  IconIDs: array[TMsgDlgType] of Integer = (IDI_EXCLAMATION, IDI_HAND,
    IDI_ASTERISK, IDI_QUESTION, -1);
  ButtonCaptions: array[TMsgDlgBtn] of string = (
    SMsgDlgYes, SMsgDlgNo, SMsgDlgOK, SMsgDlgCancel, SMsgDlgAbort,
    SMsgDlgRetry, SMsgDlgIgnore, SMsgDlgAll, SMsgDlgNoToAll, SMsgDlgYesToAll,
    SMsgDlgHelp, SMsgDlgClose);
{$ELSE}
  Captions: array[TMsgDlgType] of Pointer = (@SMsgDlgWarning, @SMsgDlgError,
    @SMsgDlgInformation, @SMsgDlgConfirm, nil);
  IconIDs: array[TMsgDlgType] of PChar = (IDI_EXCLAMATION, IDI_HAND,
    IDI_ASTERISK, IDI_QUESTION, nil);
  ButtonCaptions: array[TMsgDlgBtn] of Pointer = (
    @SMsgDlgYes, @SMsgDlgNo, @SMsgDlgOK, @SMsgDlgCancel, @SMsgDlgAbort,
    @SMsgDlgRetry, @SMsgDlgIgnore, @SMsgDlgAll, @SMsgDlgNoToAll, @SMsgDlgYesToAll,
    @SMsgDlgHelp, @SMsgDlgClose);
{$ENDIF}
  ButtonNames: array[TMsgDlgBtn] of string = (
    'Yes', 'No', 'OK', 'Cancel', 'Abort', 'Retry', 'Ignore', 'All', 'NoToAll',
    'YesToAll', 'Help', 'Close');
  ModalResults: array[TMsgDlgBtn] of Integer = (
    mrYes, mrNo, mrOk, mrCancel, mrAbort, mrRetry, mrIgnore, mrAll, mrNoToAll,
    mrYesToAll, 0, mrClose);
  ButtonWidths : array[TMsgDlgBtn] of Integer;  // initialized to zero


{======================================================================}
function GetAveCharSize(Canvas: TCanvas): TPoint;
{$IF DEFINED(CLR)}
var
  I: Integer;
  Buffer: string;
  Size: TSize;
begin
  SetLength(Buffer, 52);
  for I := 0 to 25 do Buffer[I + 1] := Chr(I + Ord('A'));
  for I := 0 to 25 do Buffer[I + 27] := Chr(I + Ord('a'));
  GetTextExtentPoint(Canvas.Handle, Buffer, 52, Size);
  Result.X := Size.cx div 52;
  Result.Y := Size.cy;
end;
{$ELSE}
var
  I: Integer;
  Buffer: array[0..51] of Char;
begin
  for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A'));
  for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a'));
  GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
  Result.X := Result.X div 52;
end;
{$ENDIF}
{-----------------------------------------------------------------}
function DoMessageDlgPosHelp(MessageDialog: TForm; HelpCtx: Longint; X, Y: Integer;
  const HelpFileName: string): Integer;
begin
  with MessageDialog do
    try
      HelpContext := HelpCtx;
      HelpFile := HelpFileName;
      if X >= 0 then Left := X;
      if Y >= 0 then Top := Y;
      if (Y < 0) and (X < 0) then Position := poScreenCenter;
      Result := ShowModal;
    finally
      Free;
    end;
end;
{======================================================================}


function CreateMessageDialogRsc(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons): TForm;
var
  DefaultButton: TMsgDlgBtn;
begin
  if mbOk in Buttons then DefaultButton := mbOk else
    if mbYes in Buttons then DefaultButton := mbYes else
      DefaultButton := mbRetry;
  Result := CreateMessageDialogRsc(Msg, DlgType, Buttons, DefaultButton);
end;


function CreateMessageDialogRsc(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; DefaultButton: TMsgDlgBtn): TForm;
const
  mcHorzMargin = 8;
  mcVertMargin = 8;
  mcHorzSpacing = 10;
  mcVertSpacing = 10;
  mcButtonWidth = 50;
  mcButtonHeight = 14;
  mcButtonSpacing = 4;
var
  DialogUnits: TPoint;
  HorzMargin, VertMargin, HorzSpacing, VertSpacing, ButtonWidth,
  ButtonHeight, ButtonSpacing, ButtonCount, ButtonGroupWidth,
  IconTextWidth, IconTextHeight, X, ALeft: Integer;
  B, CancelButton: TMsgDlgBtn;
{$IF DEFINED(CLR)}
  IconID: Integer;
{$ELSE}
  IconID: PChar;
{$ENDIF}
  TextRect: TRect;
  LButton: TButton;
begin
  Result := TMessageForm.CreateNew(Application);
  with Result do
  begin
    Font.Assign(Screen.MessageFont);
    Font.Height := Muldiv(Font.Height, Result.CurrentPPI, Screen.PixelsPerInch);
    BiDiMode := Application.BiDiMode;
    BorderStyle := bsNone;
    Canvas.Font := Font;
    KeyPreview := True;
    PopupMode := pmAuto;
    Position := poDesigned;
    OnKeyDown := TMessageForm(Result).CustomKeyDown;
    DialogUnits := GetAveCharSize(Canvas);
    HorzMargin := MulDiv(mcHorzMargin, DialogUnits.X, 4);
    VertMargin := MulDiv(mcVertMargin, DialogUnits.Y, 8);
    HorzSpacing := MulDiv(mcHorzSpacing, DialogUnits.X, 4);
    VertSpacing := MulDiv(mcVertSpacing, DialogUnits.Y, 8);
    ButtonWidth := MulDiv(mcButtonWidth, DialogUnits.X, 4);
    for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
    begin
      if B in Buttons then
      begin
        if ButtonWidths[B] = 0 then
        begin
          TextRect := Rect(0,0,0,0);
          Winapi.Windows.DrawText( canvas.handle,
{$IF DEFINED(CLR)}
            ButtonCaptions[B], -1,
{$ELSE}
            PChar(LoadResString(ButtonCaptions[B])), -1,
{$ENDIF}
            TextRect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE or
            DrawTextBiDiModeFlagsReadingOnly);
          with TextRect do ButtonWidths[B] := Right - Left + 8;
        end;
        if ButtonWidths[B] > ButtonWidth then
          ButtonWidth := ButtonWidths[B];
      end;
    end;
    ButtonHeight := MulDiv(mcButtonHeight, DialogUnits.Y, 8);
    ButtonSpacing := MulDiv(mcButtonSpacing, DialogUnits.X, 4);
    SetRect(TextRect, 0, 0, Screen.Width div 2, 0);
    DrawText(Canvas.Handle, Msg, Length(Msg)+1, TextRect,
      DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or
      DrawTextBiDiModeFlagsReadingOnly);
    IconID := IconIDs[DlgType];
    IconTextWidth := TextRect.Right;
    IconTextHeight := TextRect.Bottom;
{$IF DEFINED(CLR)}
    if DlgType <> mtCustom then
{$ELSE}
    if IconID <> nil then
{$ENDIF}
    begin
      Inc(IconTextWidth, 32 + HorzSpacing);
      if IconTextHeight < 32 then IconTextHeight := 32;
    end;
    ButtonCount := 0;
    for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
      if B in Buttons then Inc(ButtonCount);
    ButtonGroupWidth := 0;
    if ButtonCount <> 0 then
      ButtonGroupWidth := ButtonWidth * ButtonCount +
        ButtonSpacing * (ButtonCount - 1);
    ClientWidth :=   Max(IconTextWidth, ButtonGroupWidth) + HorzMargin * 2; {largura do formulario}
    ClientHeight := (IconTextHeight + ButtonHeight + VertSpacing + VertMargin * 2)  + 30; {altura do formulario}
    Left := (Screen.Width div 2) - (Width div 2);
    Top := (Screen.Height div 2) - (Height div 2);
    if DlgType <> mtCustom then
{$IF DEFINED(CLR)}
      Caption := Captions[DlgType] else
      Caption := Application.Title;
    if DlgType <> mtCustom then
{$ELSE}
      Caption := LoadResString(Captions[DlgType]) else
      Caption := Application.Title;
    if IconID <> nil then
{$ENDIF}
      with TImage.Create(Result) do
      begin
        Name := 'Image';
        Parent := Result;
        Picture.Icon.Handle := LoadIcon(0, IconID);
        AutoSize := True;
//        SetBounds(HorzMargin, (VertMargin + 30), 32, 32);
        SetBounds(HorzMargin, ((IconTextHeight div 2) + 30), 32, 32);
      end;

    TMessageForm(Result).Message := TLabel.Create(Result);
    with TMessageForm(Result).Message do
    begin
      Font.Assign(Screen.MessageFont);
      Font.Color :=  clHighlight;
      Name := 'Message';
      Parent := Result;
      WordWrap := True;
      Caption := Msg;
      BoundsRect := TextRect;
      BiDiMode := Result.BiDiMode;
      ALeft := IconTextWidth - TextRect.Right + HorzMargin;
      if UseRightToLeftAlignment then
        ALeft := Result.ClientWidth - ALeft - Width;
      SetBounds(ALeft, (VertMargin  + 30),
        TextRect.Right, TextRect.Bottom);
    end;
    if mbCancel in Buttons then CancelButton := mbCancel else
      if mbNo in Buttons then CancelButton := mbNo else
        CancelButton := mbOk;
    X := (ClientWidth - ButtonGroupWidth) div 2;
    for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
      if B in Buttons then
      begin
        LButton := TButton.Create(Result);
        with LButton do
        begin
          Name := ButtonNames[B];
          Parent := Result;
{$IF DEFINED(CLR)}
          Caption := ButtonCaptions[B];
{$ELSE}
          Caption := LoadResString(ButtonCaptions[B]);
{$ENDIF}
          ModalResult := ModalResults[B];
          if B = DefaultButton then
          begin
            Default := True;
            ActiveControl := LButton;
          end;
          if B = CancelButton then
            Cancel := True;
          SetBounds(X, IconTextHeight + VertMargin + VertSpacing  + 30,
            ButtonWidth, ButtonHeight);
          Inc(X, ButtonWidth + ButtonSpacing);
          if B = mbHelp then
            OnClick := TMessageForm(Result).HelpButtonClick;
        end;
      end;


    TMessageForm(Result).FTitle.Caption  :=  Caption;

    case DlgType of
      TMsgDlgType.mtWarning:
        begin
          TMessageForm(Result).FShap.Pen.Color  :=  $000080FF;
          TMessageForm(Result).FPnlTitle.Color  :=  $000080FF;
          TMessageForm(Result).Message.Font.Color :=  $000080FF;
        end;

      TMsgDlgType.mtError:
        begin
          TMessageForm(Result).FShap.Pen.Color  :=  clRed;
          TMessageForm(Result).FPnlTitle.Color  :=  clRed;
          TMessageForm(Result).Message.Font.Color :=  clRed;
        end;

      TMsgDlgType.mtInformation:
        begin
          TMessageForm(Result).FShap.Pen.Color  :=  clGreen;
          TMessageForm(Result).FPnlTitle.Color  :=  clGreen;
          TMessageForm(Result).Message.Font.Color :=  clGreen;
        end;

      TMsgDlgType.mtConfirmation:
        begin
          TMessageForm(Result).FShap.Pen.Color  :=  clPurple;
          TMessageForm(Result).FPnlTitle.Color  :=  clPurple;
          TMessageForm(Result).Message.Font.Color :=  clPurple;
        end;
    end;
  end;
end;


procedure ShowMessageRsc(const Msg: string);
begin
  ShowMessagePosRsc(Msg, -1, -1);
end;


procedure ShowMessagePosRsc(const Msg: string; X, Y: Integer);
begin
  MessageDlgPosRsc(Msg, mtCustom, [mbOK], 0, X, Y);
end;


function MessageDlgRsc(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer;
begin
  Result := MessageDlgPosHelpRsc(Msg, DlgType, Buttons, HelpCtx, -1, -1, '');
end;


function MessageDlgPosRsc(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer;
begin
  Result := MessageDlgPosHelpRsc(Msg, DlgType, Buttons, HelpCtx, X, Y, '');
end;


function MessageDlgPosHelpRsc(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
  const HelpFileName: string): Integer;
begin
    Result := DoMessageDlgPosHelp(CreateMessageDialogRsc(Msg, DlgType, Buttons),
      HelpCtx, X, Y, HelpFileName);
end;

end.
