tntjv0tipofday.pas

TntExUpdate 是 流行的 TntUnicodeControls控件的扩展包.包括很难找到的 TntJVCL 也在里面. TntSysUtils2.pas/TntSysUtilsEx.pa

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvTipsOfDay.PAS, released on 2001-02-28.

The Initial Developers of the Original Code are Sébastien Buysse [sbuysse att buypin dott com]
and Peter Th?rnqvist [peter3 at sourceforge dot net]. Portions created by Sébastien Buysse
are Copyright (C) 2001 Sébastien Buysse. Portions created by Peter Th?rnqvist
are Copyright (C) 2002 Peter Th?rnqvist.
All Rights Reserved.

Contributor(s): Michael Beck [mbeck att bigfoot dott com].
                Remko Bonte [remkobonte att myrealbox dott com]

Jordi March Nogué ([e-mail]),
  adds:
    ShowTipsOnStartup
    ReplaceTabForLineBreak
    when Application.BiDiMode = bdRightToLeft do:
      FlipChildren (True);
      FTipLabel.Alignment := taRightJustify;
      and changes arrow glyphs
  now uses: gnugettext.TranslateComponent
 03/01/2006 version

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvTipOfDay.pas,v 1.36 2005/12/11 16:14:17 jfudickar Exp $

unit TntJv0TipOfDay;

interface

uses
  Classes, Graphics, Controls, Messages, TntClasses,
  Forms, TntForms, TntStdCtrls, Buttons, TntButtons, TntJvBaseDlg,
  gnugettext;

resourcestring
  RsNextCaption = '&Next Tip';
  RsPriorCaption = '&Prior Tip';
  RsTipsTitle = 'Tips and Tricks';
  RsTipsHeaderText = 'Did you know...';
  RsTipsCheckBoxText = '&Show Tips on Startup';

const
  IdentShowTipsOnStartup = 'ShowTipsOnStartup';

type
  TJvCanShowEvent = procedure(Sender: TObject; var CanShow: Boolean) of object;

  TTntJv0TipOfDay = class(TTntJvCommonDialogP)
  private
    FColor: TColor;
    FDefaultFonts: Boolean;
    FTipFont: TFont;
    FHeaderFont: TFont;
    FTips: TTntStringList;
    FCurrentTip: Integer;
    FOnAfterExecute: TNotifyEvent;
    FOnCanShow: TJvCanShowEvent;
    { For reentrance check: }
    FRunning: Boolean;
    FTipLabel: TTntLabel;
    FNextTipButton: TTntBitBtn;
    FPriorTipButton: TTntBitBtn;
    FCheckBox: TTntCheckBox;
    FTripCount: TTntLabel;
    FReplaceTabForLineBreak: Boolean;
    FShowTipsOnStartup: Boolean;
    procedure FontChanged(Sender: TObject);
    function  IsFontStored: Boolean;
    procedure SetDefaultFonts(const Value: Boolean);
    procedure SetHeaderFont(const Value: TFont);
    procedure SetTipFont(const Value: TFont);
    function  GetTips: TTntStrings;
    procedure SetTips(const Value: TTntStrings);
  protected
    { Determines whether the dialog can be shown; user can write an
      event handler to override the default behaviour: }
    function  CanShow: Boolean; virtual;
    procedure DoAfterExecute; virtual;
    { Handles button clicks on the 'Next' button: }
    procedure HandleNextClick(Sender: TObject);
    { Handles button clicks on the 'Prior' button: }
    procedure HandlePriorClick(Sender: TObject);
    { Initializes the "New VC++ look" Tip of the Day dialog: }
    procedure InitVC(AForm: TTntForm);
    { Called in Loaded method; sets flag FIsAutoExecute to True to indicate
      that the Execute was automatically called, thus not by the user: }
    procedure UpdateFonts;
    { Places a new tip on the dialog: }
    procedure UpdateTip;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute;
    procedure LoadFromFile(const AFileName: WideString);
    procedure SaveToFile(const AFileName: WideString);
    property ShowTipsOnStartup: Boolean read FShowTipsOnStartup write FShowTipsOnStartup default True;
  published
    property Color: TColor read FColor write FColor default clWhite;
    property DefaultFonts: Boolean read FDefaultFonts write SetDefaultFonts default True;
    property HeaderFont: TFont read FHeaderFont write SetHeaderFont stored IsFontStored;
    property OnAfterExecute: TNotifyEvent read FOnAfterExecute write FOnAfterExecute;
    property OnCanShow: TJvCanShowEvent read FOnCanShow write FOnCanShow;
    property ReplaceTabForLineBreak: Boolean read FReplaceTabForLineBreak write FReplaceTabForLineBreak default True;
    property TipFont: TFont read FTipFont write SetTipFont stored IsFontStored;
    property Tips: TTntStrings read GetTips write SetTips;
  end;

