bsskinexctrls.pas

BusinessSkinForm.v6.15汉化版支持delphi和BCB 一套支持Delphi的VCL库

{*******************************************************************}
{                                                                   }
{       Almediadev Visual Component Library                         }
{       BusinessSkinForm                                            }
{       Version 6.15                                                }
{                                                                   }
{       Copyright (c) 2000-2008 Almediadev                          }
{       ALL RIGHTS RESERVED                                         }
{                                                                   }
{       Home:  http://www.almdev.com                                }
{       Support: [e-mail]                                 }
{                                                                   }
{*******************************************************************}

unit bsSkinExCtrls;

{$P+,S-,W-,R-}
{$WARNINGS OFF}
{$HINTS OFF}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Menus, StdCtrls, ExtCtrls, bsSkinData, bsUtils, bsSkinCtrls;

type
  TbsSkinAnimateGauge = class(TbsSkinCustomControl)
  protected
    FImitation: Boolean;
    FCountFrames: Integer;
    FAnimationFrame: Integer;
    FAnimationPauseTimer: TTimer;
    FAnimationTimer: TTimer;
    FAnimationPause: Integer;
    FProgressText: String;
    FShowProgressText: Boolean;
    procedure OnAnimationPauseTimer(Sender: TObject);
    procedure OnAnimationTimer(Sender: TObject);
    procedure SetShowProgressText(Value: Boolean);
    procedure SetProgressText(Value: String);
    procedure GetSkinData; override;
    procedure CreateImage(B: TBitMap);
    procedure DrawProgressText(C: TCanvas);
    procedure CreateControlDefaultImage(B: TBitMap); override;
    procedure CreateControlSkinImage(B: TBitMap); override;
    procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
    function GetAnimationFrameRect: TRect;
    procedure CalcSize(var W, H: Integer); override;
    function CalcProgressRect: TRect;
    procedure StartInternalAnimation;
    procedure StopInternalAnimation;
  public
    ProgressRect, ProgressArea: TRect;
    NewProgressArea: TRect;
    BeginOffset, EndOffset: Integer;
    FontName: String;
    FontStyle: TFontStyles;
    FontHeight: Integer;
    FontColor: TColor;
    ProgressTransparent: Boolean;
    ProgressTransparentColor: TColor;
    ProgressStretch: Boolean;
    AnimationBeginOffset,
    AnimationEndOffset: Integer; 
    //
    AnimationSkinRect: TRect;
    AnimationCountFrames: Integer;
    AnimationTimerInterval: Integer;
    //
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure StartAnimation;
    procedure StopAnimation;
    procedure SetAnimationPause(Value: Integer);
    procedure ChangeSkinData; override;
  published
    property ProgressText: String read FProgressText write SetProgressText;
    property ShowProgressText: Boolean read FShowProgressText write SetShowProgressText;
    property AnimationPause: Integer
      read  FAnimationPause write SetAnimationPause;
    property Align;
    property Enabled;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property PopupMenu;
    property ShowHint;
  end;

  
 
  TbsSkinLinkImage = class(TImage)
  private
    FURL: String;
  protected
    procedure Click; override;
  public
    constructor Create(AOwner : TComponent); override;
  published
    property URL: string read FURL write FURL;
  end;

  TbsSkinLinkLabel = class(TCustomLabel)
  protected
    FMouseIn: Boolean;
    FIndex: Integer;
    FSD: TbsSkinData;
    FSkinDataName: String;
    FDefaultFont: TFont;
    FUseSkinFont: Boolean;
    FDefaultActiveFontColor: TColor;
     FURL: String;
    FUseUnderLine: Boolean;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure SetSkinData(Value: TbsSkinData);
    procedure SetDefaultFont(Value: TFont);
    property Transparent;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure GetSkinData;
    procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
    procedure SetUseUnderLine(Value: Boolean);
  public
    FontName: String;
    FontStyle: TFontStyles;
    FontHeight: Integer;
    FontColor, ActiveFontColor: TColor;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ChangeSkinData;
    procedure Click; override;
  published
    property UseUnderLine: Boolean read FUseUnderLine write SetUseUnderLine;
    property UseSkinFont: Boolean read FUseSkinFont write FUseSkinFont;
    property DefaultActiveFontColor: TColor
      read FDefaultActiveFontColor write FDefaultActiveFontColor;
    property URL: String read FURL write FURL;
    property DefaultFont: TFont read FDefaultFont write SetDefaultFont;
    property SkinData: TbsSkinData read FSD write SetSkinData;
    property SkinDataName: String read FSkinDataName write FSkinDataName;
    property Font;
    property Align;
    property Alignment;
    property Anchors;
    property AutoSize;
    property BiDiMode;
    property Caption;
    property Color;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property FocusControl;
    property ParentBiDiMode;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowAccelChar;
    property ShowHint;
    property Layout;
    property Visible;
    property WordWrap;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;

 TbsSkinXFormButton = class(TbsSkinButton)
 private
   FDefImage: TBitMap;
   FDefActiveImage: TBitMap;
   FDefDownImage: TBitMap;
   FDefMask: TBitMap;
   FDefActiveFontColor: TColor;
   FDefDownFontColor: TColor;
   procedure SetDefImage(Value: TBitMap);
   procedure SetDefActiveImage(Value: TBitMap);
   procedure SetDefDownImage(Value: TBitMap);
   procedure SetDefMask(Value: TBitMap);
 protected
    procedure SetControlRegion; override;
    procedure DrawDefaultButton(C: TCanvas);
    procedure CreateControlDefaultImage(B: TBitMap); override;
    procedure Loaded; override;
 public
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
   procedure ChangeSkinData; override;
   procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
 published
   property DefImage: TBitMap read FDefImage write SetDefImage;
   property DefActiveImage: TBitMap read FDefActiveImage write SetDefActiveImage;
   property DefDownImage: TBitMap read FDefDownImage write SetDefDownImage;
   property DefMask: TBitMap read FDefMask write SetDefMask;
   property DefActiveFontColor: TColor
    read FDefActiveFontColor write FDefActiveFontColor;
   property DefDownFontColor: TColor
    read FDefDownFontColor write FDefDownFontColor;
 end;

implementation

   Uses ShellAPI;

const
  DEF_GAUGE_FRAMES = 10;

// TbsSkinAnimateGauge

constructor TbsSkinAnimateGauge.Create;
begin
  inherited;
  Width := 100;
  Height := 20;
  BeginOffset := 0;
  EndOffset := 0;
  FProgressText := '';
  FShowProgressText := False;
  FSkinDataName := 'gauge';
  FAnimationPause := 1000;
  FAnimationPauseTimer := nil;
  FAnimationTimer := nil;
  FAnimationFrame := 0;
  FCountFrames := 0;
  FImitation := False;
end;

destructor TbsSkinAnimateGauge.Destroy;
begin
  if FAnimationPauseTimer <> nil then FAnimationPauseTimer.Free;
  if FAnimationTimer <> nil then FAnimationTimer.Free;
  inherited;
end;

procedure TbsSkinAnimateGauge.OnAnimationPauseTimer(Sender: TObject);
begin
  StartInternalAnimation;
end;

procedure TbsSkinAnimateGauge.OnAnimationTimer(Sender: TObject);
begin
  Inc(FAnimationFrame);
  if FAnimationFrame > FCountFrames
  then
    StopInternalAnimation;
  RePaint;
end;

procedure TbsSkinAnimateGauge.SetAnimationPause;
begin
  if Value >= 0
  then
    FAnimationPause := Value;
end;

procedure TbsSkinAnimateGauge.StartInternalAnimation;
begin
  if FAnimationPauseTimer <> nil then FAnimationPauseTimer.Enabled := False;
  FAnimationFrame := 0;
  FAnimationTimer.Enabled := True;
  RePaint;
end;

procedure TbsSkinAnimateGauge.StopInternalAnimation;
begin
  if FAnimationPauseTimer <> nil then FAnimationPauseTimer.Enabled := True;
  FAnimationTimer.Enabled := False;
  FAnimationFrame := 0;
  RePaint;
end;

procedure TbsSkinAnimateGauge.StartAnimation;
begin
  if (FIndex = -1) or ((FIndex <> -1) and
     IsNullRect(Self.AnimationSkinRect))
  then
    begin
      FImitation := True;
      FCountFrames := DEF_GAUGE_FRAMES + 5;
    end
  else
    begin
      FImitation := False;
      if AnimationCountFrames = 1
      then
        FCountFrames :=  (RectWidth(NewProgressArea) + RectWidth(AnimationSkinRect) * 2)
         div (RectWidth(AnimationSkinRect) div 3)
      else
        FCountFrames := AnimationCountFrames;
    end;

  if FAnimationPauseTimer <> nil then FAnimationPauseTimer.Free;
  if FAnimationTimer <> nil then FAnimationTimer.Free;

  FAnimationPauseTimer := TTimer.Create(Self);
  FAnimationPauseTimer.Enabled := False;
  FAnimationPauseTimer.OnTimer := OnAnimationPauseTimer;
  FAnimationPauseTimer.Interval := FAnimationPause;
  FAnimationPauseTimer.Enabled := True;

  FAnimationTimer := TTimer.Create(Self);
  FAnimationTimer.Enabled := False;
  FAnimationTimer.OnTimer := OnAnimationTimer;
  if FImitation
  then
    FAnimationTimer.Interval := 40
  else
    FAnimationTimer.Interval := Self.AnimationTimerInterval;
  StartInternalAnimation;
end;

procedure TbsSkinAnimateGauge.StopAnimation;
begin
  FAnimationFrame := 0;

  if FAnimationTimer = nil then  Exit;


  if FAnimationPauseTimer <> nil
  then
    begin
      FAnimationPauseTimer.Enabled := False;
      FAnimationPauseTimer.Free;
      FAnimationPauseTimer := nil;

    end;

  if FAnimationTimer <> nil
  then
    begin
      FAnimationTimer.Enabled := False;
      FAnimationTimer.Free;
      FAnimationTimer := nil;
    end;
  RePaint;  
end;


procedure TbsSkinAnimateGauge.WMEraseBkgnd;
begin
  if not FromWMPaint
  then
    PaintWindow(Msg.DC);
end;

procedure TbsSkinAnimateGauge.DrawProgressText;
var
  S: String;
  TX, TY: Integer;
  F: TLogFont;
begin
  if (FIndex = -1)
  then
    C.Font.Assign(FDefaultFont)
  else
  if (FIndex <> -1) and not FUseSkinFont
  then
    begin
      C.Font.Assign(FDefaultFont);
      C.Font.Color := FontColor;
    end
  else
    with C do
    begin
      Font.Name := FontName;
      Font.Height := FontHeight;
      Font.Style := FontStyle;
      Font.Color := FontColor;
    end;

   if (SkinData <> nil) and (SkinData.ResourceStrData <> nil)
   then
     C.Font.Charset := SkinData.ResourceStrData.CharSet
   else
     C.Font.CharSet := FDefaultFont.Charset;

  S := '';
  if FShowProgressText then S := S + FProgressText;
  if S = '' then Exit;
  with C do
  begin
    TX := Width div 2 - TextWidth(S) div 2;
    TY := Height div 2 - TextHeight(S) div 2;
    Brush.Style := bsClear;
    TextOut(TX, TY, S);
  end;
end;

procedure TbsSkinAnimateGauge.SetShowProgressText;
begin
  FShowProgressText := Value;
  RePaint;
end;

procedure TbsSkinAnimateGauge.SetProgressText;
begin
  FProgressText := Value;
  RePaint;
end;

procedure TbsSkinAnimateGauge.CalcSize;
var
  Offset: Integer;
  W1, H1: Integer;
begin
  inherited;
  if ResizeMode > 0
  then
    begin
      Offset := W - RectWidth(SkinRect);
      NewProgressArea := ProgressArea;
      Inc(NewProgressArea.Right, Offset);
     end
  else
    NewProgressArea := ProgressArea;

  if (FIndex <> -1) and not IsNullRect(AnimationSkinRect) and
     (Self.AnimationCountFrames = 1)
   then
     begin
       FCountFrames :=  (RectWidth(NewProgressArea) + RectWidth(AnimationSkinRect) * 2)
       div (RectWidth(AnimationSkinRect) div 3);
       if (FAnimationTimer <> nil) and FAnimationTimer.Enabled
       then
         if FAnimationFrame > FCountFrames then  FAnimationFrame := 1;
     end;
end;

function TbsSkinAnimateGauge.GetAnimationFrameRect;
var
  fs: Integer;
begin
  if RectWidth(AnimationSkinRect) > RectWidth(AnimationSkinRect)
  then
    begin
      fs := RectWidth(AnimationSkinRect) div AnimationCountFrames;
      Result := Rect(AnimationSkinRect.Left + (FAnimationFrame - 1) * fs,
                 AnimationSkinRect.Top,
                 AnimationSkinRect.Left + FAnimationFrame * fs,
                 AnimationSkinRect.Bottom);
    end
  else
    begin
      fs := RectHeight(AnimationSkinRect) div AnimationCountFrames;
      Result := Rect(AnimationSkinRect.Left,
                     AnimationSkinRect.Top + (FAnimationFrame - 1) * fs,
                     AnimationSkinRect.Right,
                     AnimationSkinRect.Top + FAnimationFrame * fs);
    end;
end;

function TbsSkinAnimateGauge.CalcProgressRect: TRect;
var
  R: TRect;
  FrameWidth: Integer;
begin
  R.Top := NewProgressArea.Top;
  R.Bottom := R.Top + RectHeight(ProgressRect);
  FrameWidth := Width div DEF_GAUGE_FRAMES;
  R.Left := NewProgressArea.Left + (FAnimationFrame - 1) * FrameWidth - 3 * FrameWidth;
  R.Right := R.Left + FrameWidth;
  Result := R;
end;

procedure TbsSkinAnimateGauge.CreateControlSkinImage;
var
  Buffer: TBitMap;
  R, R1: TRect;
  X, Y: Integer;
  XStep: Integer;
begin
  inherited;
  if (FAnimationTimer = nil) or (FCountFrames = 0) or (FAnimationFrame = 0)
  then
    begin
      if ShowProgressText then DrawProgressText(B.Canvas);
      Exit;
    end;
  if FImitation
  then
    begin
      R := CalcProgressRect;
      R.Left := R.Left - RectWidth(R) div 2;