sptbxjantracker.pas

这是整套横扫千军3D版游戏的源码

unit SpTBXjanTracker;

{
  28/09/06
  This is a quick fix for TjanTracker transparency problem. Background is drawn using TBX themes
  rather than preset color/bitmap. The code here barely works, this is only a temporary fix so that
  the component would be "compatible" with TASClient 0.30!
}


interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, SpTBXControls, SpTBXItem, TBXThemes, TBX, Math;

type
  TonChangedValue= procedure (sender:TObject;NewValue:integer) of object;
  TOnMouseUpAfterChange = procedure (Sender: TObject) of object;

  TjtbOrientation=(jtbHorizontal,jtbVertical);

  TSpTBXjanTracker = class(TCustomControl)
  private
    FThemeType: TSpTBXThemeType;

    FHitRect:TRect;
    FTrackRect:TRect;
    FTumbRect:TRect;
    FTumbPosition:integer;
    FTumbMin:integer;
    FTumbmax:integer;
    FValue: integer;
    FMinimum: integer;
    FMaximum: integer;
    FTrackColor: TColor;
    FTumbColor: TColor;
    FBackColor: TColor;
    FTumbWidth: integer;
    FTumbHeight: integer;
    FTrackHeight: integer;
    FonChangedValue: TonChangedValue;
    FOnMouseUpAfterChange: TOnMouseUpAfterChange;
    FShowCaption: boolean;
    FCaptionColor: TColor;
    FTrackBorder: boolean;
    FTumbBorder: boolean;
    FBackBorder: boolean;
    FCaptionBold: boolean;
    FOrientation: TjtbOrientation;
    FBackBitmap: TBitmap;
    { Added By Steve Childs, 18/4/00 }
    FbClickWasInRect : Boolean;
    FBorderColor: Tcolor;
    FTrackPositionColor: boolean; // Was the original mouse click in the Track Rect ?

    procedure SetThemeType(const Value: TSpTBXThemeType);
//***    procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
    procedure TBMThemeChange(var Message: TMessage); message TBM_THEMECHANGE;
    procedure ForceRepaint;

