Parsi Coders

نوشتن یک لیبل بصورت مورب
[عکس: 1448682-14c]

کد:
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;

نوشتن کپشن یک دکمه در چند سطر
[عکس: 1448800-516]

کد:
procedure TForm1.FormCreate(Sender: TObject);

begin

SetWindowLong(Button1.Handle,GWL_STYLE,GetWindowLong(Button1.Handle,GWL_STYLE) OR BS_MULTILINE);

end;

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

کد:
procedure TForm1.Button1Click(Sender: TObject);

var

 hn : HWND;

begin

 hn:= FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd',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)
[عکس: 1448749-87e]

کد:
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;

ساختن فرمی برای اتصال به اینترنت با نوشتن نام کاربری و کلمه عبور و شماره تلفن
[عکس: 1448753-9f0]

کد:
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_SHOWMINNOACTIVE);

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_SHOWMINNOACTIVE);

end;

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

[عکس: 1448769-72e]

یک 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;

برش یک فرم و تبدیل آن به دو فرم
[عکس: 1448773-6d7]

کد:
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\CurrentVersion\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;

Amin_Mansouri

Amin_Mansouri