imadouzoun

أكواد متفرقة قمت بجمعها DB + comobj + ....

24 ردود في هذا الموضوع

// إضافة حقل رقم السطر للـ DBGrid

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

1. استخدم خاصية الأعمدة للـ DBgird وأنشئ فيها عمود

2. غير اسم العمود فيها إلى تسلسل

3. استخدم الحدث و اكتب فيها الشيفرة التالية OnDrawColumncell

+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
 DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
 if DataSource1.DataSet.RecNo > 0 then
 begin
   if Column.Title.Caption = 'No' then
     DBGrid1.Canvas.TextOut(Rect.Left + 2, Rect.Top, IntToStr(DataSource1.DataSet.RecNo));
 end;
end;

//تغيير عرض العمود ضمن الـشبكة ليصبح بعرض المحتويات تماماً

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
     //if columns[n].visible then
     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
       //if columns[n].visible then begin
       temp := Canvas.TextWidth(trim(Columns[n].Field.DisplayText)) + DEFBORDER;
       if temp > lmax[n] then lmax[n] := temp;
       //end; { if }
     end; {for}
     grid.DataSource.DataSet.Next;
   end; { while }
   grid.DataSource.DataSet.First;
   for n := 0 to Columns.Count - 1 do
     if lmax[n] > 0 then
       Columns[n].Width := lmax[n];
 end; { With }
end; {SetGridColumnWidths  }

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

المبرمج عماد

2

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// امنع Alt + F4 للمستخدم

procedure TForm1.FormCreate(Sender: TObject); 
begin
 // set your applications message handler to your new one
 Application.OnMessage := AppMessage;
end;

procedure TForm1.AppMessage(var Msg: TMSG; var Handled: Boolean);
begin
 // let your application handle all messages initially
 Handled := False;
 case Msg.Message of
   WM_SYSKEYDOWN:
     if Msg.wParam = VK_F4 then
       Handled := True; // don't allow ALT-F4
 end;
end;

//Or Write in the OnCloseQuery handler CanClose :=  False 
//Oder schreibe im OnCloseQuery Ereignis CanClose := False

المبرمج عماد....... B) B) B)

تم تعديل بواسطه imadouzoun
0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// هل تريد أن تكون الأسطر الفردية بلون والزوجية بلون اّخر في الـ DBGrid

//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

//source for main form :
//...
uses
// ...
Grids, DBGrids, db
//...
procedure artgrid
(Sender: TObject; const Rect: TRect; DataCol: Integer;
Column: TColumn; State: TGridDrawState);
//...
implementation
//...
procedure TForm1.artgrid(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if ((Sender as tdbgrid).DataSource.DataSet.RecNo mod 2) = 0 then
(Sender as tdbgrid).Canvas.Brush.Color := clblue; //or any color
(Sender as tdbgrid).DefaultDrawColumnCell
(rect, datacol, column, state);
end;
//+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

//استخدم الحدث DrawColumnCell  للـ DBGrid لكتابة الأسطر التالية
procedure TForm2.DBGrid2DrawColumnCell
(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
Form1.artgrid(Sender, Rect, DataCol, Column, State);
end;

//_________________________________________________

المبرمج عماد

1

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// إخفاء الساعة من شريط المهام

function ShowTrayClock(bValue: Boolean) : Boolean; 
var
 TrayWnd, TrayNWnd, ClockWnd: HWND;
begin
 TrayWnd  := FindWindow('Shell_TrayWnd', nil);
 TrayNWnd := FindWindowEx(TrayWnd, 0, 'TrayNotifyWnd', nil);
 ClockWnd := FindWindowEx(TrayNWnd, 0, 'TrayClockWClass', nil);
 Result := IsWindow(ClockWnd);
 if Result then
 begin
   ShowWindow(ClockWnd, Ord(bValue));
   PostMessage(ClockWnd, WM_PAINT, 0, 0);
 end;
end;

// Example to hide they clock:

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowTrayClock(Boolean(0));
end;

//_________________________________________________

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// إعادة تشغيل تطبيقك من جديد

procedure TForm1.Button1Click(Sender: TObject); 
var
 FullProgPath: PChar;
begin
 FullProgPath := PChar(Application.ExeName);
 // ShowWindow(Form1.handle,SW_HIDE);
 WinExec(FullProgPath, SW_SHOW);
 Application.Terminate; // أو: Close;
end;

//_________________________________________________

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// شغل و أطفئ الــ caps Lock من تطبيقك

type 
 TKeyType = (ktCapsLock, ktNumLock, ktScrollLock);

procedure SetLedState(KeyCode: TKeyType; bOn: Boolean);
var
 KBState: TKeyboardState;
 Code: Byte;
begin
 case KeyCode of
   ktScrollLock: Code := VK_SCROLL;
   ktCapsLock: Code := VK_CAPITAL;
   ktNumLock: Code := VK_NUMLOCK;
 end;
 GetKeyboardState(KBState);
 if (Win32Platform = VER_PLATFORM_WIN32_NT) then
 begin
   if Boolean(KBState[Code]) <> bOn then
   begin
     keybd_event(Code,
                 MapVirtualKey(Code, 0),
                 KEYEVENTF_EXTENDEDKEY,
                 0);

     keybd_event(Code,
                 MapVirtualKey(Code, 0),
                 KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP,
                 0);
   end;
 end
 else
 begin
   KBState[Code] := Ord(bOn);
   SetKeyboardState(KBState);
 end;
end;

// Example Call:
// Beispielaufruf:

procedure TForm1.Button1Click(Sender: TObject);
begin
 SetLedState(ktCapsLock, True);  // CapsLock on
 SetLedState(ktNumLock, True);  // NumLock on
 SetLedState(ktScrollLock, True);  // ScrollLock on
end;

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// شغل و أطفئ الــ caps Lock من تطبيقك

type 
 TKeyType = (ktCapsLock, ktNumLock, ktScrollLock);

procedure SetLedState(KeyCode: TKeyType; bOn: Boolean);
var
 KBState: TKeyboardState;
 Code: Byte;
begin
 case KeyCode of
   ktScrollLock: Code := VK_SCROLL;
   ktCapsLock: Code := VK_CAPITAL;
   ktNumLock: Code := VK_NUMLOCK;
 end;
 GetKeyboardState(KBState);
 if (Win32Platform = VER_PLATFORM_WIN32_NT) then
 begin
   if Boolean(KBState[Code]) <> bOn then
   begin
     keybd_event(Code,
                 MapVirtualKey(Code, 0),
                 KEYEVENTF_EXTENDEDKEY,
                 0);

     keybd_event(Code,
                 MapVirtualKey(Code, 0),
                 KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP,
                 0);
   end;
 end
 else
 begin
   KBState[Code] := Ord(bOn);
   SetKeyboardState(KBState);
 end;
end;

// Example Call:
// Beispielaufruf:

procedure TForm1.Button1Click(Sender: TObject);
begin
 SetLedState(ktCapsLock, True);  // CapsLock on
 SetLedState(ktNumLock, True);  // NumLock on
 SetLedState(ktScrollLock, True);  // ScrollLock on
end;

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// اختيار سجل عشوائي من بين مجموعة سجلات

الطريقة 1 :

procedure TForm1.FormCreate(Sender: TObject);
begin
 Randomize;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 Table1.First;
 Table1.MoveBy(Random(Table1.RecordCount));
end;

//_________________________________________________

الطريقة 2 :

adoTB.RecordCount := Random(Table1.RecordCount);

المبرمج عماد.............. B) B)

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// إضافة مستخدم إلى الـ Sql Server

procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Use DataBaseName';
ADOCommand1.Execute;
ADOCommand1.CommandText := 'Exec SP_AddUser ' + QuotedStr
('Username');
ADOCommand1.Execute;
end;

//_________________________________________________

// حذف مستخدم من الـ سضم SQL Server

procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Use DataBaseName';
ADOCommand1.Execute;
ADOCommand1.CommandText := 'Exec SP_DropUser ' + QuotedStr
('Username');
ADOCommand1.Execute;
end;

//_________________________________________________

// حذف الــ User's Login من الـ Sql Server

procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Exec SP_DropLogin ' + QuotedStr
('UserName');
ADOCommand1.Execute;
end;

//_________________________________________________

// قائمة بالمستخدمين المفعلين في الـ SQl Server

procedure TForm1.Button1Click(Sender: TObject);
begin
ADOQuery1.SQL.Add('Exec SP_WHO');
ADOQuery1.Active := True;
end;

//_________________________________________________

// هل ترغب بالتخلص من مؤشر الإنتظار الخاص ب SQL ضمن تطبيقك

//هذا الكود يمكنك من استبداله بالمؤشر الذي تريد

{

بسهولة ضعهذا السطر من الكود في الحدث

ON Create

الخاص بالفرم الذي يظهر فيه هذا المؤشر}

procedure TForm1.FormCreate(Sender: TObject);
begin
Screen.Cursors[crSQLWait] := Screen.Cursors[crHourGlass];
// or whatever cursor you would like to replace the SQL hourglass with
end;

//_________________________________________________

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

//إخفاء أيقونات سطح المكتب

ShowWindow(FindWindow(nil, 'Program Manager'), SW_HIDE);

// Show the desktop icons:
ShowWindow(FindWindow(nil, 'Program Manager'), SW_SHOW);

المبرمج عماد ........... B) B)

تم تعديل بواسطه imadouzoun
0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// الحصول على قائمة بالبرمجيات المنصبة علة حاسبك الشخصي ............

uses
 Registry;
 
procedure TForm1.Button1Click(Sender: TObject);
const
 UNINST_PATH = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall';
var
 Reg: TRegistry;
 SubKeys: TStringList;
 ListItem: TlistItem;
 i: integer;
 sDisplayName, sUninstallString: string;
