نمونه کد - ترفند - کامپوننت برای ^ Delphi ^

Sampro

Sampro

Member
اضافه كردن يك گزينه به منوي سيستم برنامه :
تو ...
دلفي 7
ويندوز XP
تست شده
کد: 
 [B]uses[/B]
    ExtCtrls;
   
  [B]const[/B]
    idSysAbout=100;
   
  [B]Public[/B]
    [B]procedure [/B]AppMessage([B]var[/B] Msg:TMsg; [B]var[/B] Handled:Boolean);
   
   
  [B]procedure [/B]Tform1.AppMessage([B]var[/B] Msg:TMsg; [B]var[/B] Handled:Boolean);
  [B]begin[/B]
    [B]if[/B] (Msg.[B]message[/B]= WM_SYSCOMMAND) [B]and[/B] (Msg.wParam=idSysAbout) [B]then[/B]
      [B]begin[/B]
        ShowMessage('This is a test.');
        Handled:=true;
      [B]end[/B];
  [B]end[/B];
   
  [B]procedure [/B]TForm1.FormCreate(Sender: TObject);
  [B]begin[/B]
   AppendMenu(GetSystemMenu(Application.Handle,False),
     MF_SEPARATOR,0,'');
   AppendMenu(GetSystemMenu(Application.Handle,False),MF_STRING,
     idSysAbout,'Test');
   Application.OnMessage:=AppMessage;
  [B][FONT=&quot]end[/FONT][/B][FONT=&quot];[/FONT]

​
 
Silver PC

Silver PC

Well-Known Member
" به جاي استفاده از کليد تب از کليد ايــــــنتر استفاده کنيم "

تست شده در دلفی : 5 و 6 و 7
ویندوز اکس پی

کد: 
procedure TForm1.Edit3KeyPress(Sender: TObject; var Key: Char);
begin
if Key = #13 then { if it's an enter key }
Key := #0; { eat enter key }
Perform(WM_NEXTDLGCTL, 0, 0); { move to next control }

end;
 
Silver PC

Silver PC

Well-Known Member
" تغيير روزوليشن صفحه ويندوز "

تست شده در دلفی: 7
ویندوز اکس پی

کد: 
function SetDisplay1024x768: Boolean;

var

DevMode: TDeviceMode;

begin

EnumDisplaySettings(nil, 0, DevMode);

DevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;

DevMode.dmPelsWidth := 1024;

DevMode.dmPelsHeight := 768;        

Result := ChangeDisplaySettings(DevMode, CDS_UPDATEREGISTRY)

= DISP_CHANGE_SUCCESSFUL;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

SetDisplay1024x768;

end;
 
Silver PC

Silver PC

Well-Known Member
" ذخيره کردن يک فرم به عنوان يک عکس "

تست شده در دلفی : 6 و 7
ویندوز اکس پی

کد: 
bmp: TBitmap;
begin
  bmp := TBitmap.Create;
  bmp.Height := Form1.Height;
  bmp.Width := Form1.Width;
  DCWindow := GetWindowDC(Form1.Handle);
  BitBlt(bmp.Canvas.Handle, 0, 0, Form1.Width, Form1.Height,
         DCWindow, 0, 0, SRCCOPY);
  bmp.SaveToFile('C:\ScreenShot.bmp');
  ReleaseDC(DCWindow, DCWindow);
  bmp.Free;
end;
 
Silver PC

Silver PC

Well-Known Member
" محاسبه اختلاف دو ساعت در MaskEdit "

تست شده در دلفی 7
ویندوز اکس پی

کد: 
MaskEdit3.Text := FormatDateTime('hh:mm', StrToTime(MaskEdit2.Text)-StrToTime(MaskEdit3.Text));
 
آخرین ویرایش:
Silver PC

Silver PC

Well-Known Member
" مشخص كردن اندازه فايل انتخاب شده "

