jvdsadialogs.pas

East make Tray Icon in delphi

  TJvDSADialog = class(TJvComponent)
  private
    FCheckControl: TWinControl;
    FDialogID: Integer;
    FIgnoreDSAChkMrkTxt: Boolean;
    FOnUpdateKeys: TJvDSADataEvent;
    FOnApplyKeys: TJvDSADataEvent;
    FOrgOwner: TComponent;
    FOrgShowModalPtr: Pointer;
    FTimeout: Integer;
    FTimer: TTimer;
    FTimerCount: Integer;
    FOnCountdown: TNotifyEvent;
    FOnAutoClose: TJvDSAAutoCloseEvent;
  protected
    procedure AutoClose;
    procedure AfterShow; virtual;
    procedure ApplySavedState; virtual;
    procedure BeforeShow; virtual;
    procedure DoApplyKeys(const Storage: TDSAStorage; const DSAInfo: TDSARegItem); virtual;
    function DoAutoClose: Boolean;
    procedure DoCountDown;
    procedure DoUpdateKeys(const Storage: TDSAStorage; const DSAInfo: TDSARegItem); virtual;
    function GetDSAStateInternal(out ModalResult: Integer): Boolean;
    function GetOrgOwner: TComponent;
    function GetOrgShowModalPtr: Pointer;
    function GetStorage: TDSAStorage;
    procedure FormPatch;
    procedure FormUnPatch;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetCheckControl(Value: TWinControl); virtual;
    procedure SetDialogID(Value: Integer); virtual;
    procedure SetOrgOwner(Value: TComponent);
    procedure SetOrgShowModalPtr(Value: Pointer);
    procedure TimerEvent(Sender: TObject);
    procedure UpdateDSAState; virtual;
    property OrgOwner: TComponent read GetOrgOwner write SetOrgOwner;
    property OrgShowModalPtr: Pointer read GetOrgShowModalPtr write SetOrgShowModalPtr;
    property Storage: TDSAStorage read GetStorage;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetModalResult: Integer; virtual;
    function IsDSAChecked: Boolean; virtual;
    procedure Loaded; override;
    procedure CancelCountdown; virtual;
    function SecondsLeft: Integer;
  published
    property Timeout: Integer read FTimeout write FTimeout;
    property CheckControl: TWinControl read FCheckControl write SetCheckControl;
    property DialogID: Integer read FDialogID write SetDialogID;
    property IgnoreDSAChkMrkTxt: Boolean read FIgnoreDSAChkMrkTxt write FIgnoreDSAChkMrkTxt;
    property OnApplyKeys: TJvDSADataEvent read FOnApplyKeys write FOnApplyKeys;
    property OnUpdateKeys: TJvDSADataEvent read FOnUpdateKeys write FOnUpdateKeys;
    property OnCountdown: TNotifyEvent read FOnCountdown write FOnCountdown;
    property OnAutoClose: TJvDSAAutoCloseEvent read FOnAutoClose write FOnAutoClose;
  end;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvDSADialogs.pas,v $';
    Revision: '$Revision: 1.45 $';
    Date: '$Date: 2005/02/17 10:20:21 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  Consts, Math, TypInfo,
  {$IFDEF MSWINDOWS}
  JclRegistry,
  {$ENDIF MSWINDOWS}
  JclBase, JclSysUtils,
  JvDynControlEngineIntf, JvConsts, JvResources;

const
  cDSAStateValueName = 'DSA_State'; // do not localize
  cDSAStateLastResultName = 'LastResult'; // do not localize

type
  PBoolean = ^Boolean;

//=== CheckMarkTexts =========================================================

var
  GlobalCheckMarkTexts: TStringList = nil;

function CheckMarkTexts: TStrings;
begin
  if GlobalCheckMarkTexts = nil then
    GlobalCheckMarkTexts := TStringList.Create;
  Result := GlobalCheckMarkTexts;
end;