begin
{
 ListView1.ViewStyle := vsReport;
 ListView1.Columns.add;
 ListView1.Columns.add;
 ListView1.Columns[0].caption := 'DisplayName';
 ListView1.Columns[1].caption := 'UninstallString';
 ListView1.Columns[0].Width := 300;
 ListView1.Columns[1].Width := 300;
}
 Reg := TRegistry.Create;
 with Reg do
   try
     with ListView1.Items do
       try
         BeginUpdate;
         Clear;
         RootKey := HKEY_LOCAL_MACHINE;
         if OpenKeyReadOnly(UNINST_PATH) then
         begin
           SubKeys := TStringList.Create;
           try
             GetKeyNames(SubKeys);
             CloseKey;
             for i := 0 to subKeys.Count - 1 do
               if OpenKeyReadOnly(Format('%s\%s', [UNINST_PATH, SubKeys[i]])) then
                 try
                   sDisplayName     := ReadString('DisplayName');
                   sUninstallString := ReadString('UninstallString');
                   if sDisplayName <> '' then
                   begin
                     ListItem         := Add;
                     ListItem.Caption := sDisplayName;
                     ListItem.subitems.Add(sUninstallString);
                   end;
                 finally
                   CloseKey;
                 end;
           finally
             SubKeys.Free;
           end;
         end;
       finally
         ListView1.AlphaSort;
         EndUpdate;
       end;
   finally
     CloseKey;
     Free;
   end;
end;

المبرمج عماد .............. B) B)

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// إعرف نظام الملفات لسواقة محددة

function GetHardDiskPartitionType(const DriveLetter: Char): string;
 // FAT
 // NTFS
var
 NotUsed: DWORD;
 VolumeFlags: DWORD;
 VolumeInfo: array[0..MAX_PATH] of Char;
 VolumeSerialNumber: DWORD;
 PartitionType: array[0..32] of Char;
begin
 GetVolumeInformation(PChar(DriveLetter + ':\'),
   nil, SizeOf(VolumeInfo), @VolumeSerialNumber, NotUsed,
   VolumeFlags, PartitionType, 32);
 Result := PartitionType;
end;

المبرمج عماد ........... B) B)

procedure TForm1.Button1Click(Sender: TObject);
begin
 ShowMessage(GetHardDiskPartitionType('c'));
 ShowMessage(GetHardDiskPartitionType('a'));
end;

تم تعديل بواسطه imadouzoun
0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

//إجعل الـ button يفعل فعل الـ Alt + Tab

// الأمر فيه صعوبة نوعاً ما بسبب أنك عندما تنقر على الزر فإن تطبيقك سيمتلك التركيز بدلاً من التطبيق الذي كان سيملطه بضغط الـ Alt+ Tab

وهذا حل للمشكلة ................

var
 Index: INTEGER;

// Save description of all active windows to listbox
function EnumWindowsProc(Wnd: HWND; lParam: lParam): BOOL; stdcall;
var
 Bezeichnung: array[0..200] of Char;
begin
 if (IsWindowVisible(Wnd) or IsIconic(wnd)) and
   ((GetWindowLong(Wnd, GWL_HWNDPARENT) = 0) or
   (GetWindowLong(Wnd, GWL_HWNDPARENT) = GetDesktopWindow)) and
   (GetWindowLong(Wnd, GWL_EXSTYLE) and WS_EX_TOOLWINDOW = 0) then
 begin
   GetWindowText(Wnd, Bezeichnung, 256);
   if Bezeichnung <> 'GDI+ Window' then
     Form1.Listbox1.Items.Append(Bezeichnung);
 end;
end;

procedure TForm1.Refresh;
begin
 Listbox1.Clear;
 EnumWindows(@EnumWindowsProc, 1);
end;

// Simulate ALT + TAB
procedure Forwardtab;
var
 hWnd: DWORD;
begin
 Refresh;
 if Index < Listbox1.Count - 1 then
   Inc(Index)
 else
   Index := 0;

 hWnd := FindWindow(nil, PChar(Listbox1.Items[Index]));
 if hWnd <> 0 then
 begin
   windows.ShowWindow(hwnd, 1);
   windows.SetForegroundWindow(hWnd);
   windows.SetFocus(hWnd);
 end;
end;

// Simulate ALT + TAB (Backwards)
procedure Backwardtab;
var
 hWnd: DWORD;
begin
 Refresh;
 if Index > 0 then
   Dec(Index)
 else
   Index := listbox1.Count - 1;

 hWnd := FindWindow(nil, PChar(Listbox1.Items[Index]));
 if hWnd <> 0 then
 begin
   windows.ShowWindow(hwnd, 1);
   windows.SetForegroundWindow(hWnd);
   windows.SetFocus(hWnd);
 end;
end;

المبرمج عماد ............... B) B)

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

romanof معنا .؟؟؟؟؟؟؟؟؟ شلونك معلم ؟؟؟

لا تواخذني إنت قلت لي أن أضع الكودات في قسم الكودات الفاعلة والنادرة و أنا لم أفعل ذلك ....

على كل حال إنت بتعرف مصلحة المنتدى أكتر مني شوف أي الأماكن أنسب للكودات و ضعهم فيه , طبعاً من بعد إذنك ...

والسلام ..

عماد أوزون ... سوريا B) B) B)

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

//الحصول على بعض المعلومات الخاصة بالــ cpu >>>>

unit main;

interface

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

