(کدها ومثالها و ترفندهای دلفی)

[king75]

نوشتن یک لیبل بصورت مورب

procedure TForm1.Button1Click(Sender: TObject);

begin

AngleTextOut(Form1.Canvas,12,10,65,'Advanced Delphi Technicals !!');

end;

procedure AngleTextOut(ACanvas: TCanvas;Angle,X,Y: Integer;Str: string);

var

LogRec : TLogFont;

OldFontHandle,NewFontHandle :HFONT;

begin

GetObject(ACanvas.Font.Handle,SizeOf(LogRec),Addr( LogRec));

LogRec.lfEscapement := Angle * 10;

NewFontHandle := CreateFontIndirect(LogRec);

OldFontHandle := SelectObject(ACanvas.Handle,NewFontHandle);

ACanvas.TextOut(X,Y,str);

NewFontHandle := SelectObject(ACanvas.Handle,OldFontHandle);

DeleteObject(NewFontHandle);

end;

نوشتن کپشن یک دکمه در چند سطر

procedure TForm1.FormCreate(Sender: TObject);

begin

SetWindowLong(Button1.Handle,GWL_STYLE,GetWindowLo ng(Button1.Handle,GWL_STYLE) OR BS_MULTILINE);

end;

مخفی کردن و نمایش مجدد ساعت ویندوز

procedure TForm1.Button1Click(Sender: TObject);

var

hn : HWND;

begin

hn:= FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWn d',nil),0,

'TrayNotifyWnd',nil),0,'TrayClockWClass',nil);

if hn <> 0 then

ShowWindow(hn,SW_HIDE);

end;

برای نمایش مجدد همان کدهای بالا تکرار کرده و لی بجای سطر آخر کد زیر را قرار دهید:

ShowWindow(hn,SW_SHOW);

نمایش تمامی اطلاعات مربوط به حافظه اصلی کامپیوتر (RAM)

یک Memo و یک دکمه روی فرم قرار داده و کد زیر را برای دکمه بنویسید:

procedure TForm1.Button1Click(Sender: TObject);

var

MemorysStatus: TMemoryStatus;

begin

Memo1.Lines.Clear;

MemorysStatus.dwLength := SizeOf(MemorysStatus);

GlobalMemoryStatus(MemorysStatus);

with MemorysStatus do

begin

Memo1.Lines.Add(IntToStr(dwLength) + ' Size of Memory Status record');

Memo1.Lines.Add(IntToStr(dwMemoryLoad) + '% Memory in use');

Memo1.Lines.Add(IntToStr(dwTotalPhys) + ' Total Physical Memory in Bytes');

Memo1.Lines.Add(IntToStr(dwAvailPhys) + ' Available Physical Memory in Bytes');

Memo1.Lines.Add(IntToStr(dwTotalPageFile) + ' Total Bytes of Paging File');

Memo1.Lines.Add(IntToStr(dwAvailPageFile) + ' Available Bytes in Paging File');

Memo1.Lines.Add(IntToStr(dwTotalVirtual) + ' User Bytes of Address Space');

Memo1.Lines.Add(IntToStr(dwAvailVirtual) + ' Available User Bytes of Address Space');

end;

end;

غیرفعال کردن دکمه خروج فرم (Exit)

procedure TForm1.FormCreate(Sender: TObject);

var

hwndHandle : THANDLE;

hMenuHandle : HMENU;

iPos : Integer;

begin

hwndHandle := FindWindow(nil,PChar(Caption));

if (hwndHandle <> 0) then

begin

hMenuHandle := GetSystemMenu(hwndHandle,false);

if (hMenuHandle <> 0 ) then

begin

DeleteMenu(hMenuHandle,SC_CLOSE,MF_BYCOMMAND);

iPos := GetMenuItemCount(hMenuHandle);

Dec(iPos);

if iPos > -1 then

DeleteMenu(hwndHandle,iPos,MF_BYPOSITION);

end;

end;

End;

ساختن فرمی برای اتصال به اینترنت با نوشتن نام کاربری و کلمه عبور و شماره تلفن

procedure TForm1.Connect_ButtonClick(Sender: TObject);

var

cmd,par,fil,dir : PChar;

begin

cmd := 'Open';

fil := 'rasdial.exe';

par := PChar(EditEntry.Text + ' ' + EditUser.Text + ' ' +

EditPass.Text + ' /PHONE:' + EditPhone.Text + ' /PHONEBOOK:c:\test.pbk');

dir := 'C:';

ShellExecute(Self.Handle,cmd,fil,par,dir,SW_SHOWMI NNOACTIVE);

end;

procedure TForm1.DisConnect_ButtonClick(Sender: TObject);

var

cmd,par,fil,dir : PChar;

begin

cmd := 'Open';

fil := 'rasdial.exe';

par := PChar(EditEntry.Text + ' /DISCONNECT');

dir := 'C:';

ShellExecute(Self.Handle,cmd,fil,par,dir,SW_SHOWMI NNOACTIVE);

