1、先安装下面的控件(下面是全部源码):
unit GHTrackBar;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls ,Commctrl, Consts;
type
TGHTrackBar = class(TWinControl)
private
// FOnScroll: TScrollEvent;
// ghboy+
FOnScroll:TNotifyEvent;
// ghboy+
FOrientation: TTrackBarOrientation;
FTickMarks: TTickMark;
FTickStyle: TTickStyle;
FLineSize: Integer;
FPageSize: Integer;
FThumbLength: Integer;
FSliderVisible: Boolean;
FMin: Integer;
FMax: Integer;
FFrequency: Integer;
FPosition: Integer;
FSelStart: Integer;
FSelEnd: Integer;
FOnChange: TNotifyEvent;
function GetThumbLength: Integer;
procedure SetOrientation(Value: TTrackBarOrientation);
procedure SetParams(APosition, AMin, AMax: Integer);
procedure SetPosition(Value: Integer);
procedure SetMin(Value: Integer);
procedure SetMax(Value: Integer);
procedure SetFrequency(Value: Integer);
procedure SetTickStyle(Value: TTickStyle);
procedure SetTickMarks(Value: TTickMark);
procedure SetLineSize(Value: Integer);
procedure SetPageSize(Value: Integer);
procedure SetThumbLength(Value: Integer);
procedure SetSliderVisible(Value: Boolean);
procedure SetSelStart(Value: Integer);
procedure SetSelEnd(Value: Integer);
procedure UpdateSelection;
procedure CNHScroll(var Message: TWMHScroll);
message CN_HSCROLL;
procedure CNVScroll(var Message: TWMVScroll);
message CN_VSCROLL;
// proceduredo
Scroll(var Message: TWMScroll);
//ghboy +
protected
procedure CreateParams(var Params: TCreateParams);
override;
procedure CreateWnd;
override;
procedure DestroyWnd;
override;
procedure Changed;
dynamic;
// procedure Scroll(ScrollCode: TScrollCode;
var ScrollPos: Integer);
dynamic;
public
constructor Create(AOwner: TComponent);
override;
procedure SetTick(Value: Integer);
published
property Align;
property Anchors;
property BorderWidth;
property Ctl3D;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Constraints;
property LineSize: Integer read FLineSize write SetLineSize default 1;
property Max: Integer read FMax write SetMax default 10;
property Min: Integer read FMin write SetMin default 0;
property Orientation: TTrackBarOrientation read FOrientation write SetOrientation;
property ParentCtl3D;
property ParentShowHint;
property PageSize: Integer read FPageSize write SetPageSize default 2;
property PopupMenu;
property Frequency: Integer read FFrequency write SetFrequency;
property Position: Integer read FPosition write SetPosition;
property SliderVisible: Boolean read FSliderVisible write SetSliderVisible default True;
property SelEnd: Integer read FSelEnd write SetSelend;
property SelStart: Integer read FSelStart write SetSelStart;
property ShowHint;
property TabOrder;
property TabStop default True;
property ThumbLength: Integer read GetThumbLength write SetThumbLength default 20;
property TickMarks: TTickMark read FTickMarks write SetTickMarks;
property TickStyle: TTickStyle read FTickStyle write SetTickStyle;
property Visible;
property OnContextPopup;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnStartDock;
property OnStartDrag;
// property OnScroll: TScrollEvent read FOnScroll write FOnScroll;
//ghboy+
property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;
//ghboy+
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('LCDScreen', [TGHTrackBar]);
end;
{ TGHTrackBar }
{procedure TGHTrackBar.Scroll(ScrollCode: TScrollCode;
var ScrollPos: Integer);
begin
if Assigned(FOnScroll) then
FOnScroll(Self, ScrollCode, ScrollPos);
end;
procedure TGHTrackBar.DoScroll(var Message: TWMScroll);
var
ScrollPos: Integer;
NewPos: Longint;
ScrollInfo: TScrollInfo;
begin
showmessage('gh');
with Messagedo
begin
NewPos := FPosition;
case TScrollCode(ScrollCode) of
scLineUp:
Dec(NewPos, FSmallChange * FRTLFactor);
scLineDown:
Inc(NewPos, FSmallChange * FRTLFactor);
scPageUp:
Dec(NewPos, FLargeChange * FRTLFactor);
scPageDown:
Inc(NewPos, FLargeChange * FRTLFactor);
scPosition, scTrack:
with ScrollInfodo
begin
cbSize := SizeOf(ScrollInfo);
fMask := SIF_ALL;
GetScrollInfo(Handle, SB_CTL, ScrollInfo);
NewPos := nTrackPos;
if not NotRightToLeft then
NewPos := FMax - NewPos;
end;
scTop:
NewPos := FMin;
scBottom:
NewPos := FMax;
end;
with ScrollInfodo
begin
cbSize := SizeOf(ScrollInfo);
fMask := SIF_ALL;
GetScrollInfo(Handle, SB_CTL, ScrollInfo);
NewPos := nTrackPos;
end;
if NewPos < FMin then
NewPos := FMin;
if NewPos > FMax then
NewPos := FMax;
ScrollPos := NewPos;
Scroll(TScrollCode(ScrollCode), ScrollPos);
SetPosition(ScrollPos);
end;
end;
}
procedure TGHTrackBar.Changed;
begin
if Assigned(FOnChange) then
FOnChange(Self);
end;
procedure TGHTrackBar.CNHScroll(var Message: TWMHScroll);
begin
inherited;
FPosition := SendMessage(Handle, TBM_GETPOS, 0, 0);
// Changed;
if Assigned(FOnScroll) then
FOnScroll(Self);
Message.Result := 0;
end;
procedure TGHTrackBar.CNVScroll(var Message: TWMVScroll);
begin
inherited;
FPosition := SendMessage(Handle, TBM_GETPOS, 0, 0);
if Assigned(FOnScroll) then
FOnScroll(Self);
// Changed;
Message.Result := 0;
end;
constructor TGHTrackBar.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 150;
Height := 45;
TabStop := True;
FMin := 0;
FMax := 10;
FLineSize := 1;
FPageSize := 2;
FFrequency := 1;
FThumbLength := 20;
FTickMarks := tmBottomRight;
FTickStyle := tsAuto;
FOrientation := trHorizontal;
ControlStyle := ControlStyle - [csDoubleClicks];
// ControlStyle := [csFramed, csDoubleClicks];
FSliderVisible := True;
end;
procedure TGHTrackBar.CreateParams(var Params: TCreateParams);
const
OrientationStyle: array[TTrackbarOrientation] of DWORD = (TBS_HORZ, TBS_VERT);
TickStyles: array[TTickStyle] of DWORD = (TBS_NOTICKS, TBS_AUTOTICKS, 0);
ATickMarks: array[TTickMark] of DWORD = (TBS_BOTTOM, TBS_TOP, TBS_BOTH);
begin
InitCommonControl(ICC_BAR_CLASSES);
inherited CreateParams(Params);
CreateSubClass(Params, TRACKBAR_CLASS);
// CreateSubClass(Params, 'SCROLLBAR');
with Paramsdo
begin
Style := Style or OrientationStyle[FOrientation] or
TickStyles[FTickStyle] or ATickMarks[FTickMarks] or TBS_FIXEDLENGTH or
TBS_ENABLESELRANGE;
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or
CS_DBLCLKS;
if not FSliderVisible then
Style := Style or TBS_NOTHUMB;
end;
end;
procedure TGHTrackBar.CreateWnd;
begin
inherited CreateWnd;
if HandleAllocated then
begin
SendMessage(Handle, TBM_SETTHUMBLENGTH, FThumbLength, 0);
SendMessage(Handle, TBM_SETLINESIZE, 0, FLineSize);
SendMessage(Handle, TBM_SETPAGESIZE, 0, FPageSize);
SendMessage(Handle, TBM_SETRANGEMIN, 0, FMin);
SendMessage(Handle, TBM_SETRANGEMAX, 0, FMax);
UpdateSelection;
SendMessage(Handle, TBM_SETPOS, 1, FPosition);
SendMessage(Handle, TBM_SETTICFREQ, FFrequency, 1);
end;
end;
procedure TGHTrackBar.DestroyWnd;
begin
inherited DestroyWnd;
end;
function TGHTrackBar.GetThumbLength: Integer;
begin
if HandleAllocated then
Result := SendMessage(Handle, TBM_GETTHUMBLENGTH, 0, 0)
else
Result := FThumbLength;
end;
procedure TGHTrackBar.SetFrequency(Value: Integer);
begin
if Value <> FFrequency then
begin
FFrequency := Value;
if HandleAllocated then
SendMessage(Handle, TBM_SETTICFREQ, FFrequency, 1);
end;
end;
procedure TGHTrackBar.SetLineSize(Value: Integer);
begin
if Value <> FLineSize then
begin
FLineSize := Value;
if HandleAllocated then
SendMessage(Handle, TBM_SETLINESIZE, 0, FLineSize);
end;
end;
procedure TGHTrackBar.SetMax(Value: Integer);
begin
if Value >= FMin then
SetParams(FPosition, FMin, Value);
end;
procedure TGHTrackBar.SetMin(Value: Integer);
begin
if Value <= FMax then
SetParams(FPosition, Value, FMax);
end;
procedure TGHTrackBar.SetOrientation(Value: TTrackBarOrientation);
begin
if Value <> FOrientation then
begin
FOrientation := Value;
if ComponentState * [csLoading, csUpdating] = [] then
SetBounds(Left, Top, Height, Width);
RecreateWnd;
end;
end;
procedure TGHTrackBar.SetPageSize(Value: Integer);
begin
if Value <> FPageSize then
begin
FPageSize := Value;
if HandleAllocated then
SendMessage(Handle, TBM_SETPAGESIZE, 0, FPageSize);
end;
end;
procedure TGHTrackBar.SetParams(APosition, AMin, AMax: Integer);
begin
if AMax < AMin then
raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
if APosition < AMin then
APosition := AMin;
if APosition > AMax then
APosition := AMax;
if (FMin <> AMin) then
begin
FMin := AMin;
if HandleAllocated then
SendMessage(Handle, TBM_SETRANGEMIN, 1, AMin);
end;
if (FMax <> AMax) then
begin
FMax := AMax;
if HandleAllocated then
SendMessage(Handle, TBM_SETRANGEMAX, 1, AMax);
end;
if FPosition <> APosition then
begin
FPosition := APosition;
if HandleAllocated then
SendMessage(Handle, TBM_SETPOS, 1, APosition);
Changed;
end;
end;
procedure TGHTrackBar.SetPosition(Value: Integer);
begin
SetParams(Value, FMin, FMax);
end;
procedure TGHTrackBar.SetSelEnd(Value: Integer);
begin
if Value <> FSelEnd then
begin
FSelEnd := Value;
UpdateSelection;
end;
end;
procedure TGHTrackBar.SetSelStart(Value: Integer);
begin
if Value <> FSelStart then
begin
FSelStart := Value;
UpdateSelection;
end;
end;
procedure TGHTrackBar.SetSliderVisible(Value: Boolean);
begin
if FSliderVisible <> Value then
begin
FSliderVisible := Value;
RecreateWnd;
end;
end;
procedure TGHTrackBar.SetThumbLength(Value: Integer);
begin
if Value <> FThumbLength then
begin
FThumbLength := Value;
if HandleAllocated then
SendMessage(Handle, TBM_SETTHUMBLENGTH, Value, 0);
end;
end;
procedure TGHTrackBar.SetTick(Value: Integer);
begin
if HandleAllocated then
SendMessage(Handle, TBM_SETTIC, 0, Value);
end;
procedure TGHTrackBar.SetTickMarks(Value: TTickMark);
begin
if Value <> FTickMarks then
begin
FTickMarks := Value;
RecreateWnd;
end;
end;
procedure TGHTrackBar.SetTickStyle(Value: TTickStyle);
begin
if Value <> FTickStyle then
begin
FTickStyle := Value;
RecreateWnd;
end;
end;
procedure TGHTrackBar.UpdateSelection;
begin
if HandleAllocated then
begin
if (FSelStart = 0) and (FSelEnd = 0) then
SendMessage(Handle, TBM_CLEARSEL, 1, 0)
else
SendMessage(Handle, TBM_SETSEL, Integer(True), MakeLong(FSelStart, FSelEnd));
end;
end;
end.
2、在看下面的例子
unit Avi_pas;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, MPlayer, ComCtrls, ExtCtrls, GHTrackBar;
type
TForm1 = class(TForm)
Panel1: TPanel;
Animate1: TAnimate;
Panel2: TPanel;
MediaPlayer1: TMediaPlayer;
Button1: TButton;
OpenDialog1: TOpenDialog;
GHTrackBar1: TGHTrackBar;
Timer1: TTimer;
procedure Button1Click(Sender: TObject);
procedure Panel1Resize(Sender: TObject);
procedure FormClose(Sender: TObject;
var Action: TCloseAction);
procedure GHTrackBar1Scroll(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
Timer1.Enabled:=false;
Mediaplayer1.Close ;
if Opendialog1.Execute then
begin
Mediaplayer1.FileName := Opendialog1.FileName ;
Mediaplayer1.Open ;
Mediaplayer1.Display := Animate1;
Mediaplayer1.DisplayRect := panel1.ClientRect ;
Timer1.Enabled:=true;
GHTrackBar1.Max:=Mediaplayer1.Length;
end;
end;
procedure TForm1.Panel1Resize(Sender: TObject);
begin
Mediaplayer1.DisplayRect := panel1.ClientRect ;
end;
procedure TForm1.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Mediaplayer1.Close ;
end;
procedure TForm1.GHTrackBar1Scroll(Sender: TObject);
begin
Mediaplayer1.Position:=GHTrackBar1.Position;
Mediaplayer1.Play;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
GHTrackBar1.Position :=Mediaplayer1.Position ;
end;
end.