type
 Tfrm_main = class(TForm)
   img_info: TImage;
   procedure FormShow(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
   procedure info(s1, s2: string);
 end;

var
 frm_main: Tfrm_main;
 gn_speed_y: Integer;
 gn_text_y: Integer;
const
 gn_speed_x: Integer = 8;
 gn_text_x: Integer  = 15;
 gl_start: Boolean   = True;

implementation

{$R *.DFM}

procedure Tfrm_main.FormShow(Sender: TObject);
var
 _eax, _ebx, _ecx, _edx: Longword;
 i: Integer;
 b: Byte;
 b1: Word;
 s, s1, s2, s3, s_all: string;
begin
 //Set the startup colour of the image
 img_info.Canvas.Brush.Color := clblue;
 img_info.Canvas.FillRect(rect(0, 0, img_info.Width, img_info.Height));


 gn_text_y := 5; //position of the 1st text

 asm                //asm call to the CPUID inst.
   mov eax,0         //sub. func call
   db $0F,$A2         //db $0F,$A2 = CPUID instruction
   mov _ebx,ebx
   mov _ecx,ecx
   mov _edx,edx
 end;

 for i := 0 to 3 do   //extract vendor id
 begin
   b := lo(_ebx);
   s := s + chr(b);
   b := lo(_ecx);
   s1:= s1 + chr(b);
   b := lo(_edx);
   s2:= s2 + chr(b);
   _ebx := _ebx shr 8;
   _ecx := _ecx shr 8;
   _edx := _edx shr 8;
 end;
 info('CPU', '');
 info('   - ' + 'Vendor ID: ', s + s2 + s1);

 asm
   mov eax,1
   db $0F,$A2
   mov _eax,eax
   mov _ebx,ebx
   mov _ecx,ecx
   mov _edx,edx
 end;
 //06B1
 //|0000| |0000 0000| |0000| |00| |00| |0110| |1011| |0001|
 b := lo(_eax) and 15;
 info('   - ' + 'Stepping ID: ', IntToStr(b));
 b := lo(_eax) shr 4;
 info('   - ' + 'Model Number: ', IntToHex(b, 1));
 b := hi(_eax) and 15;
 info('   - ' + 'Family Code: ', IntToStr(b));
 b := hi(_eax) shr 4;
 info('   - ' + 'Processor Type: ', IntToStr(b));
 //31.   28. 27.   24. 23.   20. 19.   16.
 //  0 0 0 0   0 0 0 0   0 0 0 0   0 0 0 0
 b := lo((_eax shr 16)) and 15;
 info('   - ' + 'Extended Model: ', IntToStr(b));

 b := lo((_eax shr 20));
 info('   - ' + 'Extended Family: ', IntToStr(b));

 b := lo(_ebx);
 info('   - ' + 'Brand ID: ', IntToStr(b));
 b := hi(_ebx);
 info('   - ' + 'Chunks: ', IntToStr(b));
 b := lo(_ebx shr 16);
 info('   - ' + 'Count: ', IntToStr(b));
 b := hi(_ebx shr 16);
 info('   - ' + 'APIC ID: ', IntToStr(b));

 //Bit 18 =? 1     //is serial number enabled?
 if (_edx and $40000) = $40000 then
   info('   - ' + 'Serial Number ', 'Enabled')
 else
   info('   - ' + 'Serial Number ', 'Disabled');

 s := IntToHex(_eax, 8);
 asm                  //determine the serial number
   mov eax,3
   db $0F,$A2
   mov _ecx,ecx
   mov _edx,edx
 end;
 s1 := IntToHex(_edx, 8);
 s2 := IntToHex(_ecx, 8);
 Insert('-', s, 5);
 Insert('-', s1, 5);
 Insert('-', s2, 5);
 info('   - ' + 'Serial Number: ', s + '-' + s1 + '-' + s2);

 asm
   mov eax,1
   db $0F,$A2
   mov _edx,edx
 end;
 info('', '');
 //Bit 23 =? 1
 if (_edx and $800000) = $800000 then
   info('MMX ', 'Supported')
 else
   info('MMX ', 'Not Supported');

 //Bit 24 =? 1
 if (_edx and $01000000) = $01000000 then
   info('FXSAVE & FXRSTOR Instructions ', 'Supported')
 else
   info('FXSAVE & FXRSTOR Instructions Not ', 'Supported');

 //Bit 25 =? 1
 if (_edx and $02000000) = $02000000 then
   info('SSE ', 'Supported')
 else
   info('SSE ', 'Not Supported');

 //Bit 26 =? 1
 if (_edx and $04000000) = $04000000 then
   info('SSE2 ', 'Supported')
 else
   info('SSE2 ', 'Not Supported');

 info('', '');

 asm     //execute the extended CPUID inst.
   mov eax,$80000000   //sub. func call
   db $0F,$A2
   mov _eax,eax
 end;

 if _eax > $80000000 then  //any other sub. funct avail. ?
 begin
   info('Extended CPUID: ', 'Supported');
   info('   - Largest Function Supported: ', IntToStr(_eax - $80000000));
   asm     //get brand ID
     mov eax,$80000002
     db $0F
     db $A2
     mov _eax,eax
     mov _ebx,ebx
     mov _ecx,ecx
     mov _edx,edx
   end;
   s  := '';
   s1 := '';
   s2 := '';
   s3 := '';
   for i := 0 to 3 do
   begin
     b := lo(_eax);
     s3:= s3 + chr(b);
     b := lo(_ebx);
     s := s + chr(b);
     b := lo(_ecx);
     s1 := s1 + chr(b);
     b := lo(_edx);
     s2 := s2 + chr(b);
     _eax := _eax shr 8;
     _ebx := _ebx shr 8;
     _ecx := _ecx shr 8;
     _edx := _edx shr 8;
   end;

   s_all := s3 + s + s1 + s2;

   asm
     mov eax,$80000003
     db $0F
     db $A2
     mov _eax,eax
     mov _ebx,ebx
     mov _ecx,ecx
   mov _edx,edx
   end;
   s  := '';
   s1 := '';
   s2 := '';
   s3 := '';
   for i := 0 to 3 do
   begin
     b := lo(_eax);
     s3 := s3 + chr(b);
     b := lo(_ebx);
     s := s + chr(b);
     b := lo(_ecx);
     s1 := s1 + chr(b);
     b := lo(_edx);
     s2 := s2 + chr(b);
     _eax := _eax shr 8;
     _ebx := _ebx shr 8;
     _ecx := _ecx shr 8;
     _edx := _edx shr 8;
   end;
   s_all := s_all + s3 + s + s1 + s2;

   asm
     mov eax,$80000004
     db $0F
     db $A2
     mov _eax,eax
     mov _ebx,ebx
     mov _ecx,ecx
     mov _edx,edx
   end;
   s  := '';
   s1 := '';
   s2 := '';
   s3 := '';
   for i := 0 to 3 do
   begin
     b  := lo(_eax);
     s3 := s3 + chr(b);
     b := lo(_ebx);
     s := s + chr(b);
     b := lo(_ecx);
     s1 := s1 + chr(b);
     b  := lo(_edx);
     s2 := s2 + chr(b);
     _eax := _eax shr 8;
     _ebx := _ebx shr 8;
     _ecx := _ecx shr 8;
     _edx := _edx shr 8;
   end;
   info('Brand String: ', '');
   if s2[Length(s2)] = #0 then setlength(s2, Length(s2) - 1);
   info('', '   - ' + s_all + s3 + s + s1 + s2);
 end
 else
   info('   - Extended CPUID ', 'Not Supported.');
end;

procedure Tfrm_main.info(s1, s2: string);
begin
 if s1 <> '' then
 begin
   img_info.Canvas.Brush.Color := clblue;
   img_info.Canvas.Font.Color  := clyellow;
   img_info.Canvas.TextOut(gn_text_x, gn_text_y, s1);
 end;
 if s2 <> '' then
 begin
   img_info.Canvas.Brush.Color := clblue;
   img_info.Canvas.Font.Color  := clWhite;
   img_info.Canvas.TextOut(gn_text_x + img_info.Canvas.TextWidth(s1), gn_text_y, s2);
 end;
 Inc(gn_text_y, 13);
end;

end.

المبرمج عماد ... B) B) B) B)

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// هل أنا أعمل على virtual pc أم لا ؟؟؟