implementation

uses
  SysUtils, Windows, ExtCtrls, TntDialogs, JvConsts, Consts,
  TntGraphics;

{$R *.res}

{--------------------------------------}

function StrReplaceSimpleW (InStr: WideString;
  const SearchStr, ReplaceStr: WideString): WideString;
var
  I: Integer;
begin
  if  SearchStr = ''  then  begin
    Result := InStr;
    Exit;
  end
  else
    Result := '';
  while  InStr <> ''  do  begin
    I := Pos (SearchStr, InStr);
    if  I > 0  then  begin
      Result := Concat (Result, Copy (InStr, 1, I-1), ReplaceStr);
      InStr := Copy (InStr, I+Length(SearchStr), MaxInt);
    end
    else  begin
      Result := Concat (Result, InStr);
      InStr := '';
    end;
  end;
end {StrReplaceSimpleW};

{--------------------------------------}
{-PRIVATE----------}

procedure TTntJv0TipOfDay.FontChanged(Sender: TObject);
begin
  FDefaultFonts := False;
end;

function TTntJv0TipOfDay.GetTips: TTntStrings;
begin
  Result := FTips;
end;

procedure TTntJv0TipOfDay.SetTips(const Value: TTntStrings);
begin
  FTips.Assign(Value);
end;

function TTntJv0TipOfDay.IsFontStored: Boolean;
begin
  Result := not DefaultFonts;
end;

procedure TTntJv0TipOfDay.SetDefaultFonts(const Value: Boolean);
begin
  if Value <> FDefaultFonts then
  begin
    FDefaultFonts := Value;
    if FDefaultFonts then
      UpdateFonts;
  end;
end;

procedure TTntJv0TipOfDay.SetHeaderFont(const Value: TFont);
begin
  FHeaderFont.Assign(Value);
end;

procedure TTntJv0TipOfDay.SetTipFont(const Value: TFont);
begin
  FTipFont.Assign(Value);
end;

{-PROTECTED--------}

function TTntJv0TipOfDay.CanShow: Boolean;
begin
  // Show the dialog if the user called Execute (FIsAutoExecute=False) or
  // if flag toShowOnStartUp is in Options..
  Result := True;

  // ..but enable the user to override this behaviour
  if not (csDesigning in ComponentState) and Assigned(FOnCanShow) then
    FOnCanShow(Self, Result);
end;

procedure TTntJv0TipOfDay.DoAfterExecute;
begin
  if csDesigning in ComponentState then
    Exit;
  if Assigned(FOnAfterExecute) then
    FOnAfterExecute(Self);
end;

procedure TTntJv0TipOfDay.HandleNextClick(Sender: TObject);
begin
  FCurrentTip := (FCurrentTip + 1) mod Tips.Count;
  UpdateTip;
end {HandleNextClick};

procedure TTntJv0TipOfDay.HandlePriorClick(Sender: TObject);
begin
  if  FCurrentTip = 0
  then  FCurrentTip := Tips.Count-1
  else  Dec (FCurrentTip);
  UpdateTip;
end {HandlePriorClick};