function GetCheckMarkText(const ID: TDSACheckTextKind): string;
var
  Idx: Integer;
begin
  Idx := CheckMarkTexts.IndexOfObject(TObject(ID));
  if Idx > -1 then
    Result := CheckMarkTexts[Idx]
  else
    Result := '';
end;

//=== { TDSAMessageForm } ====================================================

constructor TDSAMessageForm.CreateNew(AOwner: TComponent; Dummy: Integer);
{$IFDEF VCL}
var
  NonClientMetrics: TNonClientMetrics;
{$ENDIF VCL}
begin
  inherited CreateNew(AOwner, Dummy);
  {$IFDEF VCL}
  NonClientMetrics.cbSize := SizeOf(NonClientMetrics);
  if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
    Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont);
  {$ENDIF VCL}
  FTimer := TTimer.Create(Self);
  FTimer.Enabled := False;
  FTimer.Interval := 1000;
  FTimer.OnTimer := TimerEvent;
end;

procedure TDSAMessageForm.CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  CancelAutoClose;
  if (Shift = [ssCtrl]) and (Key = Word('C')) then
  begin
    // (rom) deactivated  annoying
    // SysUtils.Beep;
    WriteToClipboard(GetFormText);
  end;
end;

procedure TDSAMessageForm.CustomMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  CancelAutoClose;
end;

procedure TDSAMessageForm.CustomShow(Sender: TObject);
var
  I: Integer;
begin
  if Timeout <> 0 then
    FTimer.Enabled := True;
  for I := 0 to ComponentCount - 1 do
  begin
    if (Components[I] is TButton) and (Components[I] as TButton).Default then
    begin
      (Components[I] as TButton).SetFocus;
      Break;
    end;
  end;
  FCountdown := TLabel(FindComponent('Countdown'));
end;

procedure TDSAMessageForm.HelpButtonClick(Sender: TObject);
begin
  CancelAutoClose;
  {$IFDEF VCL}
  Application.HelpContext(HelpContext);
  {$ENDIF VCL}
  {$IFDEF VisualCLX}
  Application.ContextHelp(HelpContext);
  {$ENDIF VisualCLX}
end;

procedure TDSAMessageForm.TimerEvent(Sender: TObject);
var
  I: Integer;
begin
  if FTimer.Enabled then
  begin
    Dec(FTimeout);
    if FTimeout = 0 then
    begin
      FTimer.Enabled := False;
      for I := 0 to ComponentCount - 1 do
      begin
        if (Components[I] is TButton) and (Components[I] as TButton).Default then
        begin
          (Components[I] as TButton).Click;
          Exit;
        end;
      end;
      // No default button found; just close the form
      Close;
    end
    else
    if FCountdown <> nil then
      FCountdown.Caption := Format(RsCntdownText, [Timeout, TimeoutUnit(Timeout)]);
  end;
end;

{$IFDEF VCL}
procedure TDSAMessageForm.WriteToClipboard(const Text: string);
var
  Data: THandle;
  DataPtr: Pointer;
begin
  if OpenClipboard(0) then
  begin
    try
      Data := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, Length(Text) + 1);
      try
        DataPtr := GlobalLock(Data);
        try
          Move(PChar(Text)^, DataPtr^, Length(Text) + 1);
          EmptyClipboard;
          SetClipboardData(CF_TEXT, Data);
        finally
          GlobalUnlock(Data);
        end;
      except
        GlobalFree(Data);
        raise;
      end;
    finally
      CloseClipboard;
    end;
  end
  else
    raise EJVCLException.CreateRes(@SCannotOpenClipboard);
end;
{$ENDIF VCL}

{$IFDEF VisualCLX}
procedure TDSAMessageForm.WriteToClipboard(const Text: string);
begin
  Clipboard.AsText := Text;
end;
{$ENDIF VisualCLX}

function TDSAMessageForm.GetFormText: string;
var
  DividerLine, ButtonCaptions: string;
  I: Integer;