function running_inside_vpc: boolean; assembler;
asm
 push ebp

 mov  ecx, offset @@exception_handler
 mov  ebp, esp

 push ebx
 push ecx
 push dword ptr fs:[0]
 mov  dword ptr fs:[0], esp

 mov  ebx, 0 // flag
 mov  eax, 1 // VPC function number

 // call VPC
 db 00Fh, 03Fh, 007h, 00Bh

 mov eax, dword ptr ss:[esp]
 mov dword ptr fs:[0], eax
 add esp, 8

 test ebx, ebx
 setz al
 lea esp, dword ptr ss:[ebp-4]
 mov ebx, dword ptr ss:[esp]
 mov ebp, dword ptr ss:[esp+4]
 add esp, 8
 jmp @@ret
 @@exception_handler:
 mov ecx, [esp+0Ch]
 mov dword ptr [ecx+0A4h], -1 // EBX = -1 -> not running, ebx = 0 -> running
 add dword ptr [ecx+0B8h], 4 // -> skip past the detection code
 xor eax, eax // exception is handled
 ret
 @@ret:
end;

المبرمج عماد .......... B) B)

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
romanof معنا .؟؟؟؟؟؟؟؟؟  شلونك معلم ؟؟؟

لا تواخذني إنت قلت لي أن أضع الكودات في قسم الكودات الفاعلة والنادرة و أنا لم أفعل ذلك  ....

على كل حال إنت بتعرف مصلحة المنتدى أكتر مني شوف أي الأماكن أنسب للكودات و ضعهم فيه , طبعاً من بعد إذنك ...

والسلام ..

عماد أوزون  ... سوريا  B)  B)  B)

شكر ا اخي على الاكواد ممتازة فعلا

بس يار يت تحطهم في مكانهم المناسب كي لا نضطر الى تضييع الوقت في نقلهم انت تعرف ان عملية النقل روتينية ومملة

ويا حبذل لو تتاكد ةتشوف المنتدى قبل ما تضيفهم بارك الله

ولا اريد ان اضطر الى تنبيهك بعد المرة يا اخي

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

أنا رح حاول ضيف الباقي على الأكواد الفاعلة والنادرة ...

بس لاحظ :

1- أنا جديد على هالمنتدى ما بعرف قدّر فيما إذا كان الكود مكرر أو مش نادر أو فاعل ..

2- أنا حاولت سابقاً ولكن ظهرت لي رسالة مفادها أنني لا يمكننا إضافة أي شي إلى القسم الأخير ..