end;

تغییر رنگ سطرهای یک جدول (StringGrid)

یک StringGrid بر روی فرم گذاشته و در DrawCell آن کد زیر را بنویسید:

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;

Rect: TRect; State: TGridDrawState);

var

dx : Integer;

begin

with (Sender as TStringGrid) do

begin

if(ACol = 0) or (ARow = 0) then

Canvas.Brush.Color := clBtnFace

else

begin

case ARow of

1: Canvas.Font.Color := clGreen;

2: Canvas.Font.Color := clRed;

end;

if ARow mod 2 = 0 then

Canvas.Brush.Color := $00E1FFF9

else

Canvas.Brush.Color := $00FFEBDF;

Canvas.TextRect(Rect,Rect.Left + 2,Rect.Top + 2,Cells[ACol,ARow]);

Canvas.FrameRect(Rect);

end;

end;

end;

برش یک فرم و تبدیل آن به دو فرم

var

Pts: array [1..9] of TPoint;

procedure TForm1.Button2Click(Sender: TObject);

var

I: integer;

hRegion: THandle;

begin

InitSize := Width;

Pts [1] := Point (0, 0);

Pts [2] := Point (Width div 2, 0);

Pts [3] := Point (Width div 2, Height);

Pts [8] := Point (0, Height);

Pts [9] := Point (0, 0);

for i := 0 to 100 do

begin

Left := Left - 1;

Width := Width + 2;

Pts [4] := Point (Width - InitSize div 2, Height);

Pts [5] := Point (Width - InitSize div 2, 0);

Pts [6] := Point (Width, 0);

pts [7] := Point (Width, Height);

HRegion := CreatePolygonRgn (Pts, 9, alternate);

SetWindowRgn (Handle, HRegion, True);

Application.ProcessMessages;

end;

end;

غیر فعال کردن TaskManager

اگر مقدار ورودی تابع True باشد غیرفعال شده ولی اگر مقدار ورودی False باشد دوباره فعال خواهد شد.

Procedure DisableTaskManager(ConstState:Boolean);

var

Reg: TRegistry;

begin

Reg := TRegistry.Create;

try

Reg.RootKey := HKEY_CURRENT_USER;

if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVe rsion\Policies\System',

True)

then Reg.WriteInteger('DisableTaskMgr',Integer(State)); //typecast the boolean to convert it to 1 or 0

finally

Reg.CloseKey;

Reg.Free;

end;

end;

ایجاد اشیا به شکلهای دلخواه

Procedure TForm1.FormCreate(Sender: TObject);

begin

SetWindowRgn(Edit1.Handle,CreateRoundRectRgn(2,2,E dit1.Width - 2,

Edit1.Height - 2,15,15),True);

SetWindowRgn(Button1.Handle,CreateRoundRectRgn(2,2 ,Button1.Width - 2,

Button1.Height - 2,15,15),True);

SetWindowRgn(Panel1.Handle,CreateRoundRectRgn(2,2, Panel1.Width - 2,

Panel1.Height - 2,15,15),True);

SetWindowRgn(ComboBox1.Handle,CreateRoundRectRgn(2 ,2,ComboBox1.Width - 2,

ComboBox1.Height - 2,15,15),True);

SetWindowRgn(Memo1.Handle,CreateRoundRectRgn(2,2,M emo1.Width - 2,

Memo1.Height - 2,15,15),True);

SetWindowRgn(ProgressBar1.Handle,CreateRoundRectRg n(2,2,ProgressBar1.Width - 2,

ProgressBar1.Height - 2,15,15),True);

end;

حذف ، کپی ، انتقال یک پوشه با تمامی زیر پوشه و فایلهای درون آن

Uses ShellApi;

Function CopyDir(const fromDir, toDir: string): Boolean;

var

fos: TSHFileOpStruct;

begin

ZeroMemory(@fos, SizeOf(fos));

with fos do

begin

wFunc := FO_COPY;

fFlags := FOF_FILESONLY;

pFrom := PChar(fromDir + #0);

pTo := PChar(toDir)

end;

Result := (0 = ShFileOperation(fos));

end;

function MoveDir(const fromDir, toDir: string): Boolean;

var

fos: TSHFileOpStruct;

begin

ZeroMemory(@fos, SizeOf(fos));

with fos do

begin

wFunc := FO_MOVE;

fFlags := FOF_FILESONLY;

pFrom := PChar(fromDir + #0);

pTo := PChar(toDir)

end;

Result := (0 = ShFileOperation(fos));

end;

function DelDir(dir: string): Boolean;

var

fos: TSHFileOpStruct;

begin

ZeroMemory(@fos, SizeOf(fos));

with fos do

begin

wFunc := FO_DELETE;

fFlags := FOF_SILENT or FOF_NOCONFIRMATION;

pFrom := PChar(dir + #0);

end;

Result := (0 = ShFileOperation(fos));

end;