moeintn
پنج شنبه 07 دی 1396, 11:56 صبح
نوشتن یک لیبل بصورت مورب
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(Const State: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;
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(Const State: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;