Забавное программирование в Delphi
Забавное программирование в Delphi Забавное программирование в Delphi Приведённый здесь материал можно озаглавить не иначе как "Чем заняться программисту, если нечего делать". На самом деле, Delphi настолько интересная среда, что в ней нарядус разработкой серьёзных приложенийможно легко увлечься созданием абсолютно бесполезных вещей.Итак, поехали... Автоматически нажимающаяся кнопкаЭтот компонент представляет из себя кнопку, на которую не надо нажимать, чтобы получить событие OnClick. Достаточно переместить курсор мышки на кнопку. При создании такого компонента традиционным способом, требуется довольно много времени, так как необходимо обрабатывать мышку, перехватывать её и т.д. Однако результат стоит того!Предлагаю взглянуть на две версии данного компонента.В более простой версии обработчик перемещения мышки просто перехватывает сообщения Windows с нужным кодом и вызывает обработчик события OnClick:
TAutoButton1 = class(TButton)
private
procedure WmMouseMove (var Msg: TMessage);
message wm_MouseMove;
end;
procedure TAutoButton1.WmMouseMove (var Msg: TMessage);
begin
inherited;
if Assigned (OnClick) then
OnClick (self);
end;
TAutoKind = (akTime, akMovement, akBoth);
TAutoButton2 = class(TButton)
private
FAutoKind: TAutoKind;
FMovements: Integer;
FSeconds: Integer;
// really private
CurrMov: Integer;
Capture: Boolean;
MyTimer: TTimer;
procedure EndCapture;
// обработчики сообщений
procedure WmMouseMove (var Msg: TWMMouse);
message wm_MouseMove;
procedure TimerProc (Sender: TObject);
procedure WmLBUttonDown (var Msg: TMessage);
message wm_LBUttonDown;
procedure WmLButtonUp (var Msg: TMessage);
message wm_LButtonUp;
public
constructor Create (AOwner: TComponent); override;
published
property AutoKind: TAutoKind
read FAutoKind write FAutoKind default akTime;
property Movements: Integer
read FMovements write FMovements default 5;
property Seconds: Integer
read FSeconds write FSeconds default 10;
end;
begin
inherited;
if not Capture then
begin
SetCapture (Handle);
Capture := True;
CurrMov := 0;
if FAutoKind <> akMovement then
begin
MyTimer := TTimer.Create (Parent);
if FSeconds <> 0 then
MyTimer.Interval := 3000
else
MyTimer.Interval := FSeconds * 1000;
MyTimer.OnTimer := TimerProc;
MyTimer.Enabled := True;
end;
end
else // захватываем
begin
if (Msg.XPos > 0) and (Msg.XPos < Width)
and (Msg.YPos > 0) and (Msg.YPos < Height) then
begin
// если мы подсчитываем кол-во движений...
if FAutoKind <> akTime then
begin
Inc (CurrMov);
if CurrMov >= FMovements then
begin
if Assigned (OnClick) then
OnClick (self);
EndCapture;
end;
end;
end
else // за пределами... стоп!
EndCapture;
end;
end;
procedure TAutoButton2.EndCapture;
begin
Capture := False;
ReleaseCapture;
if Assigned (MyTimer) then
begin
MyTimer.Enabled := False;
MyTimer.Free;
MyTimer := nil;
end;
end;
procedure TAutoButton2.TimerProc (Sender: TObject);
begin
if Assigned (OnClick) then
OnClick (self);
EndCapture;
end;
procedure TAutoButton2.WmLBUttonDown (var Msg: TMessage);
begin
if not Capture then
inherited;
end;
procedure TAutoButton2.WmLButtonUp (var Msg: TMessage);
begin
if not Capture then
inherited;
end;
TInputButton = class(TButton)
private
procedure WmChar (var Msg: TWMChar);
message wm_Char;
end;
procedure TInputButton.WmChar (var Msg: TWMChar);
var
Temp: String;
begin
if Char (Msg.CharCode) = #8 then
begin
Temp := Caption;
Delete (Temp, Length (Temp), 1);
Caption := Temp;
end
else
Caption := Caption + Char (Msg.CharCode);
end;
TInputLabel = class (TLabel)
private
MyEdit: TEdit;
procedure WMLButtonDown (var Msg: TMessage);
message wm_LButtonDown;
protected
procedure EditChange (Sender: TObject);
procedure EditExit (Sender: TObject);
public
constructor Create (AOwner: TComponent); override;
end;
begin
inherited Create (AOwner);
MyEdit := TEdit.Create (AOwner);
MyEdit.Parent := AOwner as TForm;
MyEdit.Width := 0;
MyEdit.Height := 0;
MyEdit.TabStop := False;
MyEdit.OnChange := EditChange;
MyEdit.OnExit := EditExit;
end;
procedure TInputLabel.WMLButtonDown (var Msg: TMessage);
begin
MyEdit.SetFocus;
MyEdit.Text := Caption;
(Owner as TForm).Canvas.DrawFocusRect (BoundsRect);
end;
procedure TInputLabel.EditChange (Sender: TObject);
begin
Caption := MyEdit.Text;
Invalidate;
Update;
(Owner as TForm).Canvas.DrawFocusRect (BoundsRect);
end;
procedure TInputLabel.EditExit (Sender: TObject);
begin
(Owner as TForm).Invalidate;
end;
TDdhSoundButton = class(TButton)
private
FSoundUp, FSoundDown: string;
protected
procedure MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); override;
published
property SoundUp: string
read FSoundUp write FSoundUp;
property SoundDown: string
read FSoundDown write FSoundDown;
end;
Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
inherited;
PlaySound (PChar (FSoundDown), 0, snd_Async);
end;
procedure TDdhSoundButton.MouseUp(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
inherited;
PlaySound (PChar (FSoundUp), 0, snd_Async);
end;
TScreenVirus = class(TComponent)
private
FTimer: TTimer;
FInterval: Cardinal;
FColor: TColor;
FRadius: Integer;
protected
procedure OnTimer (Sender: TObject);
procedure SetInterval (Value: Cardinal);
public
constructor Create (AOwner: TComponent); override;
procedure StartInfection;
published
property Interval: Cardinal
read FInterval write SetInterval;
property Color: TColor
read FColor write FColor default clRed;
property Radius: Integer
read FRadius write FRadius default 10;
end;
constructor TScreenVirus.Create (AOwner: TComponent);
begin
inherited Create (AOwner);
FTimer := TTimer.Create (Owner);
FInterval := FTimer.Interval;
FTimer.Enabled := False;
FTimer.OnTimer := OnTimer;
FColor := clRed;
FRadius := 10;
end;
procedure TScreenVirus.StartInfection;
begin
if Assigned (FTimer) then
FTimer.Enabled := True;
end;
procedure TScreenVirus.SetInterval (Value: Cardinal);
begin
if Value <> FInterval then
begin
FInterval := Value;
FTimer.Interval := Interval;
end;
end;
procedure TScreenVirus.OnTimer (Sender: TObject);
var
hdcDesk: THandle;
Brush: TBrush;
X, Y: Integer;
begin
hdcDesk := GetWindowDC (GetDesktopWindow);
Brush := TBrush.Create;
Brush.Color := FColor;
SelectObject (hdcDesk, Brush.Handle);
X := Random (Screen.Width);
Y := Random (Screen.Height);
Ellipse (hdcDesk, X - FRadius, Y - FRadius,
X + FRadius, Y + FRadius);
ReleaseDC (hdcDesk, GetDesktopWindow);
Brush.Free;
end;
AutoScroll = False
Caption = 'Error'
ClientHeight = 93
ClientWidth = 320
OnShow = FormShow
object Label1: TLabel
Left = 56
= 16
Width = 172
Height = 65
AutoSize = False
Caption =
'Программа выполнила недопустимую ' +
'операцию. Если проблема повторится, ' +
'то обратитесь к разработчику программного обеспечения.'
WordWrap = True
end
object Image1: TImage
Left = 8
= 16
Width = 41
Height = 41
Picture.Data = {...}
end
object Button1: TButton
Left = 240
= 16
Width = 75
Height = 25
Caption = 'Close'
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 240
= 56
Width = 75
Height = 25
Caption = 'Details >>'
TabOrder = 1
OnClick = Button2Click
end
object Memo1: TMemo // за пределами формы!
Left = 24
= 104
Width = 265
Height = 89
Color = clBtnFace
Lines.Strings = (
'AX:BX 73A5:495B'
'SX:PK 676F:FFFF'
'OH:OH 7645:2347'
'Crash 3485:9874'
''
'What'#39's going on here?')
TabOrder = 2
end
end
begin
Height := 231;
end;
begin
Button1.Left := Random (ClientWidth - Button1.Width);
Button1. := Random (ClientHeight - Button1.Height);
end;
var
HRegion1, Hreg2, Hreg3: THandle;
Col: TColor;
begin
ShowMessage ('Ready for a real crash?');
Col := Color;
Color := clRed;
PlaySound ('boom.wav', 0, snd_sync);
HRegion1 := CreatePolygonRgn (Pts,
sizeof (Pts) div 8,
alternate);
SetWindowRgn (
Handle, HRegion1, True);
ShowMessage ('Now, what have you done?');
Color := Col;
ShowMessage ('Вам лучше купить новый монитор');
end;
Отправить комментарий