أفكار سريعة

تحريك الفورم

type
 TForm1 = class(TForm)

   procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;

 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}
procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
 inherited;
 if  M.Result = htClient then
   M.Result := htCaption;
end;

end.

-------------------------------------------

تهية القرص المرن A

const
 SHFMT_ID_DEFAULT = $FFFF;
 SHFMT_OPT_QUICKFORMAT = 0;
 SHFMT_OPT_FULLFORMAT = 1;
 SHFMT_OPT_SYSONLY = 2;

 SHFMT_ERROR = -1;
 SHFMT_CANCEL = -2;
 SHFMT_NOFORMAT = -3;


var
 Form1: TForm1;

implementation

{$R *.dfm}
function SHFormatDrive(hWnd : HWND; Drive : Word;  fmtID : Word; Options :
Word) : Longint; stdcall;
external 'Shell32.dll' name 'SHFormatDrive';

procedure DiskFormat(Drive:Char);
var
 RetCode : Integer;
begin
 retCode:= SHFormatDrive(GetDesktopwindow,
           Ord(Upcase(Drive))-Ord('A'),
           SHFMT_ID_DEFAULT,
           SHFMT_OPT_QUICKFORMAT);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
DiskFormat('A');
end;

------------------------------------

:lol: :lol:

تحريك Label من اليمن الي اليسر

if Label1.Left<600 then
begin
Label1.Left:=Label1.Left+1;
end
else
Label1.Left:=-214

فتح وأغلاق CD

uses
  MMSystem

فتح

mciSendString('Set cdaudio door open wait', nil, 0, 0);

أغلاق

mciSendString('Set cdaudio door closed wait', nil, 0, 0);

يقوم بحصر التاريخ من...... الي ......

var
Year, Month, Day: Word;
dataIni : Tdate;
begin
DecodeDate(StrToDate(Edit1.Text), Year, Month, Day);
DataIni := EncodeDate(Year, 1, 1);
Query1.Close;
Query1.SQL.Clear;
Query1.SQL.Add('Select * From employee ');
Query1.SQL.Add('Where Name =HireDate+
               'and Data between :DtIni and :DtFim');
Query1.ParamByName('DtIni').AsDateTime := DataIni;
Query1.ParamByName('DtFim').AsDateTime := StrToDate(Edit2.Text);
Query1.Open

;

الخطاء عند تكرار الارقم في DataBase-

const
    eKeyViol = 9729

في OnPostError في Table

أكتاب الكود التالي

if (E is EDBEngineError) then
if (E as EDBEngineError).Errors[0].Errorcode = eKeyViol then
begin
MessageDlg('ÑÞã ÇáãæÙÝ ãæÌæÏ', mtWarning, [mbOK], 0);
Abort;
end;

السلام عليكم ورحمة الله وبركاته

اخواني انا احببت ان اشارككم ولو بشئ بيسط ؟

وبرنامجيهو إبطال مفعول الأزرار الساخنة ctrl+alt+del لويندوز اكس بي وويندوز 2000

يقوم بتعطيل التاسك منجر في الويندوز اكس بي

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,registry, jpeg, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
regis: TRegistry;//هنا نقوم بتعريف الريجستري للدلفي
begin
  regis := TRegistry.Create;
  regis.RootKey := HKEY_CURRENT_USER; //وهنا ليقوم بالدخول للرجستري وفتح الأدلة

  regis.OpenKey('Software', True);
  regis.OpenKey('Microsoft', True);
  regis.OpenKey('Windows', True);
  regis.OpenKey('CurrentVersion', True);
  regis.OpenKey('Policies', True);
  regis.OpenKey('System', True);
  regis.WriteString('DisableTaskMgr', '1');
  regis.CloseKey;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
ShowMessage('مع تحيات منتديات ليبيا كوم www.libyasite.tk ');
end;

end.

السلام عليكم ورحمة الله وبركاته

واليكم اخواني كود اخر ولكنه منقول من منتديات ليبيا كوم وانا وضغت لكم رابط التحميل للكود فقط وهو عبارة عن برنامج يقوم بميزة إدارة التحكم في إضافة أو ازالة البرامج من لوحة التحكم

وهده صورة لبرنامج

ومن هنا رابط التحميل ؟بالزر الأيمن للماوس واختر حفظ الهدف بإسم