{    ala:
    function DoDrawChannel(ACanvas: TCanvas; ARect: TRect; const PaintStage: TSpTBXPaintStage): Boolean; virtual;
    function DoDrawChannelTics(ACanvas: TCanvas; X, Y: Integer): Boolean; virtual;
    function DoDrawThumb(ACanvas: TCanvas; ARect: TRect; const PaintStage: TSpTBXPaintStage): Boolean; virtual;

    property ThemeType: TSpTBXThemeType read FThemeType write SetThemeType default thtWindows;

    *** uporablji procedure SpDrawXPTrackBar(ACanvas: TCanvas; ARect: TRect; Part: Cardinal; Vertical, Pushed: Boolean; TickMark: TSpTBXTickMark; Min, Max, SelStart, SelEnd: Integer; ThemeType: TSpTBXThemeType);
        morda?
}


    procedure SetMaximum(const Value: integer);
    procedure SetMinimum(const Value: integer);
    procedure SetValue(const Value: integer);
    procedure SetBackColor(const Value: TColor);
    procedure SetTrackColor(const Value: TColor);
    procedure SetTumbColor(const Value: TColor);
    procedure SetTumbWidth(const Value: integer);
    procedure SetTrackRect;
    procedure SetTumbMinMax;
    procedure SetTumbRect;
    procedure SetTumbHeight(const Value: integer);
    procedure SetTrackHeight(const Value: integer);
    procedure UpdatePosition;
    procedure SetOnChangedValue(const Value: TonChangedValue);
    procedure SetOnMouseUpAfterChange(const Value: TOnMouseUpAfterChange);
    procedure UpdateValue;
    procedure SetCaptionColor(const Value: TColor);
    procedure SetShowCaption(const Value: boolean);
    procedure SetBackBorder(const Value: boolean);
    procedure SetTrackBorder(const Value: boolean);
    procedure SetTumbBorder(const Value: boolean);
    procedure SetCaptionBold(const Value: boolean);
    procedure SetOrientation(const Value: TjtbOrientation);
    procedure SetBackBitmap(const Value: TBitmap);
    procedure BackBitmapChanged(sender:TObject);
    { Added By Steve Childs, 18/4/00 }
    procedure WMEraseBkgnd(var Msg: TWmEraseBkgnd); message WM_ERASEBKGND;
    procedure SetBorderColor(const Value: Tcolor);
    procedure SetTrackPositionColor(const Value: boolean);

    { Private declarations }
  protected
    { Protected declarations }
    procedure doChangedValue(NewValue:integer);
    procedure MouseMove(Shift: TShiftState; X, Y: Integer);override;
    { Added By Steve Childs, 18/4/00 }
    procedure MouseDown(Button: TMouseButton;Shift: TShiftState; X, Y: Integer);override;
    { Added By Steve Childs, 18/4/00 }
    procedure MouseUp(Button: TMouseButton;Shift: TShiftState; X, Y: Integer);override;
    procedure Resize; override;

  public
    { Public declarations }
    constructor Create (AOwner:TComponent);override;
    destructor Destroy; override;
    procedure Paint; override;
  published
    { Published declarations }

    property ThemeType: TSpTBXThemeType read FThemeType write SetThemeType default thtTBX;

    property Minimum:integer read FMinimum write SetMinimum;
    property Maximum:integer read FMaximum write SetMaximum;
    property Value:integer read FValue write SetValue;
    property Orientation:TjtbOrientation read FOrientation write SetOrientation;
    property BackBitmap:TBitmap read FBackBitmap write SetBackBitmap;
    property BackColor:TColor read FBackColor write SetBackColor;
    property BackBorder:boolean read FBackBorder write SetBackBorder;
    property TrackColor:TColor read FTrackColor write SetTrackColor;
    property TrackPositionColor:boolean read FTrackPositionColor write SetTrackPositionColor;
    property TrackBorder:boolean read FTrackBorder write SetTrackBorder;
    property BorderColor:Tcolor read FBorderColor write SetBorderColor;
    {
      Changed Next 4 By Steve Childs, 18/4/00, Corrects Spelling Mistake
      Although, this may cause more trouble than it's worth with exisiting users
      So you might want to comment these out
    }
    property ThumbColor:TColor read FTumbColor write SetTumbColor;
    property ThumbBorder:boolean read FTumbBorder write SetTumbBorder;
    property ThumbWidth:integer read FTumbWidth write SetTumbWidth;
    property ThumbHeight:integer read FTumbHeight write SetTumbHeight;


    property TrackHeight:integer read FTrackHeight write SetTrackHeight;
    property ShowCaption:boolean read FShowCaption write SetShowCaption;
    property CaptionColor:TColor read FCaptionColor write SetCaptionColor;
    property CaptionBold:boolean read FCaptionBold write SetCaptionBold;
    property onChangedValue:TonChangedValue read FonChangedValue write SetOnChangedValue;
    property OnMouseUpAfterChange: TOnMouseUpAfterChange read FOnMouseUpAfterChange write SetOnMouseUpAfterChange;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Spring lobby', [TSpTBXjanTracker]);
end;

{ TSpTBXjanTracker }

constructor TSpTBXjanTracker.Create(AOwner: TComponent);
begin
  inherited;
  
  FThemeType := thtWindows;
  AddThemeNotification(Self);

  width:=150;
  height:=24;
  FOrientation:=jtbHorizontal;
  FTrackHeight:=6;
  FTumbWidth:=20;
  FTumbHeight:=16;
  FBackColor:=clsilver;
  FTrackColor:=clgray;
  FTrackBorder:=true;
  FBorderColor:=clblack;
  FTumbColor:=clsilver;
  FCaptioncolor:=clblack;
  FShowCaption:=true;
  FMinimum:=0;
  FMaximum:=100;
  FValue:=0;
  FBackBitmap := TBitmap.Create;
  FBackBitmap.OnChange := BackBitmapChanged;
end;

destructor TSpTBXjanTracker.Destroy;
begin
  RemoveThemeNotification(Self);
  inherited;
end;

procedure TSpTBXjanTracker.ForceRepaint;
begin
  // NM_CUSTOMDRAW messages are not sent when calling Invalidate, we must
  // recreate the window
  if HandleAllocated then RecreateWnd;
end;

procedure TSpTBXjanTracker.SetThemeType(const Value: TSpTBXThemeType);
begin
  if Value <> FThemeType then begin
    FThemeType := Value;
    ForceRepaint;
  end;
end;

procedure TSpTBXjanTracker.TBMThemeChange(var Message: TMessage);
begin
  inherited;
  if Message.WParam = TSC_AFTERVIEWCHANGE then
    ForceRepaint;
end;

{ ***
hmmm tole bo treba 歟 pogruntat 鑕 sploh potrebujem. Namre