begin
  DividerLine := StringOfChar('-', 27) + CrLf;
  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]);
  I := ComponentCount - 1;
  while (I > -1) and not (Components[I] is TLabel) do
    Dec(I);
  Result := Format('%s%s%s%s%s%s%s%s%s%s', [DividerLine, Caption, CrLf, DividerLine,
    TLabel(Components[I]).Caption, CrLf, DividerLine, ButtonCaptions, CrLf, DividerLine]);
end;

function TDSAMessageForm.TimeoutUnit(Secs: Integer): string;
begin
  if Secs <> 1 then
    Result := RsCntdownSecsText
  else
    Result := RsCntdownSecText;
end;

procedure TDSAMessageForm.CancelAutoClose;
begin
  FTimer.Enabled := False;
  FreeAndNil(FCountdown);
end;

function TDSAMessageForm.IsDSAChecked: Boolean;
var
  I: Integer;
begin
  I := ComponentCount - 1;
  while (I > -1) and not (Components[I] is TCustomCheckBox) do
    Dec(I);
  if (I > -1) then
    Result := TCheckBox(Components[I]).Checked
  else
    Result := False;
end;

function GetAveCharSize(Canvas: TCanvas): TPoint;
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'));
  GetTextExtentPoint32(Canvas.Handle, Buffer, 52, TSize(Result));
  Result.X := Result.X div 52;
end;

function CreateDSAMessageForm(const ACaption, Msg: string; const APicture: TGraphic;
  const Buttons: array of string; const Results: array of Integer; const HelpCtx: Integer;
  const CheckCaption: string; const Center: TDlgCenterKind = dckScreen;
  const ATimeout: Integer = 0; const DefaultButton: Integer = 0;
  const CancelButton: Integer = 1; HelpButton: Integer = -1;
  const ADynControlEngine: TJvDynControlEngine = nil): TDSAMessageForm;
const
  mcHorzMargin = 8;
  mcVertMargin = 8;
  mcHorzSpacing = 10;
  mcVertSpacing = 10;
  mcButtonWidth = 50;
  mcButtonHeight = 14;
  mcButtonSpacing = 4;
var
  DialogUnits: TPoint;
  HorzMargin, VertMargin, HorzSpacing, VertSpacing, ButtonWidth: Integer;
  ButtonHeight, ButtonSpacing, ButtonCount, ButtonGroupWidth: Integer;
  IconTextWidth, IconTextHeight, X, ALeft: Integer;
  ChkTextWidth: Integer;
  TimeoutTextWidth: Integer;
  IconID: PChar;
  TempRect, TextRect: TRect;
  I: Integer;
  CenterParent: TComponent;
  CenterParLeft, CenterParTop, CenterParWidth, CenterParHeight: Integer;
  DynControlEngine: TJvDynControlEngine;
  CountDownlabel, MessageLabel: TControl;
  Image: TWinControl;
  DynControlImage: IJvDynControlImage;
  DynControlLabel: IJvDynControlLabel;
  Panel: TWinControl;
begin
  if Assigned(ADynControlEngine) then
    DynControlEngine := ADynControlEngine
  else
    DynControlEngine := DefaultDynControlEngine;
  case Center of
    dckScreen:
      CenterParent := Screen;
    dckMainForm:
      CenterParent := Application.MainForm;
    dckActiveForm:
      CenterParent := Screen.ActiveCustomForm;
  else
    CenterParent := nil;
  end;
  if CenterParent = nil then
    CenterParent := Screen;
  if CenterParent is TScreen then
  begin
    CenterParLeft := 0;
    CenterParTop := 0;
    CenterParWidth := TScreen(CenterParent).Width;
    CenterParHeight := TScreen(CenterParent).Height;
  end
  else
  begin
    with TWinControl(CenterParent) do
    begin
      CenterParLeft := Left;
      CenterParTop := Top;
      CenterParWidth := Width;
      CenterParHeight := Height;
    end;