تحياتي للجميع والسلام عليكم ورحمة الله وبركاته

كود لجعل الشاشة شفافة

procedure TForm1.FormClose
(Sender: TObject; var Action: TCloseAction);
var
  i, cavb : 0..255;
begin
  if AlphaBlend=False then
  begin
    AlphaBlendValue:=255;
    AlphaBlend:=True;
  end;
  cavb:=AlphaBlendValue;

  for i := cavb downto 0 do
  begin
    AlphaBlendValue := i;
    Application.ProcessMessages;
  end
end;

قانصة الالغام بالدلفي

ان اردتم وضع الكود بدون شرح

اضعه والا انتظروني قليلا

Saolei.rar

زركشة جميلة :)

ايضا

ان اردتم وضع الكود بدون شرح

اضعه والا انتظروني قليلا

اخي عروة ابعث لي بريدك لا

جميل.rar

قانصة الغام خفيفة مع الصوت وايضا مع السورس

mines.rar

الأكواد بدون شرح .. كلها مرحب بها .. ولكن يفضل نقلها إلى مكتبة الأكواد ... (متخصصة بهذه الامور )

هنا لاداعي للمرفقات .. .. بس شروحات عن افكار برمجية قصيرة ومفيدة ..

يعني هنا شرح بسيط ..

هناك

ملف مرفق بدون شرح ..

بريدي هو orwah@orwah.net

.. (لكل الذين لاحظو نقص تواجدي , فأنا لا اكتب من البيت الآن .. وأحاول الوصول للإنترنت سرقة .. )

سلام يا أحلى شباب

كيف نجعل زر الTab يعمل مع عنصر ال Memo :

Memo إفتراضيا لايقبل tab . ولجعلة يتعامل مع زر tab بإمكانك إضافة هذه الشفره في FormCreate :

procedure TForm1.FormCreate(Sender: TObject);
var
   DialogUnitsX : LongInt;
   PixelsX : LongInt;
   i : integer;
   TabArray : array[0..4] of integer;
begin
   Memo1.WantTabs := true;
   DialogUnitsX := LoWord(GetDialogBaseUnits);
   PixelsX := 25;
   for i := 1 to 5 do begin
    TabArray[i - 1] :=
      ((PixelsX * i ) * 4) div DialogUnitsX;
   end;
   SendMessage(Memo1.Handle,
               EM_SETTABSTOPS,
               5,
               LongInt(@TabArray));
   Memo1.Refresh;
end;

حصر تايخ......

Query1.Close;
Query1.SQL.Clear;
Query1.SQL.Add('Select * from MyTable');
Query1.SQL.Add('where MYDATE Between :RangeStart and :RangeEnd');
Query1.ParamByName('RangeStart').AsDate := StrToDate(Edit1.Text);
Query1.ParamByName('RangeEnd').AsDate := StrToDate(Edit2.Text);
Query1.Open;

:rolleyes:

هذا اول واحدة من كنز كلاشنكوف بابا والاربعين خبير

اظهار و اخفاء زر ابدا

var

  flag:boolean;
....

procedure Startbutton(visi:boolean);
var
  Tray, Child : hWnd;
  C : array[0..127] of Char;
  S : string;
begin
  Tray := FindWindow('Shell_TrayWnd', nil);
  Child := GetWindow(Tray, GW_CHILD);
  while Child <> 0 do
  begin
    if GetClassName(Child, C, SizeOf(C)) > 0 then
    begin
      S := StrPAS(C);
      if UpperCase(S) = 'BUTTON' then
      begin
        if Visi then
          ShowWindow(Child, 1)
        else
          ShowWindow(Child, 0);
      end;
    end;
    Child := GetWindow(Child, GW_HWNDNEXT);
  end;
end;
//=================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
 Startbutton(flag);
 flag:=not flag;
end;

لتفعيل و ايقاف تفعيل ابدا

procedure TForm1.Button2Click(Sender: TObject);
begin
  EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
    0, 'Button', nil), false);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
    0, 'Button', nil), true);
end;

end.

تقوم الدالة باغلاق الجهاز 

ExitWindowsEx(EWX_LOGOFF or ewx_force,0);


هذه الدالة تقوم بإغلاق حميع العمليات مع المحافظة على بيانات التطبيق المستدعي للدالة 



ExitWindowsEx(EWX_SHUTDOWN or ewx_force,0);