procedure TTntJv0TipOfDay.InitVC(AForm: TTntForm);
begin
  with AForm do
  begin
    { Title }
    BiDiMode := Application.BiDiMode;
    Caption := RsTipsTitle;
    ClientHeight := 283;
    ClientWidth := 352;
    BorderIcons := [biSystemMenu];
    BorderStyle := bsSingle;
    Position := poScreenCenter;
    with TShape.Create(AForm) do
    begin
      Parent := AForm;
      SetBounds(8, 8, 337, 206);
      Brush.Color := Self.Color;
      Pen.Color := clGray;
      Pen.Style := psInsideFrame;
    end;
    with TShape.Create(AForm) do
    begin
      Parent := AForm;
      SetBounds(8, 8, 53, 205);
      Brush.Color := clGray;
      Pen.Color := clGray;
    end;
    with TShape.Create(AForm) do
    begin
      Parent := AForm;
      SetBounds(61, 51, 284, 1);
      Brush.Color := clGray;
      Pen.Color := clGray;
      Pen.Width := 10;
    end;

    { Header: 'Did you know...' }
    with TTntLabel.Create(AForm) do
    begin
      Parent := AForm;
      SetBounds(71, 19, 266, 23);
      AutoSize := False;
      Caption := RsTipsHeaderText;
      Color := Self.Color;
      Font := Self.HeaderFont;
    end;
    with TImage.Create(AForm) do
    begin
      Parent := AForm;
      Center := True;
      SetBounds(8, 8, 53, 53);
      Picture.Bitmap.LoadFromResourceName(HInstance, 'TntJvTipOfDayPIC1');
    end;

    { CheckBox: 'Show Tips on StartUp' }
    FCheckBox := TTntCheckBox.Create(AForm);
    with FCheckBox do
    begin
      Parent := AForm;
      SetBounds(8, 224, 293, 17);
      Caption := RsTipsCheckBoxText;
    end;

    FTripCount := TTntLabel.Create(AForm);
    with FTripCount do
    begin
      Parent := AForm;
      Caption := '';
      Font := Self.HeaderFont;
      Alignment := taRightJustify;
      Left := 337;
      Top := 224;
    end;

    FPriorTipButton := TTntBitBtn.Create(AForm);
    with FPriorTipButton do
    begin
      Parent := AForm;
      Caption := RsPriorCaption;
      OnClick := HandlePriorClick;
      SetBounds(8, 252, 91, 25);
      if  BiDiMode = bdRightToLeft  then  begin
        Glyph.LoadFromResourceName(HInstance, 'TntArrow1R');
        Layout := blGlyphRight;
      end
      else  begin
        Glyph.LoadFromResourceName(HInstance, 'TntArrow1L');
      end;
    end;

    FNextTipButton := TTntBitBtn.Create(AForm);
    with FNextTipButton do
    begin
      Parent := AForm;
      Caption := RsNextCaption;
      OnClick := HandleNextClick;
      SetBounds(108, 252, 91, 25);
      if  BiDiMode = bdRightToLeft  then  begin
        Glyph.LoadFromResourceName(HInstance, 'TntArrow1L');
      end
      else  begin
        Glyph.LoadFromResourceName(HInstance, 'TntArrow1R');
        Layout := blGlyphRight;
      end;
    end;

    with TTntBitBtn.Create(AForm) do
    begin
      Parent := AForm;
      SetBounds(208, 252, 91, 25);
      ModalResult := mrOk;
      Caption := SCloseButton;
      Glyph.LoadFromResourceName(HInstance, 'TntClose');
    end;

    { Tip label }
    FTipLabel := TTntLabel.Create(AForm);
    with FTipLabel do
    begin
      Parent := AForm;
      SetBounds(71, 60, 266, 149);
      AutoSize := False;
      Color := Self.Color;
      WordWrap := True;
      Font := Self.TipFont;
    end;

    if UseRightToLeftAlignment then  begin
      FlipChildren (True);
      FTripCount.Left := 8;
    end;
    TranslateComponent (AForm);
  end;