على كل حال تكرم عيونك .. ولو .. رح حاول مرة ثانية وثالثة ورابعة إذا أردت ... :lol:

عماد ... B)

حتى الاّن لم أستطع ذلك يا أخي romanof دلّني كيف يمكن ذلك ز أنا جاهز !!!!!

تم تعديل بواسطه imadouzoun
0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// إطبع ملف الـ Excel

uses
 ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
 ExcelApp: OLEVariant;
begin
 // Create an Excel instance
 ExcelApp := CreateOleObject('Excel.Application');
 try
   ExcelApp.Workbooks.Open('C:\test\xyz.xls');
   // you can also modify some settings from PageSetup
   ExcelApp.ActiveSheet.PageSetup.Orientation := xlLandscape;
   // Print it out
    ExcelApp.Worksheets.PrintOut;
 finally
   // Close Excel
   // Excel wieder schliessen
   if not VarIsEmpty(ExcelApp) then
   begin
     ExcelApp.Quit;
     ExcelApp := Unassigned;
   end;
 end;

end;

//---------------

المبرمج عماد ....... B) B) B)

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// الان أنقل مجموعة السجلات إلى ملف الـ Excel

uses DB;

 private
   procedure SendToExcel(aDataSet: TDataSet);


uses
 ComObj, ActiveX, Excel2000; // or Excel97

procedure TForm1.SendToExcel(aDataSet: TDataSet);
var
 PreviewToExcel: TExcelApplication;
 RangeE: Excel2000.Range;
 I, Row: Integer;
 Bookmark: TBookmarkStr;
begin
 PreviewToExcel := TExcelApplication.Create(Self);
 PreviewToExcel.Connect;
 PreviewToExcel.Workbooks.Add(NULL, 0);
 RangeE := PreviewToExcel.ActiveCell;

 for I := 0 to aDataSet.Fields.Count - 1 do
 begin
   RangeE.Value := aDataSet.Fields[I].DisplayLabel;
   RangeE := RangeE.Next;
 end;

 aDataSet.DisableControls;
 try
   Bookmark := aDataSet.Bookmark;
   try
     aDataSet.First;
     Row := 2;
     while not aDataSet.EOF do
     begin
       //Write down Record As Row in msExcel
       RangeE := PreviewToExcel.Range['A' + IntToStr(Row), 'A' + IntToStr(Row)];
       for I := 0 to aDataSet.Fields.Count - 1 do
       begin
         RangeE.Value := aDataSet.Fields[I].AsString;
         RangeE := RangeE.Next;
       end;
       aDataSet.Next;
       Inc(Row);
     end;
   finally
     aDataSet.Bookmark := Bookmark;
   end;
 finally
   aDataSet.EnableControls;
 end;

 RangeE := PreviewToExcel.Range['A1', chr(64 + aDataSet.Fields.Count) + IntToStr(Row - 1)];

 RangeE.AutoFormat(8, NULL, NULL, NULL, NULL, NULL, NULL);
 PreviewToExcel.Visible[0] := True;
 PreviewToExcel.Disconnect;
end;
// الان استخدم الـ Button
procedure TForm1.Button1Click(Sender: TObject);
begin
 SendToExcel(Table1);
end;

//--------------

عماد .... B) B) B)

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// حمل ملف excel في الـ stringgrid

uses
 ComObj;

function Xls_To_StringGrid(AGrid: TStringGrid; AXLSFile: string): Boolean;
const
 xlCellTypeLastCell = $0000000B;
var
 XLApp, Sheet: OLEVariant;
 RangeMatrix: Variant;
 x, y, k, r: Integer;
begin
 Result := False;
 // إنشاء كائن من نوع Excel-ole
 XLApp := CreateOleObject('Excel.Application');
 try
   // إخفاء تطبيق الـ Excel في حال كان يعمل
   XLApp.Visible := False;

   // إفتح WorkBook
   XLApp.Workbooks.Open(AXLSFile);

   // Sheet := XLApp.Workbooks[1].WorkSheets[1];
   Sheet := XLApp.Workbooks[ExtractFileName(AXLSFile)].WorkSheets[1];

   // ولكي تعرف عدد الأسطر والأعمدة المستخدمة سنفعل اخر خلية مستخدمة منها
   Sheet.Cells.SpecialCells(xlCellTypeLastCell, EmptyParam).Activate;
   // الحصول على رقم السطر الأخير
   x := XLApp.ActiveCell.Row;
   // الحصول على رقم العمود الأخير
   y := XLApp.ActiveCell.Column;

   // إسناد القيم السابقة إلى الـ stringgrid
   AGrid.RowCount := x;
   AGrid.ColCount := y;

   // Assign the Variant associated with the WorkSheet to the Delphi Variant

   RangeMatrix := XLApp.Range['A1', XLApp.Cells.Item[X, Y]].Value;
   // حلقة لملئ الـ stringgrid بالقيم من الملف
   k := 1;
   repeat
     for r := 1 to y do
       AGrid.Cells[(r - 1), (k - 1)] := RangeMatrix[K, R];
     Inc(k, 1);
     AGrid.RowCount := k + 1;
   until k > x;
   // تفريغ المتحول RangeMatrix
   RangeMatrix := Unassigned;

 finally
   // إلاغلاق Excel
   if not VarIsEmpty(XLApp) then
   begin
     // XLApp.DisplayAlerts := False;
     XLApp.Quit;
     XLAPP := Unassigned;
     Sheet := Unassigned;
     Result := True;
   end;
 end;