تقوم الدالة بوضع النظام في وضع امن بمعنى انها تقوم بتنظيف الذاكرة المؤقتة وحفظ البيانات على القرص الصلب وتقوم بإيقاف جمبع العمليات 

ExitWindowsEx(EWX_REBOOT or ewx_force,0);


اعادة تشغيل النظام 
CODE
ExitWindowsEx(EWX_FORCE or ewx_force,0);


تقوم العبارة التالية بإغلاق جميع التطلبقات بدون ترسل اليهم الرسائل 

WM_QUERYENDSESSION و الWM_ENDSESSIO قد يؤدي هذا الى فقد البينات غير المحفوظة 


ExitWindowsEx(EWX_POWEROFF or ewx_force,0);


اما العبارة التالية فتقوم بغلاق الجهاز مع قطع التلقائي للتيار الكهربائي 
ExitWindowsEx(EWX_FORCEIFHUNG or ewx_force,0);


لاحظ اننا فعلنا كلما ماسبق بدالة واحدة اللهم اننا غيرنا البارمترات 
وهذه طريقة اخرى لإعادة التشغيل 


mov  al,0F0h  
out  64h,al

جعل الEnter يعمل كالزر Tab

private
....
procedure CMDialogKey(var Msg: TWMKey); message CM_DIALOGKEY;


...


procedure TForm1.CMDialogKey(var Msg: TWMKey);
begin

   if Msg.Charcode = 13 then
     Msg.Charcode := 9;
 inherited;
end;

procedure TForm1.Button1Click(Sender: TObject);

var
  i: Integer;
const
  NamePrefix = 'MyEdit';
begin
  for i := 1 to 20 do begin
    TEdit.Create(Self).Name := NamePrefix + IntToStr(i);
    with TEdit(FindComponent(NamePrefix + IntToStr(i))) do
    begin
      Left := 10;
      Top := i * 20;
      Parent := self;
    end;
  end;
end;

//===========================
for t := 1 to 5 do
  FindComponent('Label' + IntToStr(t)).Visible := TRUE;

//==========================



امثلة  للنسخ من وإلى الحافظة المؤقتة 


//*********************************************

function CopyClipToBuf(DC: HDC; Left, Top,
           Width, Height: Integer;  Rop: LongInt;
           var CopyDC: HDC;
           var CopyBitmap: HBitmap): Boolean;

var
  TempBitmap: HBitmap;

begin
  Result := False;
  CopyDC := 0;
  CopyBitmap := 0;
  if DC <> 0 then
    begin
      CopyDC := CreateCompatibleDC(DC);
      if CopyDC <> 0 then
        begin
          CopyBitmap := CreateCompatibleBitmap(DC,
                          Width, Height);
          if CopyBitmap <> 0 then
            begin
              TempBitmap := CopyBitmap;
              CopyBitmap := SelectObject(CopyDC,
                              CopyBitmap);
              Result := BitBlt(CopyDC, 0, 0,
                          Width, Height, DC,
                          Left, Top, Rop);
              CopyBitmap := TempBitmap;
            end;
        end;
    end;
end;
////////////////////////////////////////////////////
function CopyBufToClip(DC: HDC; var CopyDC: HDC;
           var CopyBitmap: HBitmap; 
           Left, Top, Width, Height: Integer;
           Rop: LongInt; DeleteObjects: Boolean): Boolean;

var
  TempBitmap: HBitmap;

begin
  Result := False;
  if (DC <> 0) and
     (CopyDC <> 0) and
     (CopyBitmap <> 0) then
    begin
      TempBitmap := CopyBitmap;
      CopyBitmap := SelectObject(DC, CopyBitmap);
      Result := BitBlt(DC, Left, Top,
                  Width, Height, CopyDC,
                  0, 0, Rop);
      CopyBitmap := TempBitmap;
      if DeleteObjects then
        begin
          DeleteDC(CopyDC);
          DeleteObject(CopyBitmap);
        end;
    end;
end;

//**********************************************




تحديد اخر تغيير للملف


//**********************************************


function GetFileDate(FileName: string): string;

var
  FHandle: Integer;

begin
  FHandle := FileOpen(FileName, 0);
  try
    Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
  finally
    FileClose(FHandle);
  end;
end;

//**********************************************

 كيف تعرف وجود  قرص مرن في محرك الاقراص