تست شده در دلفی: 5 و 6 و 7
ویندوز اکس پی

کد: 
procedure TForm1.Button1Click(Sender: TObject);
var
SearchRec: TSearchRec;
begin
if OpenDialog1.Execute then
if FindFirst(OpenDialog1.FileName, faAnyFile, SearchRec) = 0 then
Label1.Caption := FloatToStrF(SearchRec.Size/1048576, ffFixed, 7, 2)+' MB';
FindClose(SearchRec);
end;
 
Silver PC

Silver PC

Well-Known Member
" يک کد براي اينکه فرم به صورت Blind (کم رنگ تا پررنگ) ظاهر شود "

تست شده در دلفی : 5 و 6 و 7
ویندوز کس پی

کد: 
procedure TForm1.FormCreate(Sender: TObject) ;
var
FullRgn, ClientRgn, ButtonRgn: THandle;
Margin, X, Y: Integer;
begin
Margin := (Width - ClientWidth) div 2;
FullRgn := CreateRectRgn(0, 0, Width, Height) ;
X := Margin;
Y := Height - ClientHeight - Margin;
ClientRgn := CreateRectRgn
(X, Y, X + ClientWidth, Y + ClientHeight) ;
CombineRgn(FullRgn, FullRgn, ClientRgn, RGN_DIFF) ;
X := X + Button1.Left;               
Y := Y + Button1.Top;
ButtonRgn := CreateRectRgn
(X, Y, X + Button1.Width, Y + Button1.Height) ;
CombineRgn(FullRgn, FullRgn, ButtonRgn, RGN_OR) ;
SetWindowRgn(Handle, FullRgn, True) ;
end;
 
Silver PC

Silver PC

Well-Known Member
" AutoSize کردن ستون هاي يک DBGrid را براي Fit شدن "

تست شده در دلفی 7
ویندوز اکس پی

کد: 
procedure SetGridColumnWidths(Grid: Tdbgrid);
const
   DEFBORDER = 10;
var
  temp, n: Integer;
  lmax: array [0..30] of Integer;
begin
  with Grid do
    begin
      Canvas.Font := Font;
      for n := 0 to Columns.Count - 1 do
      lmax[n] := Canvas.TextWidth(Fields[n].FieldName) + DEFBORDER;
      grid.DataSource.DataSet.First;
      while not grid.DataSource.DataSet.EOF do 
        begin
          for n := 0 to Columns.Count - 1 do 
            begin
              temp := Canvas.TextWidth(trim(Columns[n].Field.DisplayText)) + DEFBORDER;
              if temp > lmax[n] then lmax[n] := temp;
            end; 
          grid.DataSource.DataSet.Next;
        end; 
      grid.DataSource.DataSet.First;
      for n := 0 to Columns.Count - 1 do
      if lmax[n] > 0 then
      Columns[n].Width := lmax[n];
    end; 
end; 

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetGridColumnWidths(dbgrid3);
end;
 
Silver PC

Silver PC

Well-Known Member
" اجراي ماشين حساب ويندوز در دلفي "

تست شده در دلفی 5 و 6 و 7
ویندوز اکس پی

کد: 
ShellExecute (HWND(nil), 'open', 'calc','', '', SW_SHOWNORMAL);
 
یاسردرا

یاسردرا

Member
تنظیم کردن رنگ پنجره فروم
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, SkinCaption, WinSkinStore, WinSkinData;

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
OldColor:TColor;
elemnt:tcolor=color_btnface;
implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
if colordialog1.execute then
begin
SetSysColors(1,elemnt,colordialog1.color);
end;

end;

procedure TForm1.FormShow(Sender: TObject);
begin
oldcolor:=GetSysColor(color_btnface);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
SetSysColors(1,elemnt,oldcolor);
end;

end.​
 
برای ارسال پاسخ شما باید وارد سیستم شوید.

آخرین مطالب مجیدآنلاین

جدیدترین ارسال ها

بالا