end;

// يمكنك الان اللجوء للـ Button ليكمل عنك
procedure TForm1.Button1Click(Sender: TObject);
begin
 if Xls_To_StringGrid(StringGrid1, 'C:\Table1.xls') then
   ShowMessage('Table has been exported!');
end;

المبرمج عماد ......... B) B) B)

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// لازم الاّن تحديث سطح المكتب

uses
 ShlObj;

procedure RefreshDesktop1;
begin
 SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
end;

procedure RefreshDesktop2;
var
 hDesktop: HWND;
begin
 hDesktop := FindWindowEx(FindWindowEx(FindWindow('Progman', 'Program Manager'), 0,
   'SHELLDLL_DefView', ''), 0, 'SysListView32', '');
 PostMessage(hDesktop, WM_KEYDOWN, VK_F5, 0);
 PostMessage(hDesktop, WM_KEYUP, VK_F5, 1 shl 31);
end

;

المبرمج عماد .... B) B) B)

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

// الحصول على اسم الـ cpu

function CPUname: string; 
var
 Reg: TRegistry;
begin
 CPUname := '';
 Reg := TRegistry.Create;
 try
   Reg.RootKey := HKEY_LOCAL_MACHINE;
   if Reg.OpenKey('\Hardware\Description\System\CentralProcessor\0', False) then
     CPUname := Reg.ReadString('Identifier');
 finally
   Reg.Free;
 end;
end;

//--------------

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

السلام عليكم ::

// البحث عن و استبدال كلمة في مستند Word

uses
 ComObj;
type
 TWordReplaceFlags = set of (wrfReplaceAll, wrfMatchCase, wrfMatchWildcards);

function Word_StringReplace(ADocument: TFileName; SearchString, ReplaceString: string; Flags: TWordReplaceFlags): Boolean;
const
 wdFindContinue = 1;
 wdReplaceOne = 1;
 wdReplaceAll = 2;
 wdDoNotSaveChanges = 0;
var
 WordApp: OLEVariant;
begin
 Result := False;

 // التأكد من وجود الملف
 if not FileExists(ADocument) then
 begin
   ShowMessage('Specified Document not found.');
   Exit;
 end;

// إنشاء كائن من نوع OLE
 try
   WordApp := CreateOLEObject('Word.Application');
 except
   on E: Exception do
   begin
     E.Message := 'Word is not available.';
     raise;
   end;
 end;

 try
  // إخفاء نسخة الـ Word
   WordApp.Visible := False;
   // فتح تطبيق الـ word
   WordApp.Documents.Open(ADocument);
 // تهيئة البارامترات
   WordApp.Selection.Find.ClearFormatting;
   WordApp.Selection.Find.Text := SearchString;
   WordApp.Selection.Find.Replacement.Text := ReplaceString;
   WordApp.Selection.Find.Forward := True;
   WordApp.Selection.Find.Wrap := wdFindContinue;
   WordApp.Selection.Find.Format := False;
   WordApp.Selection.Find.MatchCase := wrfMatchCase in Flags;
   WordApp.Selection.Find.MatchWholeWord := False;
   WordApp.Selection.Find.MatchWildcards := wrfMatchWildcards in Flags;
   WordApp.Selection.Find.MatchSoundsLike := False;
   WordApp.Selection.Find.MatchAllWordForms := False;
 // البحث عن الكلمة
   if wrfReplaceAll in Flags then
     WordApp.Selection.Find.Execute(Replace := wdReplaceAll)
   else
     WordApp.Selection.Find.Execute(Replace := wdReplaceOne);
 // حفظ المستند
   WordApp.ActiveDocument.SaveAs(ADocument);
   Result := True;
 // إغلاق المستند
   WordApp.ActiveDocument.Close(wdDoNotSaveChanges);
 finally
  // إغلاق الـ Word
   WordApp.Quit;
   WordApp := Unassigned;
 end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 Word_StringReplace('C:\Test.doc','Old String','New String',[wrfReplaceAll]);
end;

//--------------------------

// وضع نص في مستند وورد عند الـ BookMark

uses
 ComObj;

procedure TForm1.Button1Click(Sender: TObject);
const
 YourWordDocument = 'c:\test\MyDoc.doc';
var
 BookmarkName, Doc, R: OleVariant;
begin
 // تشغيل نسخة الـ Word
 try
   WordApp := CreateOleObject('Word.Application');
 except
   ShowMessage('Could not start MS Word!');
 end;
 // فتح المستند بمثيل الـ Word
 WordApp.Documents.Open(YourWordDocument);
 Doc := WordApp.ActiveDocument;
// اسم المعلمة أو الـ BookMark
 BookmarkName := 'MyBookMark';

 // البحث عن المعلمة والتأكد من وجودها
 if Doc.Bookmarks.Exists(BookmarkName) then
 begin
   R := Doc.Bookmarks.Item(BookmarkName).Range;
   // إضافة النص عند المعلمة
   R.InsertAfter('منتديات الفريق العربي للبرمجة');
   // تحديد لون الخط مثلاً
   R.Font.Color := clRed;
 end;

 // حفظ المستند و إغلاق مثيل الـ Word
 if not VarIsEmpty(WordApp) then
 begin
   WordApp.DisplayAlerts := 0;
   WordApp.Documents.Item(1).Save;
   WordApp.Quit;
   BookmarkName := Unassigned;
   R := Unassigned;
   WordApp := Unassigned;
 end;