type
  TDriveState(DS_NO_DISK, DS_UNFORMATTED_DISK, 
    DS_EMPTY_DISK, DS_DISK_WITH_FILES);

function DriveState(DrvLetter: Char): TDriveState;

var
  Mask: String[6];
  SearchRec: TSearchRec;
  oldMode: Cardinal;
  ReturnCode: Integer;

begin
  oldMode: = SetErrorMode(SEM_FAILCRITICALERRORS);
  Mask:= '?:\*.*';
  Mask[1] := DrvLetter;
  {$I-}  { отключить обработку исключительных ситуаций }
  ReturnCode := FindFirst(Mask, faAnyfile, SearchRec);
  FindClose(SearchRec);

  {$I+}
  case ReturnCode of
    { как минимум один файл был найден }
    0: Result := DS_DISK_WITH_FILES;
    { файлов не найдено и дискета в порядке }
    -18: Result := DS_EMPTY_DISK;
    { DS_NO_DISK для DOS, ERROR_NOT_READY для WinNT, ERROR_PATH_NOT_FOUND для Win 3.1 }
    -21, -3: Result := DS_NO_DISK;
  else
    { дискета лежит в дисководе но она не форматировнная }
    Result := DS_UNFORMATTED_DISK;
  end;
  SetErrorMode(oldMode);
end; { DriveState }


//**********************************************
كيف وضع   افل  حجم  للفورم  

type
  TForm1 = class(TForm)
    procedure wmGetMinMaxInfo(var Msg : TMessage); message wm_GetMinMaxInfo;

procedure TForm1.wmGetMinMaxInfo(var Msg : TMessage); 

begin
  PMinMaxInfo(Msg.lParam)^.ptMinTrackSize.X := 600;
  PMinMaxInfo(Msg.lParam)^.ptMinTrackSize.Y := 350;
end;


//**********************************************

ترتيب الاحداث  عند  انشاء الفورم


OnCreate
    OnShow
    OnPaint
    OnActivate
    OnResize
    OnPaint

تشغيل نسخة واحدة من البرنامج

program Project1;

uses
 Forms,
 Windows, // не забудьте эту строчку
 Unit1 in 'Unit1.pas' {Form1};

 {$R *.RES}

var
 HM: THandle;
function Check: boolean;
begin
 HM := OpenMutex(MUTEX_ALL_ACCESS, false, 'MyOwnMutex');
 Result := (HM <> 0);
 if HM = 0 then
   HM := CreateMutex(nil, false, 'MyOwnMutex');
end;

begin
 if Check then
   Exit;
 Application.Initialize;
 Application.CreateForm(TForm1, Form1);
 Application.Run;
end.

كود يسمح لك بجعل الفورم يتلاشى ببطئ (هذه من الاخ عروة )

Form1.Hide;
 AnimateWindow (Form1.Handle,3000, AW_BLEND);
 // you can also use AW_HOR_POSITIVE, AW_HOR_NEGATIVE,
 // AW_VER_POSITIVE, or AW_VER_NEGATIVE  , AW_BLEND, , AW_BLEND
 Form1.Show;
 Form1.Repaint;

كود لانشاء ملف Word

قم بتشغيل MS Word ثم شغل البرنامج التالي

uses ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  MSWord: Variant;
begin
  try
    MsWord := GetActiveOleObject('Word.Application');
  except
    try
      MsWord := CreateOleObject('Word.Application');
      MsWord.Visible := True;
    except
      Exception.Create('Error');
    end;
  end;
  MSWord.Documents.Add;
  MSWord.Selection.Font.Size := 12;
  MSWord.Selection.TypeText('Текст');
  MSWord.Selection.Font.Bold := true;
  MSWord.Selection.TypeText(#13#10'new');
  MSWord.ActiveDocument.SaveAs('C:\ex.doc');
end;


لا تضغط الزر  اكثر من مرة     :lol:  :lol:

كود لإستدعاء نافذة إاغلاق الوندوز

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendMessage(FindWindow('Progman', 'Program Manager'), 
    WM_CLOSE, 0, 0);
end;

كود لتنشيط النافذة تحت مؤشر الفارة

procedure TForm1.FormCreate(Sender: TObject);
begin
  Timer1.Interval := 50;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  p: TPoint;
begin
  GetCursorPos(p);
  SetForegroundWindow(WindowFromPoint(p));
end;

هذا الكود يراقب كل ثانية اذا كانت شاشة التوقف نشطة ام لا

procedure TForm1.Timer1Timer(Sender: TObject);
var
  s: array [0..255] of char;
begin
  GetClassName(GetForegroundWindow, s, length(s));
  if UpperCase(s) = 'WINDOWSSCREENSAVERCLASS'
    then beep;
end;

تشغيل البرنامج مع بداية تشغيل الوندوز

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
  reg: TRegistry;
begin
  Reg := nil;
  try
    reg := TRegistry.Create;
    reg.RootKey := HKEY_LOCAL_MACHINE;
    reg.LazyWrite := false;
    reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run',
      false);
    reg.WriteString('My App', Application.ExeName);
    reg.CloseKey;
    reg.free;
  except
    if Assigned(Reg) then Reg.Free;

  end;
