Mega Code Archive
[] Tek programda bir çok konu
<![CDATA[
{
Delphi FAQs and TIs.chm dosyasından derlediğim tek program
-Başlat çubuğundaki program simgesine sağ tuş menüsü elemanı ekleme
-Fare ile seçim dikdörtgeni yapma
-Bir nesnenin resmini çekip Image1 nesnesine atma
-Bir yazıyı açılı olarak ekrana basma
}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, commctrl, Spin,LzExpand;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
Memo1: TMemo;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure OnAppMessage(var Msg: TMsg; var Handled: Boolean);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT;
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
Capturing : bool;
Captured : bool;
StartPlace : TPoint;
EndPlace : TPoint;
public
{ Public declarations }
end;
const
SC_MyMenuItem = WM_USER + 1;
var
Form1: TForm1;
implementation
{$R *.dfm}
function MakeRect(Pt1 : TPoint;
Pt2 : TPoint) : TRect;
begin
if pt1.x < pt2.x then begin
Result.Left := pt1.x;
Result.Right := pt2.x;
end else begin
Result.Left := pt2.x;
Result.Right := pt1.x;
end;
if pt1.y < pt2.y then begin
Result.Top := pt1.y;
Result.Bottom := pt2.y;
end else begin
Result.Top := pt2.y;
Result.Bottom := pt1.y;
end;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Captured then
DrawFocusRect(Form1.Canvas.Handle,
MakeRect(StartPlace,
EndPlace));
StartPlace.x := X;
StartPlace.y := Y;
EndPlace.x := X;
EndPlace.y := Y;
DrawFocusRect(Form1.Canvas.Handle,
MakeRect(StartPlace,
EndPlace));
Capturing := true;
Captured := true;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Capturing then begin
DrawFocusRect(Form1.Canvas.Handle,
MakeRect(StartPlace,
EndPlace));
EndPlace.x := X;
EndPlace.y := Y;
DrawFocusRect(Form1.Canvas.Handle,
MakeRect(StartPlace,
EndPlace));
end;
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Capturing := false;
end;
procedure TForm1.Button1Click(Sender: TObject); //bir nesnenin resmini çekme...
var
DC : HDC;
begin
DC := GetDC(Memo1.Handle);
BitBlt(form1.Image1.Canvas.Handle,0,0,
Memo1.Width+1,Memo1.Height+1,DC,-2,-2,SrcCopy);
ReleaseDC(Memo1.Handle,DC);
image1.width:=Memo1.width;
image1.Height:=Memo1.Height;
Image1.Repaint;
end;
procedure TForm1.FormCreate(Sender: TObject); //Başlat çubuğunda sağ tuş menüsü
begin
Application.OnMessage := OnAppMessage;
AppendMenu(GetSystemMenu(Application.Handle, FALSE), MF_SEPARATOR, 0, '');
AppendMenu(GetSystemMenu(Application.Handle, FALSE),
MF_STRING,
SC_MyMenuItem,
'Mesaj');
end;
procedure TForm1.OnAppMessage(var Msg: TMsg; var Handled: Boolean);
begin
// Check to see if the message is a system command
// and the message's wParam is SC_MyMenuItem
if (Msg.message = WM_SYSCOMMAND) and (Msg.wParam = SC_MyMenuItem) then
begin
ShowMessage('Got the message');
Handled := True;
end;
end;
procedure TForm1.WMNCPaint(var Msg: TWMNCPaint); //dikdörtgen seçim...
var
dc : hDc;
Pen : hPen;
OldPen : hPen;
OldBrush : hBrush;
begin
inherited;
dc := GetWindowDC(Handle);
msg.Result := 1;
Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0));
OldPen := SelectObject(dc, Pen);
OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
Rectangle(dc, 0,0, Form1.Width, Form1.Height);
SelectObject(dc, OldBrush);
SelectObject(dc, OldPen);
DeleteObject(Pen);
ReleaseDC(Handle, Canvas.Handle);
end;
procedure TForm1.Button2Click(Sender: TObject); //açılı TrueType Font Yazı....
var
lf : TLogFont;
tf : TFont;
begin
with Form1.Canvas do begin
Font.Name := 'Arial';
Font.Size := 24;
tf := TFont.Create;
tf.Assign(Font);
GetObject(tf.Handle, sizeof(lf), @lf);
lf.lfEscapement := 450;
lf.lfOrientation := 450;
tf.Handle := CreateFontIndirect(lf);
Font.Assign(tf);
tf.Free;
TextOut(20, Height div 2, 'Rotated Text!');
end;
end;
end.
]]>