| Kaf_Dağı | 18 Mart 2015 14:17 |
MSNPopUp componenti
Kod:
unit MSNPopUp;
interface
uses
Windows, ExtCtrls, StdCtrls, Controls, Classes, Graphics, Forms,
ShellApi, Dialogs;
type
TOrientation = (mbHorizontal, mbVertical);
TScrollSpeed = 1..50;
TMSNPopUp = class(TComponent)
private
{ Private declarations }
FURL: String;
FText: String;
FTitle: String;
FIcon: TIcon;
FWidth: Integer;
FHeight: Integer;
FTimeOut: Integer;
FScrollSpeed: TScrollSpeed;
FAllowScroll: Boolean;
FAllowHyperlink: Boolean;
FColor1: TColor;
FColor2: TColor;
FGradientOrientation: TOrientation;
FFont: TFont;
FHoverFont: TFont;
FTitleFont: TFont;
FCursor: TCursor;
FOnClick: TNotifyEvent;
procedure SetIcon(Value: TIcon);
protected
procedure Click; dynamic;
public
procedure ShowPopUp;
published
property Text: String read FText write FText;
property URL: String read FURL write FURL;
property PopUpIcon: TIcon read FIcon write SetIcon stored True;
property TimeOut: Integer read FTimeOut write FTimeOut default 10;
property Width: Integer read FWidth write FWidth default 175;
property Height: Integer read FHeight write FHeight default 175;
property AllowScroll: Boolean read FAllowScroll write FAllowScroll default True;
property AllowHyperlink: Boolean read FAllowHyperlink write FAllowHyperlink default True;
property GradientColor1: TColor read FColor1 write FColor1;
property GradientColor2: TColor read FColor2 write FColor2;
property GradientOrientation: TOrientation read FGradientOrientation write FGradientOrientation default mbVertical;
property ScrollSpeed: TScrollSpeed read FScrollSpeed write FScrollSpeed default 5;
property Font: TFont read FFont write FFont;
property HoverFont: TFont read FHoverFont write FHoverFont;
property Title: String read FTitle write FTitle;
property TitleFont: TFont read FTitleFont write FTitleFont;
property Cursor: TCursor read FCursor write FCursor;
property OnClick: TNotifyEvent read FOnClick write FOnClick;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
type
TfrmMSNPopUp = class(TForm)
pnlBorder: TPanel;
imgIcon: TImage;
lblText: TLabel;
imgGradient: TImage;
tmrExit: TTimer;
tmrScroll: TTimer;
lblTitle: TLabel;
procedure lblTextMouseEnter(Sender: TObject);
procedure lblTextMouseLeave(Sender: TObject);
procedure lblTextClick(Sender: TObject);
procedure tmrExitTimer(Sender: TObject);
procedure lblTextMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure tmrScrollTimer(Sender: TObject);
procedure imgIconMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure imgGradientMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
function CalcColorIndex(StartColor, EndColor: TColor; Steps, ColorIndex: Integer): TColor;
function GetEdge: Integer;
procedure PositionText;
public
URL, Text, Title: String;
TimeOut: Integer;
Icon: TIcon;
sWidth: Integer;
sHeight: Integer;
bScroll, bHyperlink: Boolean;
Color1, Color2: TColor;
Orientation: TOrientation;
ScrollSpeed: TScrollSpeed;
Font, HoverFont, TitleFont: TFont;
StoredBorder: Integer;
Click: TNotifyEvent;
Cursor: TCursor;
procedure PopUp;
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
procedure Register;
implementation
{$R *.dfm}
procedure Register;
begin
RegisterComponents('Ramazan', [TMSNPopUp]);
end;
procedure TMSNPopUp.ShowPopUp;
var
MSNPopUp: TfrmMSNPopUp;
begin
MSNPopUp := TfrmMSNPopUp.Create( Self.Owner );
MSNPopUp.sWidth := FWidth;
MSNPopUp.sHeight := FHeight;
MSNPopUp.Text := FText;
MSNPopUp.URL := FURL;
MSNPopUp.Title := FTitle;
MSNPopUp.TimeOut := FTimeOut;
MSNPopUp.Icon := FIcon;
MSNPopUp.bScroll := FAllowScroll;
MSNPopUp.bHyperlink := FAllowHyperlink;
MSNPopUp.ScrollSpeed := FScrollSpeed;
MSNPopUp.Font := FFont;
MSNPopUp.HoverFont := FHoverFont;
MSNPopUp.TitleFont := FTitleFont;
MSNPopUp.Click := Self.OnClick;
MSNPopUp.Cursor := FCursor;
MSNPopUp.Color1 := FColor1;
MSNPopUp.Color2 := FColor2;
MSNPopUp.Orientation := FGradientOrientation;
MSNPopUp.PopUp;
end;
procedure TMSNPopUp.SetIcon(Value: TIcon);
begin
if Value <> Self.FIcon then
begin
Self.FIcon.Assign(Value);
end;
end;
constructor TMSNPopUp.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FIcon := TIcon.Create;
FFont := TFont.Create;
FHoverFont := TFont.Create;
FTitleFont := TFont.Create;
FWidth := 175;
FHeight := 175;
FTimeOut := 10;
FScrollSpeed := 5;
FText := 'text';
FURL := 'http://<a href="
Bu forumdaki linkleri ve resimleri görebilmek için en az 25 mesajınız olması gerekir.
crDefault;
FColor1 := RGB(0,102,204);
FColor2 := RGB(255,255,255);
FGradientOrientation := mbVertical;
FHoverFont.Style := [fsUnderline];
FHoverFont.Color := clBlue;
FTitleFont.Style := [fsBold];
FAllowScroll := True;
FAllowHyperlink := True;
end;
destructor TMSNPopUp.Destroy;
begin
FIcon.Free;
FFont.Free;
FHoverFont.Free;
FTitleFont.Free;
inherited;
end;
procedure TMSNPopUp.Click;
begin
if Assigned(FOnClick) then
FOnClick(Self);
end;
procedure TfrmMSNPopUp.CreateParams(var Params: TCreateParams);
begin
inherited;
with Params do begin
Style := Style and not WS_CAPTION or WS_POPUP;
ExStyle := ExStyle or WS_EX_TOPMOST or WS_EX_TOOLWINDOW;
WndParent := GetDesktopwindow;
end;
end;
function TfrmMSNPopUp.GetEdge: Integer;
var
AppBar: TAppbarData;
begin
Result := -1;
FillChar( AppBar, sizeof(AppBar), 0);
AppBar.cbSize := Sizeof(AppBar);
if ShAppBarMessage( ABM_GETTASKBARPOS, AppBar ) <> 0 then
begin
if ((AppBar.rc.top = AppBar.rc.left) and (AppBar.rc.bottom > AppBar.rc.right)) then
Result := ABE_LEFT
else if ((AppBar.rc.top = AppBar.rc.left) and (AppBar.rc.bottom < AppBar.rc.right)) then
Result := ABE_TOP
else if (AppBar.rc.top > AppBar.rc.left ) then
Result := ABE_BOTTOM
else
Result := ABE_RIGHT;
end;
end;
procedure TfrmMSNPopUp.PopUp;
var
r: TRect;
gradient: TBitmap;
i: Integer;
begin
SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0);
Self.Height := sHeight;
Self.Width := sWidth;
lblText.Cursor := Cursor;
case GetEdge of
ABE_LEFT:
begin
Self.Left := r.Left + 5;
Self.Top := r.Bottom - Self.Height - 5;
end;
ABE_TOP:
begin
Self.Left := r.Right - Self.Width - 5;
Self.Top := r.Top + 5;
end;
ABE_BOTTOM:
begin
Self.Left := r.Right - Self.Width - 5;
Self.Top := r.Bottom - 5 - Self.Height;
end;
ABE_RIGHT:
begin
Self.Left := r.Right - Self.Width - 5;
Self.Top := r.Bottom - Self.Height - 5;
end;
end;
lblTitle.Font := TitleFont;
lblTitle.Caption := Title;
pnlBorder.Align := alNone;
imgGradient.Align := alNone;
imgGradient.Width := pnlBorder.Width;
imgGradient.Height := pnlBorder.Height;
if Icon.Empty = False then
imgIcon.Picture.Icon := Icon
else
lblTitle.Left := 8;
gradient := TBitmap.Create;
gradient.Width := pnlBorder.Width;
gradient.Height := pnlBorder.Height;
if Orientation = mbVertical then
begin
for i := 0 to gradient.Height do
begin
gradient.Canvas.Pen.Color := CalcColorIndex( Color1, Color2, gradient.Height + 1, i + 1 );
gradient.Canvas.MoveTo(0,i);
gradient.Canvas.LineTo(gradient.width,i);
end;
end;
if Orientation = mbHorizontal then
begin
for i := 0 to gradient.Width do
begin
gradient.Canvas.Pen.Color := CalcColorIndex( Color1, Color2, gradient.Height + 1, i + 1 );
gradient.Canvas.MoveTo(i,0);
gradient.Canvas.LineTo(i,gradient.Height);
end;
end;
imgGradient.Canvas.Draw(0,0,gradient);
gradient.Free;
tmrExit.Interval := TimeOut * 1000;
if bScroll then
begin
if (GetEdge = ABE_TOP) or (GetEdge = ABE_BOTTOM) then
begin
if GetEdge = ABE_BOTTOM then
Self.Top := Self.Top + Self.Height;
Self.Height := 1;
end;
if (GetEdge = ABE_LEFT) or (GetEdge = ABE_RIGHT) then
begin
if GetEdge = ABE_RIGHT then
Self.Left := Self.Left + Self.Width;
Self.Width := 1;
end;
tmrScroll.Enabled := True;
end;
if not bScroll then
tmrExit.Enabled := True;
ShowWindow( Self.Handle, SW_SHOWNOACTIVATE );
Self.Visible := True;
lblText.Font := HoverFont;
PositionText;
lblText.Font := Font;
PositionText;
end;
procedure TfrmMSNPopUp.lblTextMouseEnter(Sender: TObject);
begin
if bHyperlink then
begin
lblText.Font := HoverFont;
PositionText;
end;
end;
procedure TfrmMSNPopUp.lblTextMouseLeave(Sender: TObject);
begin
if bHyperlink then
begin
lblText.Font := Font;
PositionText;
end;
end;
procedure TfrmMSNPopUp.PositionText;
begin
lblText.Caption := Text;
lblText.Width := pnlBorder.Width - 15;
lblText.Left := Round( ( pnlBorder.Width - lblText.Width ) /2 );
lblText.Top := Round( ( pnlBorder.Height - lblText.Height ) /2 );
end;
function TfrmMSNPopUp.CalcColorIndex(StartColor, EndColor: TColor; Steps, ColorIndex: Integer): TColor;
var
BeginRGBValue: Array[0..2] of Byte;
RGBDifference: Array[0..2] of Integer;
Red, Green, Blue: Byte;
NumColors: Integer;
begin
NumColors := Steps;
Dec(ColorIndex);
BeginRGBValue[0] := GetRValue(ColorToRGB(StartColor));
BeginRGBValue[1] := GetGValue(ColorToRGB(StartColor));
BeginRGBValue[2] := GetBValue(ColorToRGB(StartColor));
RGBDifference[0] := GetRValue(ColorToRGB(EndColor)) - BeginRGBValue[0];
RGBDifference[1] := GetGValue(ColorToRGB(EndColor)) - BeginRGBValue[1];
RGBDifference[2] := GetBValue(ColorToRGB(EndColor)) - BeginRGBValue[2];
Red := BeginRGBValue[0] + MulDiv(ColorIndex, RGBDifference[0], NumColors - 1);
Green := BeginRGBValue[1] + MulDiv(ColorIndex, RGBDifference[1], NumColors - 1);
Blue := BeginRGBValue[2] + MulDiv(ColorIndex, RGBDifference[2], NumColors - 1);
Result := RGB(Red, Green, Blue);
end;
procedure TfrmMSNPopUp.lblTextClick(Sender: TObject);
begin
if bHyperlink then
begin
ShellExecute(0, nil, PChar(URL), nil, nil, SW_ShowDefault);
end;
Self.Close;
if Assigned( Click ) then
Click(Sender);
end;
procedure TfrmMSNPopUp.tmrExitTimer(Sender: TObject);
begin
Self.Close;
end;
procedure TfrmMSNPopUp.lblTextMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button = mbRight then
begin
Self.Close;
if Assigned( Click ) then
Click(Sender);
end;
end;
procedure TfrmMSNPopUp.tmrScrollTimer(Sender: TObject);
var
r: TRect;
begin
SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0);
if StoredBorder = 0 then
StoredBorder := GetEdge;
case StoredBorder of
ABE_LEFT:
begin
if (Self.Width + Scrollspeed) < sWidth then
begin
Self.Width := Self.Width + ScrollSpeed;
end
else
begin
Self.Width := sWidth;
tmrScroll.Enabled := False;
tmrExit.Enabled := True;
end;
end;
ABE_TOP:
begin
if (Self.Height + ScrollSpeed) < sHeight then
begin
Self.Height := Self.Height + ScrollSpeed;
end
else
begin
Self.Height := sHeight;
tmrScroll.Enabled := False;
tmrExit.Enabled := True;
end;
end;
ABE_BOTTOM:
begin
if (Self.Height + ScrollSpeed) < sHeight then
begin
Self.Height := Self.Height + ScrollSpeed;
Self.Top := Self.Top - ScrollSpeed;
end
else
begin
Self.Height := sHeight;
Self.Top := r.Bottom - 5 - Self.Height;
tmrScroll.Enabled := False;
tmrExit.Enabled := True;
end;
end;
ABE_RIGHT:
begin
if (Self.Width + ScrollSpeed) < sWidth then
begin
Self.Width := Self.Width + ScrollSpeed;
Self.Left := Self.Left - ScrollSpeed;
end
else
begin
Self.Width := sWidth;
Self.Left := r.Right - 5 - Self.Width;
tmrScroll.Enabled := False;
tmrExit.Enabled := True;
end;
end;
end;
end;
procedure TfrmMSNPopUp.imgIconMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Self.Close;
if Assigned( Click ) then
Click(Sender);
end;
procedure TfrmMSNPopUp.imgGradientMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Self.Close;
if Assigned( Click ) then
Click(Sender);
end;
procedure TfrmMSNPopUp.FormShow(Sender: TObject);
begin
lblText.AutoSize := False;
lblText.Width := 10;
lblText.Height := 10;
lblText.AutoSize := True;
PositionText;
end;
procedure TfrmMSNPopUp.Button1Click(Sender: TObject);
begin
PositionText;
end;
end.
|