end {InitVC};

procedure TTntJv0TipOfDay.UpdateFonts;
var
  SavedDefaultFonts: Boolean;
begin
  { If we change the fonts, FDefaultFonts will be set to False (in
    FontChanged), thus before changing we must save the current
    value of FDefaultFonts
  }
  SavedDefaultFonts := FDefaultFonts;

  FTipFont.Charset := DEFAULT_CHARSET;
  FTipFont.Color := clWindowText;
  FTipFont.Name := 'MS Sans Serif';
  FTipFont.Pitch := fpDefault;
  FTipFont.Size := 10;
  FTipFont.Style := [];

  FHeaderFont.Charset := DEFAULT_CHARSET;
  FHeaderFont.Color := clWindowText;
  FHeaderFont.Name := 'Times New Roman';
  FHeaderFont.Pitch := fpDefault;
  FHeaderFont.Size := 12;
  FHeaderFont.Style := [fsBold];

  FDefaultFonts := SavedDefaultFonts;
end {UpdateFonts};

procedure TTntJv0TipOfDay.UpdateTip;
var
  WS: WideString;
begin
  if Tips.Count > 0 then  begin
    WS := Tips[FCurrentTip];
    if FReplaceTabForLineBreak
    then  WS := StrReplaceSimpleW (WS, Tab, sLineBreak);
    FTipLabel.Caption := WS;
  end;
  if Tips.Count <= 1 then  begin
    FNextTipButton.Enabled := False;
    FPriorTipButton.Enabled := False;
  end;
  FTripCount.Caption := IntToStr (FCurrentTip+1) + '/' + IntToStr (Tips.Count);
end {UpdateTip};

{-PUBLIC-----------}

constructor TTntJv0TipOfDay.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTips := TTntStringList.Create;

  FTipFont := TFont.Create;
  FTipFont.OnChange := FontChanged;

  FHeaderFont := TFont.Create;
  FHeaderFont.OnChange := FontChanged;

  FColor := clWhite;
  FDefaultFonts := True;

  UpdateFonts;
  FShowTipsOnStartup := True;
  FReplaceTabForLineBreak := True;
end;

destructor TTntJv0TipOfDay.Destroy;
begin
  FTips.Free;
  FTipFont.Free;
  FHeaderFont.Free;
  inherited Destroy;
end;

procedure TTntJv0TipOfDay.Execute;
var
  LForm: TTntForm;
begin
  // Reentrance check
  if FRunning then
    Exit;
  FRunning := True;
  try
    if not CanShow then
      Exit;
    { toShowOnStartUp will be changed in ExecuteVS/ExecuteStandard if
      the user changes the checkbox }
    LForm := TTntForm.Create(Application);
    with LForm do
    try
      InitVC(LForm);
      FCheckBox.Checked := FShowTipsOnStartup;
      Randomize;
      FCurrentTip := Random(Tips.Count);
      UpdateTip;
      ShowModal;
      FShowTipsOnStartup := FCheckBox.Checked;
    finally
      Free;
    end;
    DoAfterExecute;
  finally
    FRunning := False;
  end;
end {Execute};

procedure TTntJv0TipOfDay.LoadFromFile(const AFileName: WideString);
begin
  if Length(AFileName) = 0 then
    with TTntOpenDialog.Create(Application) do
    try
      if Execute then
        Tips.LoadFromFile(FileName);
    finally
      Free;
    end
  else
  if FileExists(AFileName) then
    Tips.LoadFromFile(AFileName);
end {LoadFromFile};

procedure TTntJv0TipOfDay.SaveToFile(const AFileName: WideString);
begin
  if Length(AFileName) = 0 then
    with TTntSaveDialog.Create(Application) do
    try
      if Execute then
        Tips.SaveToFile(FileName);
    finally
      Free;
    end
  else
    Tips.SaveToFile(AFileName);
end {SaveToFile};

{--------------------------------------}

end.