end;

إظهار واخفاء الTaskBar

اقتباس

procedure TForm1.Button1Click(Sender: TObject);

begin

  ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_Hide);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

  ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_ShowNormal);

end;

تشغيل شاشة التوقف

procedure TForm1.Button1Click(Sender: TObject);
begin
 SendMessage(Form1.Handle, WM_SYSCOMMAND, SC_SCREENSAVE, 0);

end;

تنظيف جميع المستندات من قائمة ابدأ/المستندات

uses ShlOBJ;
.   .   .
procedure TForm1.Button1Click(Sender: TObject);
begin
  SHAddToRecentDocs(SHARD_PATH, nil);
end;

يبدو انني لم اقرا الموضوع جيدا اسف للتكرار

اضافة للقائمة الرئيسية

Private
procedure NewShortcutClick(Sender: TObject);
 …   …  

procedure tform1.addmainitem(s:string);


var
newitem : Tmenuitem;
begin
newitem:=tmenuitem.create(Mainmenu1);
newitem.caption:=s;
mainmenu1.items.insert(mainmenu1.items.count,newitem);
end;

أضافة بند للقائمة

procedure tform1.addsubitem(s:string; t0 : integer);

var
newitem, toitem : Tmenuitem;
begin
{
رقم القائمة التي سنضيف اليها بندا 
}
toitem:=mainmenu1.items[t0];
newitem:=tmenuitem.create(toitem);
newitem.caption:=s;
{
  بامكانك ان تضع ماتريد كاستجابة للنقر على البند 
}

toitem.onclick:= NewShortcutClick;
toitem.insert(toitem.count,newitem);
end;


procedure TForm1.NewShortcutClick(Sender: TObject);
begin
{ write all of what you want as event }
end;

انشاء قاعدة البيانات برمجيا

procedure TForm1.Button2Click(Sender: TObject);
begin
with Table1 do begin
  Active := False;
  DatabaseName := 'MyNewAlias';
  TableType := ttParadox;
  TableName := 'CustInfo';

  { Don't overwrite an existing table }

  if not Table1.Exists then begin
    { The Table component must not be active }
    { First, describe the type of table and give }
    { it a name }
    { Next, describe the fields in the table }
    with FieldDefs do begin
      Clear;
      with AddFieldDef do begin
        Name := 'Field1';
        DataType := ftInteger;
        Required := True;
      end;
      with AddFieldDef do begin

        Name := 'Field2';
        DataType := ftString;
        Size := 30;
      end;
    end;
    { Next, describe any indexes }
    with IndexDefs do begin
      Clear;
      { The 1st index has no name because it is
      { a Paradox primary key }
      with AddIndexDef do begin
        Name := '';
        Fields := 'Field1';
        Options := [ixPrimary];
      end;
      with AddIndexDef do begin

        Name := 'Fld2Indx';
        Fields := 'Field2';
        Options := [ixCaseInsensitive];
      end;
    end;
    { Call the CreateTable method to create the table }
    CreateTable;
  end;
  Table1.Active:= True;
  DataSource1.DataSet:= Table1;
 DBGrid1.DataSource:= DataSource1;
end;


end;

عفوا في المشاركة السابقة رايتم الجدول برمجيا وهذه هي Alias برمجيا

procedure TForm1.Button1Click(Sender: TObject);
begin
Database1.DatabaseName:= 'MyNewAlias';
Database1.DriverName:= 'STANDARD';
Database1.Params.Clear;
end;