end;

//------------------------------

إرسال جدول من البيانات إلى ملف إكسل :

uses DB;
//---
 private
   procedure SendToExcel(aDataSet: TDataSet);
//---
uses
 ComObj, ActiveX, Excel2000;

procedure TForm1.SendToExcel(aDataSet: TDataSet);
var
 PreviewToExcel: TExcelApplication;
 RangeE: Excel2000.Range;
 I, Row: Integer;
 Bookmark: TBookmarkStr;
begin
 PreviewToExcel := TExcelApplication.Create(Self);
 PreviewToExcel.Connect;
 PreviewToExcel.Workbooks.Add(NULL, 0);
 RangeE := PreviewToExcel.ActiveCell;

 for I := 0 to aDataSet.Fields.Count - 1 do
 begin
   RangeE.Value := aDataSet.Fields[I].DisplayLabel;
   RangeE := RangeE.Next;
 end;

 aDataSet.DisableControls;
 try
   Bookmark := aDataSet.Bookmark;
   try
     aDataSet.First;
     Row := 2;
     while not aDataSet.EOF do
     begin
       // أدخل السجل إلى مستند الـ Excel
       RangeE := PreviewToExcel.Range['A' + IntToStr(Row), 'A' + IntToStr(Row)];
       for I := 0 to aDataSet.Fields.Count - 1 do
       begin
         RangeE.Value := aDataSet.Fields[I].AsString;
         RangeE := RangeE.Next;
       end;
       aDataSet.Next;
       Inc(Row);
     end;
   finally
     aDataSet.Bookmark := Bookmark;
   end;
 finally
   aDataSet.EnableControls;
 end;

 RangeE := PreviewToExcel.Range['A1', chr(64 + aDataSet.Fields.Count) + IntToStr(Row - 1)];
 RangeE.AutoFormat(8, NULL, NULL, NULL, NULL, NULL, NULL);
 PreviewToExcel.Visible[0] := True;
 PreviewToExcel.Disconnect;
end;

// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
 SendToExcel(Table1);
end;

//---------------------------------

// تجهيز التاريخ و الوقت بما يناسب إعدادات الـ SqlServer

function TForm1.GetSQLDateTimeFormat(UDL: string): string;
begin
 Screen.Cursor := crSQLWait;
 if ADOConnection1.Connected then ADOConnection1.Close;
 ADOConnection1.ConnectionString := 'FILE NAME=' + UDL;
 ADOQuery1.SQL.Clear;
 ADOQuery1.SQL.Add('sp_helplanguage @@LANGUAGE');
 Application.ProcessMessages;
 try
   try
     ADOQuery1.Open;
   except
     on E: Exception do MessageBox(Handle,
         PChar('An error has been occured :' + #13#10 + #13#10 + E.Message),
         PChar('Error !'), 16);
   end;
   if (ADOQuery1.Active) and (ADOQuery1.RecordCount > 0) then
     Result := ADOQuery1.FieldByName('dateformat').AsString;
 finally
   Screen.Cursor := crDefault;
 end;
end;


function DateTimeToSQLDateTimeString(Data: TDateTime; Format: string;
 OnlyDate: Boolean = True): string;
var
 y, m, d, h, mm, s, ms: Word;
begin
 DecodeDate(Data, y, m, d);
 DecodeTime(Data, h, mm, s, ms);
 if Format = 'dmy' then
   Result := IntToStr(d) + '-' + IntToStr(m) + '-' + IntToStr(y)
 else if Format = 'ymd' then
   Result := IntToStr(y) + '-' + IntToStr(m) + '-' + IntToStr(d)
 else if Format = 'ydm' then
   Result := IntToStr(y) + '-' + IntToStr(d) + '-' + IntToStr(m)
 else if Format = 'myd' then
   Result := IntToStr(m) + '-' + IntToStr(y) + '-' + IntToStr(d)
 else if Format = 'dym' then
   Result := IntToStr(d) + '-' + IntToStr(y) + '-' + IntToStr(m)
 else
   Result := IntToStr(m) + '-' + IntToStr(d) + '-' + IntToStr(y); //mdy:; //US
 if not OnlyDate then
   Result := Result + ' ' + IntToStr(h) + ':' + IntToStr(mm) + ':' + IntToStr(s);
end;

//Example:
procedure ConvertSQLDateTime;
begin
 ShowMessage(DateTimeToSQLDateTimeString(now, GetSQLLanguage('C:\Engine.udl')));
end;

//-----------------

// كلمات مرور لجداول بارادوكس محمية بكلمة مرور

for PARADOX 7.0 use this password: "jIGGAe" or "cupcdvum"
for PARADOX 5.0 use this password: same thing

//--------------

المبرمج عماد .. B) B)

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
زوار
This topic is now closed to further replies.

  • يستعرض القسم حالياً   0 members

    لا يوجد أعضاء مسجلين يشاهدون هذه الصفحة .