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

// امنع 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)

// هل تريد أن تكون الأسطر الفردية بلون والزوجية بلون اّخر في الـ 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;

//_________________________________________________

المبرمج عماد

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

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;

//_________________________________________________

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

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;

//_________________________________________________

// شغل و أطفئ الــ 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;

// شغل و أطفئ الــ 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;

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

الطريقة 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)

// إضافة مستخدم إلى الـ 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;

//_________________________________________________

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

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

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

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

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

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])) 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)

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

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;

//إجعل الـ 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)

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

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

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

والسلام ..

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

//الحصول على بعض المعلومات الخاصة بالــ 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)

// هل أنا أعمل على 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)

imadouzoun كتب:

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

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

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

والسلام ..

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

←

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

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

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

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

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

بس لاحظ :

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

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

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

عماد ... B)

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

// إطبع ملف الـ 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)

// الان أنقل مجموعة السجلات إلى ملف الـ 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.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.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)

// حمل ملف 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)

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

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)

// الحصول على اسم الـ 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;

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

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

// البحث عن و استبدال كلمة في مستند 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.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.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)