تمامی مسائل و مباحث در مورد دلفی

نصب يك فايل INF در دلفي

کد:

---

uses
  ShellAPI;

function InstallINF(const PathName: string; hParent: HWND): Boolean;
var
  instance: HINST;
begin
  instance := ShellExecute(hParent,
    PChar('open'),
    PChar('rundll32.exe'),
    PChar('setupapi,InstallHinfSection DefaultInstall 132 ' + PathName),
    nil,
    SW_HIDE);

  Result := instance > 32;
end; { InstallINF }

// Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  InstallINF('C:\XYZ.inf', 0);
end;

---

دسترسي به ListBox از طريق API

کد:

---

function LB_GetItemCount(hListBox: THandle): Integer;
begin
  Result := SendMessage(hListBox, LB_GETCOUNT, 0, 0);
end;

// Delete a string in a ListBox
// Einen String in einer ListBox löschen

procedure LB_DeleteItem(hListBox: THandle; Index: Integer);
begin
  SendMessage(hListBox, LB_DELETESTRING, Index, 0);
end;

// Retrieve the selected item from a ListBox
// Gibt den Text des markiertes Items einer ListBox zurück

function LB_GetSelectedItem(hListBox: THandle): string;
var
  Index, len: Integer;
  s: string;
  buffer: PChar;
begin
  Index := SendMessage(hListBox, LB_GETCURSEL, 0, 0);
  len := SendMessage(hListBox, LB_GETTEXTLEN, wParam(Index), 0);
  GetMem(buffer, len + 1);
  SendMessage(hListBox, LB_GETTEXT, wParam(Index), lParam(buffer));
  SetString(s, buffer, len);
  FreeMem(buffer);
  Result := IntToStr(Index) + ' : ' + s;
end;

// Example, Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
var
  hListBox: THandle;
begin
  hListBox := {...}; // listbox handle
  ListBox1.Items.Text := LB_GetSelectedItem(hListBox);
end;

// Retrieve a string from a ListBox
// Gibt den Text eines bestimmten Items einer ListBox zurück

function LB_GetListBoxItem(hWnd: Hwnd; LbItem: Integer): string;
var
  l: Integer;
  buffer: PChar;
begin
  l := SendMessage(hWnd, LB_GETTEXTLEN, LbItem, 0);
  GetMem(buffer, l + 1);
  SendMessage(hWnd, LB_GETTEXT, LbItem, Integer(buffer));
  Result := StrPas(buffer);
  FreeMem(buffer);
end;

// Example, Beispiel:

procedure TForm1.Button2Click(Sender: TObject);
var
  hListBox: THandle;
begin
  hListBox := {...}; // listbox handle
  ListBox1.Items.Text := LB_GetListBoxItem(hListBox, 2);
end;

// Gibt den gesamten Text einer ListBox zurück
// Retrieve all listbox items

function LB_GetAllItems(hWnd: Hwnd; sl: TStrings): string;
var
  RetBuffer: string;
  i, x, y: Integer;
begin
  x := SendMessage(hWnd, LB_GETCOUNT, 0, 0);
  for i := 0 to x - 1 do
  begin
    y := SendMessage(hWnd, LB_GETTEXTLEN, i, 0);
    SetLength(RetBuffer, y);
    SendMessage(hWnd, LB_GETTEXT, i, lParam(PChar(RetBuffer)));
    sl.Add(RetBuffer);
  end;
end;

// Example, Beispiel:

procedure TForm1.Button3Click(Sender: TObject);
var
  sl: TStringList;
  ListBox_Handle: THandle;
begin
  hListBox := {...}; // listbox handle
  sl := TStringList.Create;
  try
    LB_GetAllItems(ListBox_Handle, sl);
  finally
    ListBox1.Items.Text := sl.Text;
    sl.Free;
  end;
end;

---

ليست تمام زيرپوشه هاي يك پوشه اصلي

کد:

---

procedure GetSubDirs(const sRootDir: string; slt: TStrings);
var
  srSearch: TSearchRec;
  sSearchPath: string;
  sltSub: TStrings;
  i: Integer;
begin
  sltSub := TStringList.Create;
  slt.BeginUpdate;
  try
    sSearchPath := AddDirSeparator(sRootDir);
    if FindFirst(sSearchPath + '*', faDirectory, srSearch) = 0 then
      repeat
        if ((srSearch.Attr and faDirectory) = faDirectory) and
          (srSearch.Name <> '.') and
          (srSearch.Name <> '..') then
        begin
          slt.Add(sSearchPath + srSearch.Name);
          sltSub.Add(sSearchPath + srSearch.Name);
        end;
      until (FindNext(srSearch) <> 0);

    FindClose(srSearch);

    for i := 0 to sltSub.Count - 1 do
      GetSubDirs(sltSub.Strings[i], slt);
  finally
    slt.EndUpdate;
    FreeAndNil(sltSub);
  end;
end;

---

جايگزيني يك متن درون TextFile

کد:

---

procedure FileReplaceString(const FileName, searchstring, replacestring: string);
var
  fs: TFileStream;
  S: string;
begin
  fs := TFileStream.Create(FileName, fmOpenread or fmShareDenyNone);
  try
    SetLength(S, fs.Size);
    fs.ReadBuffer(S[1], fs.Size);
  finally
    fs.Free;
  end;
  S  := StringReplace(S, SearchString, replaceString, [rfReplaceAll, rfIgnoreCase]);
  fs := TFileStream.Create(FileName, fmCreate);
  try
    fs.WriteBuffer(S[1], Length(S));
  finally
    fs.Free;
  end;
end;

---

تغيير نام يك دايركتوري

کد:

---

uses
  ShellApi;

procedure RenameDir(DirFrom, DirTo: string);
var
  shellinfo: TSHFileOpStruct;
begin
  with shellinfo do
  begin
    Wnd    := 0;
    wFunc  := FO_RENAME;
    pFrom  := PChar(DirFrom);
    pTo    := PChar(DirTo);
    fFlags := FOF_FILESONLY or FOF_ALLOWUNDO or
              FOF_SILENT or FOF_NOCONFIRMATION;
  end;
  SHFileOperation(shellinfo);
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
  RenameDir('C:\Dir1', 'C:\Dir2');
end;

---

خواندن يك فايل table-textfile درون يك StringGrid

کد:

---

procedure ReadTabFile(FN: TFileName; FieldSeparator: Char; SG: TStringGrid);
var
  i: Integer;
  S: string;
  T: string;
  Colonne, ligne: Integer;
  Les_Strings: TStringList;
  CountCols: Integer;
  CountLines: Integer;
  TabPos: Integer;
  StartPos: Integer;
  InitialCol: Integer;
begin
  Les_Strings := TStringList.Create;
  try
    // Load the file, Datei laden
    Les_Strings.LoadFromFile(FN);

    // Get the number of rows, Anzahl der Zeilen ermitteln
    CountLines := Les_Strings.Count + SG.FixedRows;

    // Get the number of columns, Anzahl der Spalten ermitteln
    T := Les_Strings[0];
    for i := 0 to Length(T) - 1 do Inc(CountCols, Ord(IsDelimiter(FieldSeparator, T, i)));
    Inc(CountCols, 1 + SG.FixedCols);

    // Adjust Grid dimensions, Anpassung der Grid-Größe
    if CountLines > SG.RowCount then SG.RowCount := CountLines;
    if CountCols > SG.ColCount then SG.ColCount := CountCols;

    // Initialisierung
    InitialCol := SG.FixedCols - 1;
    Ligne := SG.FixedRows - 1;

    // Iterate through all rows of the table
    // Schleife durch allen Zeilen der Tabelle
    for i := 0 to Les_Strings.Count - 1 do
    begin
      Colonne := InitialCol;
      Inc(Ligne);
      StartPos := 1;
      S := Les_Strings[i];
      TabPos := Pos(FieldSeparator, S);
      repeat
        Inc(Colonne);
        SG.Cells[Colonne, Ligne] := Copy(S, StartPos, TabPos - 1);
        S := Copy(S, TabPos + 1, 999);
        TabPos := Pos(FieldSeparator, S);
      until TabPos = 0;
    end;
  finally
    Les_Strings.Free;
  end;
end;

// Example, Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Screen.Cursor := crHourGlass;
  // Open tab-delimited files
  ReadTabFile('C:\TEST.TXT', #9, StringGrid1);
  Screen.Cursor := crDefault;
end;

---

استفاده از توابع shell براي copy/move يك فايل

کد:

---

uses
  ShellApi;

procedure ShellFileOperation(fromFile: string; toFile: string; Flags: Integer);
var
  shellinfo: TSHFileOpStructA;
begin
  with shellinfo do
  begin
    wnd  := Application.Handle;
    wFunc := Flags;
    pFrom := PChar(fromFile);
    pTo  := PChar(toFile);
  end;
  SHFileOperation(shellinfo);
end;




procedure TForm1.Button1Click(Sender: TObject);
begin
  ShellFileOperation('c:\afile.txt', 'd:\afile2.txt', FO_COPY);
  // To Move a file: FO_MOVE
end;

---

کد:

---

function AttachToFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;
var
  aStream: TFileStream;
  iSize: Integer;
begin
  Result := False;
  if not FileExists(AFileName) then
    Exit;
  try
    aStream := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyWrite);
    MemoryStream.Seek(0, soFromBeginning);
    // seek to end of File
    // ans Ende der Datei Seeken
    aStream.Seek(0, soFromEnd);
    // copy data from MemoryStream
    // Daten vom MemoryStream kopieren
    aStream.CopyFrom(MemoryStream, 0);
    // save Stream-Size
    // die Streamgröße speichern
    iSize := MemoryStream.Size + SizeOf(Integer);
    aStream.Write(iSize, SizeOf(iSize));
  finally
    aStream.Free;
  end;
  Result := True;
end;

function LoadFromFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;
var
  aStream: TFileStream;
  iSize: Integer;
begin
  Result := False;
  if not FileExists(AFileName) then
    Exit;

  try
    aStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
    // seek to position where Stream-Size is saved
    // zur Position seeken wo Streamgröße gespeichert
    aStream.Seek(-SizeOf(Integer), soFromEnd);
    aStream.Read(iSize, SizeOf(iSize));
    if iSize > aStream.Size then
    begin
      aStream.Free;
      Exit;
    end;
    // seek to position where data is saved
    // zur Position seeken an der die Daten abgelegt sind
    aStream.Seek(-iSize, soFromEnd);
    MemoryStream.SetSize(iSize - SizeOf(Integer));
    MemoryStream.CopyFrom(aStream, iSize - SizeOf(iSize));
    MemoryStream.Seek(0, soFromBeginning);
  finally
    aStream.Free;
  end;
  Result := True;
end;

procedure TForm1.SaveClick(Sender: TObject);
var
  aStream: TMemoryStream;
begin
  aStream := TMemoryStream.Create;
  Memo1.Lines.SaveToStream(aStream);
  AttachToFile('Test.exe', aStream);
  aStream.Free;
end;

procedure TForm1.LoadClick(Sender: TObject);
var
  aStream: TMemoryStream;
begin
  aStream := TMemoryStream.Create;
  LoadFromFile('Test.exe', aStream);
  Memo1.Lines.LoadFromStream(aStream);
  aStream.Free;
end;

---

پاك كردن يك فايل درون پوشه Document

کد:

---

uses
  ShlObj;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SHAddToRecentDocs(0, nil);
end;

---

توابع مفيد جهت كار با Stream

کد:

---

unit ClassUtils;

interface

uses
  SysUtils,
  Classes;

{: Write a string to the stream
  @param Stream is the TStream to write to.
  @param s is the string to write
  @returns the number of bytes written. }
function Writestring(_Stream: TStream; const _s: string): Integer;

{: Write a string to the stream appending CRLF
  @param Stream is the TStream to write to.
  @param s is the string to write
  @returns the number of bytes written. }
function WritestringLn(_Stream: TStream; const _s: string): Integer;

{: Write formatted data to the stream appending CRLF
  @param Stream is the TStream to write to.
  @param Format is a format string as used in sysutils.format
  @param Args is an array of const as used in sysutils.format
  @returns the number of bytes written. }
function WriteFmtLn(_Stream: TStream; const _Format: string;
  _Args: array of const): Integer;

implementation

function Writestring(_Stream: TStream; const _s: string): Integer;
begin
  Result := _Stream.Write(PChar(_s)^, Length(_s));
end;

function WritestringLn(_Stream: TStream; const _s: string): Integer;
begin
  Result := Writestring(_Stream, _s);
  Result := Result + Writestring(_Stream, #13#10);
end;

function WriteFmtLn(_Stream: TStream; const _Format: string;
  _Args: array of const): Integer;
begin
  Result := WritestringLn(_Stream, Format(_Format, _Args));
end;

---

تبديل OEM به ANSI

کد:

---

procedure ConvertFile(const FileName: string; fromCodepage: Integer);
var
  ms: TMemoryStream;
begin
  if getOEMCP <> fromCodepage then
    raise Exception.Create('ConvertFile: Codepage doesn't match!');
  ms := TMemoryStream.Create;
  try
    ms.LoadFromFile(FileName);
    // make backup
    ms.Position := 0;
    ms.SaveToFile(ChangeFileExt(FileName, '.BAK'));
    // convert text
    OEMToCharBuff(ms.Memory, ms.Memory, ms.Size);
    // save back to original file
    ms.Position := 0;
    ms.SaveToFile(FileName);
  finally
    ms.Free;
  end;
end;

---

ثبت خروجي يك برنامه DOS

کد:

---

function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile,
  ErrMsg: string): Boolean;
const
  ROUTINE_ID = '[function: CreateDOSProcessRedirected ]';
var
  OldCursor: TCursor;
  pCommandLine: array[0..MAX_PATH] of Char;
  pInputFile, pOutPutFile: array[0..MAX_PATH] of Char;
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  SecAtrrs: TSecurityAttributes;
  hAppProcess, hAppThread, hInputFile, hOutputFile: THandle;
begin
  Result := False;

  { check for InputFile existence }
  if not FileExists(InputFile) then
    raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
      'Input file * %s *' + #10 +
      'does not exist' + #10 + #10 +
      ErrMsg, [InputFile]);

  { save the cursor }
  OldCursor    := Screen.Cursor;
  Screen.Cursor := crHourglass;

  { copy the parameter Pascal strings to null terminated strings }
  StrPCopy(pCommandLine, CommandLine);
  StrPCopy(pInputFile, InputFile);
  StrPCopy(pOutPutFile, OutputFile);

  try

    { prepare SecAtrrs structure for the CreateFile calls
      This SecAttrs structure is needed in this case because
      we want the returned handle can be inherited by child process
      This is true when running under WinNT.
      As for Win95 the documentation is quite ambiguous }
    FillChar(SecAtrrs, SizeOf(SecAtrrs), #0);
    SecAtrrs.nLength        := SizeOf(SecAtrrs);
    SecAtrrs.lpSecurityDescriptor := nil;
    SecAtrrs.bInheritHandle := True;

    { create the appropriate handle for the input file }
    hInputFile := CreateFile(pInputFile,
      { pointer to name of the file }
      GENERIC_READ or GENERIC_WRITE,
      { access (read-write) mode }
      FILE_SHARE_READ or FILE_SHARE_WRITE,
      { share mode } @SecAtrrs,                            { pointer to security attributes }
      OPEN_ALWAYS,                          { how to create }
      FILE_ATTRIBUTE_TEMPORARY,              { file attributes }
      0);                                  { handle to file with attributes to copy }


    { is hInputFile a valid handle? }
    if hInputFile = INVALID_HANDLE_VALUE then
      raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
        'WinApi function CreateFile returned an invalid handle value' +
        #10 +
        'for the input file * %s *' + #10 + #10 +
        ErrMsg, [InputFile]);

    { create the appropriate handle for the output file }
    hOutputFile := CreateFile(pOutPutFile,
      { pointer to name of the file }
      GENERIC_READ or GENERIC_WRITE,
      { access (read-write) mode }
      FILE_SHARE_READ or FILE_SHARE_WRITE,
      { share mode } @SecAtrrs,                            { pointer to security attributes }
      CREATE_ALWAYS,                        { how to create }
      FILE_ATTRIBUTE_TEMPORARY,              { file attributes }
      0);                                  { handle to file with attributes to copy }

    { is hOutputFile a valid handle? }
    if hOutputFile = INVALID_HANDLE_VALUE then
      raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
        'WinApi function CreateFile returned an invalid handle value' +
        #10 +
        'for the output file * %s *' + #10 + #10 +
        ErrMsg, [OutputFile]);

    { prepare StartupInfo structure }
    FillChar(StartupInfo, SizeOf(StartupInfo), #0);
    StartupInfo.cb          := SizeOf(StartupInfo);
    StartupInfo.dwFlags    := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
    StartupInfo.wShowWindow := SW_HIDE;
    StartupInfo.hStdOutput  := hOutputFile;
    StartupInfo.hStdInput  := hInputFile;

    { create the app }
    Result := CreateProcess(nil,                          { pointer to name of executable module }
      pCommandLine,
      { pointer to command line string }
      nil,                          { pointer to process security attributes }
      nil,                          { pointer to thread security attributes }
      True,                          { handle inheritance flag }
      CREATE_NEW_CONSOLE or
      REALTIME_PRIORITY_CLASS,      { creation flags }
      nil,                          { pointer to new environment block }
      nil,                          { pointer to current directory name }
      StartupInfo,                  { pointer to STARTUPINFO }
      ProcessInfo);                  { pointer to PROCESS_INF }

    { wait for the app to finish its job and take the handles to free them later }
    if Result then
    begin
      WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
      hAppProcess := ProcessInfo.hProcess;
      hAppThread  := ProcessInfo.hThread;
    end
    else
      raise Exception.Create(ROUTINE_ID + #10 + #10 +
        'Function failure' + #10 + #10 +
        ErrMsg);

  finally
    { close the handles
      Kernel objects, like the process and the files we created in this case,
      are maintained by a usage count.
      So, for cleaning up purposes we have to close the handles
      to inform the system that we don't need the objects anymore }
    if hOutputFile <> 0 then CloseHandle(hOutputFile);
    if hInputFile <> 0 then CloseHandle(hInputFile);
    if hAppThread <> 0 then CloseHandle(hAppThread);
    if hAppProcess <> 0 then CloseHandle(hAppProcess);
    { restore the old cursor }
    Screen.Cursor := OldCursor;
  end;
end;

---

قرار دادن يك فايل Exe درون برنامه و اجراي آن

کد:

---

var
  Form1: TForm1;
  NOTEPAD_FILE: string;

implementation

{$R *.DFM}
{$R MYRES.RES}

function GetTempDir: string;
var
  Buffer: array[0..MAX_PATH] of Char;
begin
  GetTempPath(SizeOf(Buffer) - 1, Buffer);
  Result := StrPas(Buffer);
end;

// Extract the Resource
function ExtractRes(ResType, ResName, ResNewName: string): Boolean;
var
  Res: TResourceStream;
begin
  Result := False;
  Res := TResourceStream.Create(Hinstance, Resname, PChar(ResType));
  try
    Res.SavetoFile(ResNewName);
    Result := True;
  finally
    Res.Free;
  end;
end;

// Execute the file
procedure ShellExecute_AndWait(FileName: string);
var
  exInfo: TShellExecuteInfo;
  Ph: DWORD;
begin
  FillChar(exInfo, SizeOf(exInfo), 0);
  with exInfo do
  begin
    cbSize := SizeOf(exInfo);
    fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
    Wnd := GetActiveWindow();
    ExInfo.lpVerb := 'open';
    lpFile := PChar(FileName);
    nShow := SW_SHOWNORMAL;
  end;
  if ShellExecuteEx(@exInfo) then
  begin
    Ph := exInfo.HProcess;
  end
  else
  begin
    ShowMessage(SysErrorMessage(GetLastError));
    Exit;
  end;
  while WaitForSingleObject(ExInfo.hProcess, 50) <> WAIT_OBJECT_0 do
    Application.ProcessMessages;
  CloseHandle(Ph);
end;

// To Test it
procedure TForm1.Button1Click(Sender: TObject);
begin
  if ExtractRes('EXEFILE', 'TESTFILE', NOTEPAD_FILE) then
    if FileExists(NOTEPAD_FILE) then
    begin
      ShellExecute_AndWait(NOTEPAD_FILE);
      ShowMessage('Notepad finished!');
      DeleteFile(NOTEPAD_FILE);
    end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  NOTEPAD_FILE := GetTempDir + 'Notepad_FROM_RES.EXE';
end;

---

پاك كردن برنامه توسط خودش بعد از اجراي آن

کد:

---

procedure DeleteEXE;

  function GetTmpDir: string;
  var
    pc: PChar;
  begin
    pc := StrAlloc(MAX_PATH + 1);
    GetTempPath(MAX_PATH, pc);
    Result := string(pc);
    StrDispose(pc);
  end;

  function GetTmpFileName(ext: string): string;
  var
    pc: PChar;
  begin
    pc := StrAlloc(MAX_PATH + 1);
    GetTempFileName(PChar(GetTmpDir), 'uis', 0, pc);
    Result := string(pc);
    Result := ChangeFileExt(Result, ext);
    StrDispose(pc);
  end;
 
var
  batchfile: TStringList;
  batchname: string;
begin
  batchname := GetTmpFileName('.bat');
  FileSetAttr(ParamStr(0), 0);
  batchfile := TStringList.Create;
  with batchfile do
  begin
    try
      Add(':Label1');
      Add('del "' + ParamStr(0) + '"');
      Add('if Exist "' + ParamStr(0) + '" goto Label1');
      Add('rmdir "' + ExtractFilePath(ParamStr(0)) + '"');
      Add('del ' + batchname);
      SaveToFile(batchname);
      ChDir(GetTmpDir);
      ShowMessage('Uninstalling program...');
      WinExec(PChar(batchname), SW_HIDE);
    finally
      batchfile.Free;
    end;
    Halt;
  end;
end;

---

غير فعال كردن دكمه Close در فرم

کد:

---

procedure TFMain.FormCreate(Sender: TObject);
var
  hMenuHandle: Integer;
begin
  hMenuHandle := GetSystemMenu(Handle, False);
  if (hMenuHandle <> 0) then
    DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;

---

روش استفاده از TFileStream

کد:

---

type

  TPerson = record
    Name: string[50];
    vorname: string[50];
  end;

  TComputer = record
    Name: string[30];
    cpu: string[30];
  end;

var
  Form1: TForm1;

  Person: TPerson;
  Computer: TComputer;

  Stream: TFileStream;

implementation

{$R *.DFM}

//Speichern resp. Erstellen von Datei
//Save or create the file
procedure TForm1.Button1Click(Sender: TObject);
begin
  try
    Stream := TFileStream.Create('c:\test.dat', fmOpenReadWrite);
  except
    Stream := TFileStream.Create('c:\test.dat', fmCreate);
  end;

  //2 Einträge pro Record
  //save 2 records for TPerson and TComputer
  Person.Name    := 'Grossenbacher';
  Person.vorname := 'Simon';
  Stream.WriteBuffer(Person, SizeOf(TPerson));

  Person.Name    := 'Stutz';
  Person.vorname := 'Thomas';
  Stream.WriteBuffer(Person, SizeOf(TPerson));

  Computer.Name := 'Delphi';
  Computer.cpu  := 'Intel';
  Stream.WriteBuffer(Computer, SizeOf(TComputer));

  Computer.Name := 'Win';
  Computer.cpu  := 'AMD';
  Stream.WriteBuffer(Computer, SizeOf(TComputer));

  Stream.Free;
end;

//lädt alle daten von TPerson in listbox1 und
//daten von TComputer in Listbox2

//load records from TPerson to listbox1 and
//load records from TComputer to listbox2
procedure TForm1.Button2Click(Sender: TObject);
var
  i: Integer;
begin
  try
    // nur lesen öffnen
    //open read only
    Stream := TFileStream.Create('c:\test.dat', fmOpenRead);
  except
    ShowMessage('Datei konnte nicht geladen werden.');
    Exit;
  end;

  //variable i auf anzahl Einträge setzen

  //set variable i to the record count

  //Einlesen von TPerson
  //Read records TPerson
  for i := 2 downto 1 do
  begin
    Stream.ReadBuffer(Person, SizeOf(TPerson));
    Listbox1.Items.Add(Person.vorname + ' ' + Person.Name);
  end;

  //Einlesen von TComputer
  //Read Records TComputer
  for i := 2 downto 1 do
  begin
    Stream.ReadBuffer(Computer, SizeOf(TComputer));
    Listbox2.Items.Add(Computer.Name + ' ' + Computer.cpu);
  end;

  Stream.Free;
end;

---

جايگزيني يك Dll در حال استفاده از آن

کد:

---

function SystemErrorMessage: string;
var 
  P: PChar;
begin
  if FormatMessage(Format_Message_Allocate_Buffer + Format_Message_From_System,
                  nil,
                  GetLastError,
                  0,
                  @P,
                  0,
                  nil) <> 0 then
  begin
    Result := P;
    LocalFree(Integer(P))
  end 
  else 
    Result := '';
end;


// Path to Original File

procedure TForm1.Button2Click(Sender: TObject);
begin
  if Opendialog1.Execute then
    edit1.Text := OpenDialog1.FileName;
end;

// Path to New File

procedure TForm1.Button3Click(Sender: TObject);
begin
  if Opendialog2.Execute then
    edit2.Text := OpenDialog2.FileName;
end;

// Replace the File.

procedure TForm1.Button1Click(Sender: TObject);
begin
  if (Movefileex(PChar(Edit1.Text), PChar(Edit2.Text), MOVEFILE_DELAY_UNTIL_REBOOT) = False) then
    ShowMessage(SystemErrorMessage)
  else
  begin
    ShowMessage('Please Restart Windows to have these changes take effect');
    halt;
  end;
end;

---

تغيير صفات يك فايل

کد:

---

procedure TForm1.Button1Click(Sender: TObject);
begin
  FileSetAttr('C:\YourFile.ext', faHidden);
end;

{
  Other Files Attributes:
  Andere Dateiattribute:
}

{
  faReadOnly  $00000001 Schreibgeschützte Datei
  faHidden    $00000002 Verborgene Datei
  faSysFile  $00000004 Systemdatei
  faVolumeID  $00000008 Laufwerks-ID
  faDirectory $00000010 Verzeichnis
  faArchive  $00000020 Archivdatei
  faAnyFile  $0000003F Beliebige Datei
}


{
  You can also set some attributes at once:
  Es kِnnen auch mehrere Attribute aufs Mal gesetzt werden:
}

FileSetAttr('C:\Autoexec.bat', faReadOnly + faHidden);


{
  To remove write protection on a file:
  Den Schreibschutz einer Datei aufheben:
}

if (FileGetAttr(FileName) and faReadOnly) > 0
 then FileSetAttr(FileName, FileGetAttr(FileName) xor faReadOnly);

{
  Re-Set write protection:
  Schreibschutz wieder setzen:
}

FileSetAttr(FileName, FileGetAttr(FileName) or faReadOnly);

---

خواندن يك فايل متني بصورت خط به خط و تغيير آن

کد:

---

procedure TForm1.Button1Click(Sender: TObject);
var
  i, z: Integer;
  f: TextFile;
  t: string;
  Data: array of string;
begin
  if OpenDialog1.Execute then
  begin
    //Read line by line in to the array data
    AssignFile(f, OpenDialog1.FileName);
    Reset(f);
    z := 0;
    SetLength(Data, 0);
    //Repeat for each line until end of file
    repeat
      Inc(z);
      readln(f, t);
      SetLength(Data, Length(Data) + Length(t));
      Data[z] := t;
    until EOF(f);

    SetLength(Data, Length(Data) + 3 * z);
    //Add to each line the line number
    for i := 1 to z do Data[i] := IntToStr(i) + ' ' + Data[i];
    SetLength(Data, Length(Data) + 2);
    //Add a carriage return and line feed
    Data[1] := Data[1] + #13 + #10;
    i      := Length(Data[5]);
    Data[5] := '';
    SetLength(Data, Length(Data) - i);
    //create a new textfile with the new data
    AssignFile(f, OpenDialog1.FileName + '2');
    ReWrite(f);
    //write all lines
    for i := 1 to z do writeln(f, Data[i]);
    //save file and close it
    CloseFile(f);
  end;
end;

---

تعيين فضاي آزاد ديسك

کد:

---

procedure TForm1.Button1Click(Sender: TObject);
var
  freeSpace, totalSpace: Double;
  s: Char;
begin
  // Drive letter
  // Laufwerksbuchstabe
  s := 'D';

  freeSpace  := DiskFree(Ord(s) - 64);
  totalSpace := DiskSize(Ord(s) - 64);

  label1.Caption := Format('Free Space: %12.0n', [freeSpace]);
  Label2.Caption := Format('Total Space: %12.0n', [totalSpace]);
  Label3.Caption := IntToStr(Round((totalSpace - freeSpace) / totalSpace * 100)) +
    ' Percent used.';
end;

---

استفاده از فايلهاي INI

کد:

---

uses
  IniFiles;

// Write values to a INI file

procedure TForm1.Button1Click(Sender: TObject);
var
  ini: TIniFile;
begin
  // Create INI Object and open or create file test.ini
  ini := TIniFile.Create('c:\MyIni.ini');
  try
    // Write a string value to the INI file.
    ini.WriteString('Section_Name', 'Key_Name', 'String Value');
    // Write a integer value to the INI file.
    ini.WriteInteger('Section_Name', 'Key_Name', 2002);
    // Write a boolean value to the INI file.
    ini.WriteBool('Section_Name', 'Key_Name', True);
  finally
    ini.Free;
  end;
end;


// Read values from an INI file

procedure TForm1.Button2Click(Sender: TObject);
var
  ini: TIniFile;
  res: string;
begin
  // Create INI Object and open or create file test.ini
  ini := TIniFile.Create('c:\MyIni.ini');
  try
    res := ini.ReadString('Section_Name', 'Key_Name', 'default value');
    MessageDlg('Value of Section:  ' + res, mtInformation, [mbOK], 0);
  finally
    ini.Free;
  end;
end;

// Read all sections

procedure TForm1.Button3Click(Sender: TObject);
var 
  ini: TIniFile;
begin
  ListBox1.Clear;
  ini := TIniFile.Create('MyIni.ini');
  try
    ini.ReadSections(listBox1.Items);
  finally 
    ini.Free; 
  end;
end;

// Read a section

procedure TForm1.Button4Click(Sender: TObject);
var 
  ini: TIniFile;
begin
  ini: = TIniFile.Create('WIN.INI');
  try
    ini.ReadSection('Desktop', ListBox1.Items);
  finally
    ini.Free;
  end;
end;


// Read section values

procedure TForm1.Button5Click(Sender: TObject);
var
  ini: TIniFile;
begin
  ini := TIniFile.Create('WIN.INI');
  try
    ini.ReadSectionValues('Desktop', ListBox1.Items);
  finally 
    ini.Free; 
  end;
end;

// Erase a section

procedure TForm1.Button6Click(Sender: TObject);
var 
  ini: TIniFile;
begin
  ini := TIniFile.Create('MyIni.ini');
  try
    ini.EraseSection('My_Section');
  finally
    ini.Free;
  end;
end;

---

سايز يك دايركتوري

کد:

---

function GetDirSize(dir: string; subdir: Boolean): Longint;
var
  rec: TSearchRec;
  found: Integer;
begin
  Result := 0;
  if dir[Length(dir)] <> '\' then dir := dir + '\';
  found := FindFirst(dir + '*.*', faAnyFile, rec);
  while found = 0 do
  begin
    Inc(Result, rec.Size);
    if (rec.Attr and faDirectory > 0) and (rec.Name[1] <> '.') and (subdir = True) then
      Inc(Result, GetDirSize(dir + rec.Name, True));
    found := FindNext(rec);
  end;
  FindClose(rec);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  label1.Caption := FloatToStr(GetDirSize('e:\download', False) / Sqr(1024)) + ' MBytes';
  label2.Caption := FloatToStr(GetDirSize('e:\download', True) / Sqr(1024)) + ' MBytes';
end;

---

كپي كردن يك فايل

کد:

---

var
  fileSource, fileDest: string;
begin
  fileSource := 'C:\SourceFile.txt';
  fileDest := 'G:\DestFile.txt';
  CopyFile(PChar(fileSource), PChar(fileDest), False);
end;

---

روش بدست آوردن اطلاعات 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.

---

مشخص كردن وجود Terminal Service ها

کد:

---

function IsRemoteSession: Boolean;
const
  sm_RemoteSession = $1000; { from WinUser.h }
begin
  Result := (GetSystemMetrics(sm_RemoteSession) <> 0);
end;

---

کد:

---

type
  OSVERSIONINFOEX = packed record
    dwOSVersionInfoSize: DWORD;
    dwMajorVersion: DWORD;
    dwMinorVersion: DWORD;
    dwBuildNumber: DWORD;
    dwPlatformId: DWORD;
    szCSDVersion: array[0..127] of Char;
    wServicePackMajor: WORD;
    wServicePackMinor: WORD;
    wSuiteMask: WORD;
    wProductType: BYTE;
    wReserved: BYTE;
  end;
  TOSVersionInfoEx = OSVERSIONINFOEX;
  POSVersionInfoEx = ^TOSVersionInfoEx;

const
  VER_SUITE_TERMINAL = $00000010;
  VER_SUITENAME = $00000040;
  VER_AND = 6;

function VerSetConditionMask(
  ConditionMask: int64;
  TypeMask: DWORD;
  Condition: Byte
  ): int64; stdcall; external kernel32;

function VerifyVersionInfo(
  var VersionInformation: OSVERSIONINFOEX;
  dwTypeMask: DWORD;
  dwlConditionMask: int64
  ): BOOL; stdcall; external kernel32 name 'VerifyVersionInfoA';


function IsTerminalServicesEnabled: Boolean;
var
  osVersionInfo: OSVERSIONINFOEX;
  dwlConditionMask: int64;
begin
  FillChar(osVersionInfo, SizeOf(osVersionInfo), 0);
  osVersionInfo.dwOSVersionInfoSize := sizeof(osVersionInfo);
  osVersionInfo.wSuiteMask := VER_SUITE_TERMINAL;
  dwlConditionMask := 0;
  dwlConditionMask :=
    VerSetConditionMask(dwlConditionMask,
    VER_SUITENAME,
    VER_AND);
  Result := VerifyVersionInfo(
    osVersionInfo,
    VER_SUITENAME,
    dwlConditionMask);
end;

---

تعيين نسخه MS Word نصب شده روي كامپيوتر

کد:

---

uses ComObj;

{
const
  Wordversion97 = 8;
  Wordversion2000 = 9;
  WordversionXP = 10;
  Wordversion2003 = 11;
}

function GetInstalledWordVersion: Integer;
var
  word: OLEVariant;
begin
  word := CreateOLEObject('Word.Application');
  result := word.version;
  word.Quit;
  word := UnAssigned;
end;


// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(IntToStr(GetInstalledWordVersion));
end;

---

وارد كردن يك متن RTF در Word

کد:

---

uses
  Word_TLB, ActiveX, ComObj;

function GetRTFFormat(DataObject: IDataObject; var RTFFormat: TFormatEtc): Boolean;
var
  Formats: IEnumFORMATETC;
  TempFormat: TFormatEtc;
  pFormatName: PChar;
  Found: Boolean;
begin
  try
    OleCheck(DataObject.EnumFormatEtc(DATADIR_GET, Formats));
    Found := False;
    while (not Found) and (Formats.Next(1, TempFormat, nil) = S_OK) do
    begin
      pFormatName := AllocMem(255);
      GetClipBoardFormatName(TempFormat.cfFormat, pFormatName, 254);
      if (string(pFormatName) = 'Rich Text Format') then
      begin
        RTFFormat := TempFormat;
        Found := True;
      end;
      FreeMem(pFormatName);
    end;
    Result := Found;
  except
    Result := False;
  end;
end;

procedure WriteToMSWord(const RTFText: String);
var
  WordDoc: _Document;
  WordApp: _Application;
  DataObj : IDataObject;
  Formats : IEnumFormatEtc;
  RTFFormat: TFormatEtc;
  Medium : TStgMedium;
  pGlobal : Pointer;
begin
    try
      GetActiveOleObject('Word.Application').QueryInterface(_Application, WordApp);
    except
      WordApp := CoWordApplication.Create;
    end;
    WordApp.Documents.Add(EmptyParam, EmptyParam, EmptyParam, EmptyParam);
    WordApp.Visible := True;
    WordDoc := WordApp.ActiveDocument;
    OleCheck(WordDoc.QueryInterface(IDataObject,DataObj));
    GetRTFFormat(DataObj, RTFFormat);
    FillChar(Medium,SizeOf(Medium),0);
    Medium.tymed := RTFFormat.tymed;
    Medium.hGlobal := GlobalAlloc(GMEM_MOVEABLE, Length(RTFText)+1);
    try
    pGlobal := GlobalLock(Medium.hGlobal);
    CopyMemory(PGlobal,PChar(RTFText),Length(RTFText)+1);
    GlobalUnlock(Medium.hGlobal);
    OleCheck(DataOBJ.SetData(RTFFormat,Medium,True));
    finally
      GlobalFree(Medium.hGlobal);
      ReleaseStgMedium(Medium);
    end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  WriteToMSWord(Memo1.Text); // may be rtf-formatted text
end;

---

فشرده سازي و ترميم يك بانك اطلاعاتي Access

کد:

---

uses
  ComObj;

function CompactAndRepair(DB: string): Boolean; {DB = Path to Access Database}
var 
  v: OLEvariant;
begin
  Result := True;
  try
    v := CreateOLEObject('JRO.JetEngine');
    try
      V.CompactDatabase('Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DB,
                        'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DB+'x;Jet OLEDB:Engine Type=5');
      DeleteFile(DB);
      RenameFile(DB+'x',DB);
    finally
      V := Unassigned;
    end;
  except
    Result := False;
  end;
end;

---

ايجاد Database در يك بانك اطلاعاتي sql sever 2000 در حالت local

کد:

---

procedure CreateDatabase(WindowsSecurity: Boolean; Username, Password: String);
var
  ConnectionString: String;
  CommandText: String;
begin
  if WindowsSecurity then
    ConnectionString := 'Provider=SQLOLEDB.1;' +
                        'Integrated Security=SSPI;' +
                        'Persist Security Info=False;' +
                        'Initial Catalog=master'
  else
    ConnectionString := 'Provider=SQLOLEDB.1;' +
                        'Password=' + Password + ';' +
                        'Persist Security Info=True;' +
                        'User ID=' + Username + ';' +
                        'Initial Catalog=master';

  try

    try
      ADOConnection.ConnectionString := ConnectionString;
      ADOConnection.LoginPrompt := False;
      ADOConnection.Connected := True;


      CommandText := 'CREATE DATABASE test ON ' +
                    '( NAME = test_dat,    ' +
                    'FILENAME = ''c:\program files\microsoft sql server\mssql\data\test.mdf'', ' +
                    'SIZE = 4, ' +
                    'MAXSIZE = 10, ' +
                    'FILEGROWTH = 1 )';

      ADOCommand.CommandText := CommandText;
      ADOCommand.Connection := ADOConnection;
      ADOCommand.Execute;
      MessageDlg('Database succesfully created.', mtInformation, [mbOK], 0);

    except
      on E: Exception do MessageDlg(E.Message, mtWarning, [mbOK], 0);
    end;

  finally
    ADOConnection.Connected := False;
    ADOCommand.Connection := nil;
  end;

end;

---

پيدا كردن يك مقدار در فيلد ايندكس نشده به كمك TTable

کد:

---

function Locate(const oTable: TTable; const oField: TField;
  const sValue: string): Boolean;
var

  bmPos: TBookMark;
  bFound: Boolean;
begin
  Locate := False;
  bFound := False;
  if not oTable.Active then Exit;
  if oTable.FieldDefs.IndexOf(oField.FieldName) < 0 then Exit;
  bmPos := oTable.GetBookMark;
  with oTable do
  begin
    DisableControls;
    First;
    while not EOF do
      if oField.AsString = sValue then
      begin
        Locate := True;
        bFound := True;
        Break;
      end
    else
      Next;
  end;
  if (not bFound) then
    oTable.GotoBookMark(bmPos);
  oTable.FreeBookMark(bmPos);
  oTable.EnableControls;
end;

---

تهيه خروجي از جداول ADO به فرمتهاي مختلف

کد:

---

unit ExportADOTable;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, ADODB;

type
  TExportADOTable = class(TADOTable)
  private
    { Private declarations }
    //TADOCommand component used to execute the SQL exporting commands
    FADOCommand: TADOCommand;
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;

    //Export procedures
    //"FiledNames" is a comma separated list of the names of the fields you want to export
    //"FileName" is the name of the output file (including the complete path)
    //if the dataset is filtered (Filtered = true and Filter <> ''), then I append 
    //the filter string to the sql command in the "where" directive
    //if the dataset is sorted (Sort <> '') then I append the sort string to the sql command in the 
    //"order by" directive
   
    procedure ExportToExcel(FieldNames: string; FileName: string;
      SheetName: string; IsamFormat: string);
    procedure ExportToHtml(FieldNames: string; FileName: string);
    procedure ExportToParadox(FieldNames: string; FileName: string; IsamFormat: string);
    procedure ExportToDbase(FieldNames: string; FileName: string; IsamFormat: string);
    procedure ExportToTxt(FieldNames: string; FileName: string);
  published
    { Published declarations }
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Carlo Pasolini', [TExportADOTable]);
end;

constructor TExportADOTable.Create(AOwner: TComponent);
begin
  inherited;

  FADOCommand := TADOCommand.Create(Self);
end;


procedure TExportADOTable.ExportToExcel(FieldNames: string; FileName: string;
  SheetName: string; IsamFormat: string);
begin
  {IsamFormat values
  Excel 3.0
  Excel 4.0
  Excel 5.0
  Excel 8.0
  }

  if not Active then
    Exit;
  FADOCommand.Connection  := Connection; 
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    SheetName + ']' + ' IN ' + '"' + FileName + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;

procedure TExportADOTable.ExportToHtml(FieldNames: string; FileName: string);
var
  IsamFormat: string;
begin
  if not Active then
    Exit;

  IsamFormat := 'HTML Export';

  FADOCommand.Connection  := Connection;
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' + 
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;


procedure TExportADOTable.ExportToParadox(FieldNames: string;
  FileName: string; IsamFormat: string);
begin
  {IsamFormat values
  Paradox 3.X
  Paradox 4.X
  Paradox 5.X
  Paradox 7.X
  }
  if not Active then
    Exit;

  FADOCommand.Connection  := Connection;
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' + 
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;

procedure TExportADOTable.ExportToDbase(FieldNames: string; FileName: string;
  IsamFormat: string);
begin
  {IsamFormat values
  dBase III
  dBase IV
  dBase 5.0
  }
  if not Active then
    Exit;

  FADOCommand.Connection  := Connection;
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' + 
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;

procedure TExportADOTable.ExportToTxt(FieldNames: string; FileName: string);
var
  IsamFormat: string;
begin
  if not Active then
    Exit;

  IsamFormat := 'Text';

  FADOCommand.Connection  := Connection;
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' + 
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;

end.

---

ايجاد خروجي از TDBGrid به قالب Excel

کد:

---

unit DBGridExportToExcel;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, ComCtrls, DB, IniFiles, Buttons, dbgrids, ADOX_TLB, ADODB;


type TScrollEvents = class
      BeforeScroll_Event: TDataSetNotifyEvent;
      AfterScroll_Event: TDataSetNotifyEvent;
      AutoCalcFields_Property: Boolean;
  end;

procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);


implementation

//Support procedures: I made that in order to increase speed in
//the process of scanning large amounts
//of records in a dataset

//we make a call to the "DisableControls" procedure and then disable the "BeforeScroll" and
//"AfterScroll" events and the "AutoCalcFields" property.
procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
begin
    with DataSet do
          begin
              DisableControls;
              ScrollEvents := TScrollEvents.Create();
              with ScrollEvents do
                    begin
                        BeforeScroll_Event := BeforeScroll;
                        AfterScroll_Event := AfterScroll;
                        AutoCalcFields_Property := AutoCalcFields;
                        BeforeScroll := nil;
                        AfterScroll := nil;
                        AutoCalcFields := False;
                    end;
          end;
end;

//we make a call to the "EnableControls" procedure and then restore
// the "BeforeScroll" and "AfterScroll" events and the "AutoCalcFields" property.
procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
begin
    with DataSet do
          begin
              EnableControls;
              with ScrollEvents do
                    begin
                        BeforeScroll := BeforeScroll_Event;
                        AfterScroll := AfterScroll_Event;
                        AutoCalcFields := AutoCalcFields_Property;
                    end;
          end;
end;

//This is the procedure which make the work:

procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);
var
  cat: _Catalog;
  tbl: _Table;
  col: _Column;
  i: integer;
  ADOConnection: TADOConnection;
  ADOQuery: TADOQuery;
  ScrollEvents: TScrollEvents;
  SavePlace: TBookmark;
begin
  //
  //WorkBook creation (database)
  cat := CoCatalog.Create;
  cat._Set_ActiveConnection('Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0');
  //WorkSheet creation (table)
  tbl := CoTable.Create;
  tbl.Set_Name(SheetName);
  //Columns creation (fields)
  DBGrid.DataSource.DataSet.First;
  with DBGrid.Columns do
    begin
      for i := 0 to Count - 1 do
        if Items[i].Visible then
        begin
          col := nil;
          col := CoColumn.Create;
          with col do
            begin
              Set_Name(Items[i].Title.Caption);
              Set_Type_(adVarWChar);
            end;
          //add column to table
          tbl.Columns.Append(col, adVarWChar, 20);
        end;
    end;
  //add table to database
  cat.Tables.Append(tbl);

  col := nil;
  tbl := nil;
  cat := nil;

  //exporting
  ADOConnection := TADOConnection.Create(nil);
  ADOConnection.LoginPrompt := False;
  ADOConnection.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0';
  ADOQuery := TADOQuery.Create(nil);
  ADOQuery.Connection := ADOConnection;
  ADOQuery.SQL.Text := 'Select * from [' + SheetName + '$]';
  ADOQuery.Open;


  DisableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);
  SavePlace := DBGrid.DataSource.DataSet.GetBookmark;
  try
  with DBGrid.DataSource.DataSet do
    begin
      First;
      while not Eof do
        begin
          ADOQuery.Append;
          with DBGrid.Columns do
            begin
              ADOQuery.Edit;
              for i := 0 to Count - 1 do
                if Items[i].Visible then
                  begin
                    ADOQuery.FieldByName(Items[i].Title.Caption).AsString := FieldByName(Items[i].FieldName).AsString;
                  end;
              ADOQuery.Post;
            end;
          Next;
        end;
    end;

  finally
  DBGrid.DataSource.DataSet.GotoBookmark(SavePlace);
  DBGrid.DataSource.DataSet.FreeBookmark(SavePlace);
  EnableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);

  ADOQuery.Close;
  ADOConnection.Close;

  ADOQuery.Free;
  ADOConnection.Free;

  end;

end;

end.

---

دسترسي به جداول paradox روي cdrom يا درايوهاي Read Only

کد:

---

A:
This Technical Information document will help step thru concepts regarding
the creation and use of ALIASES within your Delphi Applications.

Typically, you use the BDE Configuration Utility BDECFG.EXE to create and
configure aliases outside of Delphi.  However, with the use of the TDatabase
component, you have the ability to create and use this ALIAS within your
application-- not pre-defined in the IDAPI.CFG.

The ability to create Aliases that are only available within your
application is important.  Aliases specify the location of database tables
and connection parameters for database servers.
Ultimately, you can gain the advantages of using ALIASES within your
applications-- without having to worry about the existance of a
configuration entry in the IDAPI.CFG when you deploy your
application.  }

{Summary of Examples:}
{Example #1:}
      {Example #1 creates and configures an Alias to use
        STANDARD (.DB, .DBF) databases.  The Alias is
            then used by a TTable component.}
{Example #2:}
      {Example #2 creates and configures an Alias to use
        an INTERBASE database (.gdb).  The Alias is then
        used by a TQuery component to join two tables of
        the database.}
{Example #3:}
      {Example #3 creates and configures an Alias to use
                  STANDARD (.DB, .DBF) databases.  This example
          demonstrates how user input can be used to
        configure the Alias during run-time.}


{Example #1:  Use of a .DB or .DBF database (STANDARD)}

{1.  Create a New Project.

2.  Place the following components on the form:  - TDatabase, TTable,
TDataSource, TDBGrid, and TButton.

3.  Double-click on the TDatabase component or choose Database Editor from
the TDatabase SpeedMenu to launch the Database Property editor.

4.  Set the Database Name to 'MyNewAlias'.  This name will serve as your
ALIAS name used in the DatabaseName Property for dataset components such as
TTable, TQuery, TStoredProc.

5.  Select STANDARD as the Driveer Name.

6.  Click on the Defaults Button.  This will automatically add  a PATH= in
the Parameter Overrides section.

7.  Set the PATH= to C:\DELPHI\DEMOS\DATA  (PATH=C:\DELPHI\DEMOS\DATA)

8.  Click the OK button to close the Database Dialog.

9.  Set the TTable DatabaseName Property to 'MyNewAlias'.

10.  Set the TDataSource's DataSet Property to 'Table1'.

11.  Set the DBGrid's DataSource Property to 'DataSource1'.

12.  Place the following code inside of the TButton's OnClick event.}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Table1.TableName := 'CUSTOMER';
  Table1.Active    := True;
end;

{13.  Run the application.}


{***  If you want an alternative way to steps 3 - 11, place the following
code inside of the TButton's OnClick event.}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Database1.DatabaseName := 'MyNewAlias';
  Database1.DriverName  := 'STANDARD';
  Database1.Params.Clear;
  Database1.Params.Add('PATH=C:\DELPHI\DEMOS\DATA');
  Table1.DatabaseName := 'MyNewAlias';
  Table1.TableName    := 'CUSTOMER';
  Table1.Active      := True;
  DataSource1.DataSet := Table1;
  DBGrid1.DataSource  := DataSource1;
end;

{Example #2: Use of a INTERBASE database}

{1.  Create a New Project.

2.  Place the following components on the form: - TDatabase, TQuery,
TDataSource, TDBGrid, and TButton.

3.  Double-click on the TDatabase component or choose Database Editor from
the TDatabase SpeedMenu to launch the Database  Property editor.

4.  Set the Database Name to 'MyNewAlias'.  This name will serve as your
ALIAS name used in the DatabaseName Property for dataset components such as
TTable, TQuery, TStoredProc.

5.  Select INTRBASE as the Driver Name.

6.  Click on the Defaults Button.  This will automatically add  the
following entries in the Parameter Overrides section.

      SERVER NAME=IB_SERVEER:/PATH/DATABASE.GDB
      USER NAME=MYNAME
      OPEN MODE=READ/WRITE
      SCHEMA CACHE SIZE=8
      LANGDRIVER=
      SQLQRYMODE=
      SQLPASSTHRU MODE=NOT SHARED
      SCHEMA CACHE TIME=-1
      PASSWORD=

7.  Set the following parameters

      SERVER NAME=C:\IBLOCAL\EXAMPLES\EMPLOYEE.GDB
      USER NAME=SYSDBA
      OPEN MODE=READ/WRITE
      SCHEMA CACHE SIZE=8
      LANGDRIVER=
      SQLQRYMODE=
      SQLPASSTHRU MODE=NOT SHARED
      SCHEMA CACHE TIME=-1
      PASSWORD=masterkey

8.  Set the TDatabase LoginPrompt Property to 'False'.  If you  supply the
PASSWORD in the Parameter Overrides section and set the LoginPrompt to
'False', you will not be prompted for the
password when connecting to the database.  WARNING:  If an incorrect
password in entered in the Parameter Overrides  section and LoginPrompt is
set to 'False', you are not prompted by the Password dialog to re-enter a
valid password.

9.  Click the OK button to close the Database Dialog.

10.  Set the TQuery DatabaseName Property to 'MyNewAliias'.

11.  Set the TDataSource's DataSet Property to 'Query1'.

12.  Set the DBGrid's DataSource Property to 'DataSource1'.

13.  Place the following code inside of the TButton's OnClick event.}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Query1.SQL.Clear;
  Query1.SQL.Add('SELECT DISTINCT * FROM CUSTOMER C, SALES S
    WHERE(S.CUST_NO = C.CUST_NO)
    ORDER BY C.CUST_NO, C.CUSTOMER');
  Query1.Active := True;
end;

{14.  Run the application.}


{Example #3: User-defined Alias Configuration}

{This example brings up a input dialog and prompts the user to enter the
directory to which the ALIAS is to be configured to.

The directory, servername, path, database name, and other neccessary Alias
parameters can be read into the application from use of an input dialog or
.INI file.

1.  Follow the steps (1-11) in Example #1.

2.  Place the following code inside of the TButton's  OnClick event.}

procedure TForm1.Buttton1Click(Sender: TObject);
var
  NewString: string;
  ClickedOK: Boolean;
begin
  NewString := 'C:\';
  ClickedOK := InputQuery('Database Path',
    'Path: --> C:\DELPHI\DEMOS\DATA', NewString);
  if ClickedOK then
  begin
    Database1.DatabaseName := 'MyNewAlias';
    Database1.DriverName  := 'STANDARD';
    Database1.Params.Clear;
    Database1.Params.Add('Path=' + NewString);
    Table1.DatabaseName := 'MyNewAlias';
    Table1.TableName    := 'CUSTOMER';
    Table1.Active      := True;
    DataSource1.DataSet := Table1;
    DBGrid1.DataSource  := DataSource1;
  end;
end;

//3.  Run the Application

---

ايجاد يك جدول مجازي

کد:

---

unit Inmem;

interface

uses DBTables, WinTypes, WinProcs, DBITypes, DBIProcs, DB, SysUtils;

type
  TInMemoryTable = class(TTable)
  private
    hCursor: hDBICur;
    procedure EncodeFieldDesc(var FieldDesc: FLDDesc;
      const Name: string; DataType: TFieldType; Size: Word);
    function CreateHandle: HDBICur; override;
  public
    procedure CreateTable;
  end;

implementation

{
  Luckely this function is virtual - so I could override it. In the
  original VCL code for TTable this function actually opens the table -
  but since we already have the handle to the table - we just return it
}

function TInMemoryTable.CreateHandle;
begin
  Result := hCursor;
end;

{
  This function is cut-and-pasted from the VCL source code. I had to do
  this because it is declared private in the TTable component so I had no
  access to it from here.
}

procedure TInMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc;
  const Name: string; DataType: TFieldType; Size: Word);
const
  TypeMap: array[TFieldType] of Byte = (fldUNKNOWN, fldZSTRING, fldINT16,
    fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
begin
  with FieldDesc do
  begin
    AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
    iFldType := TypeMap[DataType];
    case DataType of
      ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic:
        iUnits1 := Size;
      ftBCD:
        begin
          iUnits1 := 32;
          iUnits2 := Size;
        end;
    end;
    case DataType of
      ftCurrency:
        iSubType := fldstMONEY;
      ftBlob:
        iSubType := fldstBINARY;
      ftMemo:
        iSubType := fldstMEMO;
      ftGraphic:
        iSubType := fldstGRAPHIC;
    end;
  end;
end;

{
  This is where all the fun happens. I copied this function from the VCL
  source and then changed it to use DbiCreateInMemoryTable instead of
  DbiCreateTable.

  Since InMemory tables do not support Indexes - I took all of the
  index-related things out
}

procedure TInMemoryTable.CreateTable;
var
  I: Integer;
  pFieldDesc: pFLDDesc;
  szTblName: DBITBLNAME;
  iFields: Word;
  Dogs: pfldDesc;
begin
  CheckInactive;
  if FieldDefs.Count = 0 then
    for I := 0 to FieldCount - 1 do
      with Fields[I] do
        if not Calculated then
          FieldDefs.Add(FieldName, DataType, Size, Required);
  pFieldDesc := nil;
  SetDBFlag(dbfTable, True);
  try
    AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
    iFields := FieldDefs.Count;
    pFieldDesc := AllocMem(iFields * SizeOf(FLDDesc));
    for I := 0 to FieldDefs.Count - 1 do
      with FieldDefs[I] do
      begin
        EncodeFieldDesc(PFieldDescList(pFieldDesc)^[I], Name,
          DataType, Size);
      end;
    { the driver type is nil = logical fields }
    Check(DbiTranslateRecordStructure(nil, iFields, pFieldDesc,
      nil, nil, pFieldDesc));
    { here we go - this is where hCursor gets its value }
    Check(DbiCreateInMemTable(DBHandle, szTblName, iFields, pFieldDesc, hCursor));
  finally
    if pFieldDesc <> nil then FreeMem(pFieldDesc, iFields * SizeOf(FLDDesc));
    SetDBFlag(dbfTable, False);
  end;
end;

end.

---

ايجاد سريع يك جدول پارادوكس به كمك كد

کد:

---

procedure TForm1.Button1Click(Sender: TObject);
begin
  with Query1 do
  begin
    DatabaseName := 'DBDemos';
    with SQL do
    begin
      Clear;
      {
        CREATE TABLE creates a table with the given name in the
        current database

        CREATE TABLE erzeugt eine Tabelle mit einem angegebenen
        Namen in der aktuellen Datenbank
      }
      Add('CREATE TABLE "PDoxTbl.db" (ID AUTOINC,');
      Add('Name CHAR(255),');
      Add('PRIMARY KEY(ID))');
      {
        Call ExecSQL to execute the SQL statement currently
        assigned to the SQL property.

        Mit ExecSQL wird die Anweisung ausgeführt,
        welche aktuell in der Eigenschaft SQL enthalten ist.
      }
      ExecSQL;
      Clear;
      Add('CREATE INDEX ByName ON "PDoxTbl.db" (Name)');
      ExecSQL;
    end;
  end;
end;

---

ايجاد يك اتصال DBExpress در زمان اجرا

کد:

---

procedure TVCLScanner.PostUser(const Email, FirstName, LastName: WideString);
var
  Connection: TSQLConnection;
  DataSet: TSQLDataSet;
begin
  Connection := TSQLConnection.Create(nil);
  with Connection do
  begin
    ConnectionName := 'VCLScanner';
    DriverName := 'INTERBASE';
    LibraryName := 'dbexpint.dll';
    VendorLib := 'GDS32.DLL';
    GetDriverFunc := 'getSQLDriverINTERBASE';
    Params.Add('User_Name=SYSDBA');
    Params.Add('Password=masterkey');
    Params.Add('Database=milo2:D:\frank\webservices\umlbank.gdb');
    LoginPrompt := False;
    Open;
  end;
  DataSet := TSQLDataSet.Create(nil);
  with DataSet do
  begin
    SQLConnection := Connection;
    CommandText := Format('INSERT INTO kings VALUES("%s","%s","%s")',
      [Email, FirstN, LastN]);
    try
      ExecSQL;
    except
    end;
  end;
  Connection.Close;
  DataSet.Free;
  Connection.Free;
end;

---

رنگ آميزي يك TDBGrid

کد:

---

procedure TForm1.ColorGrid(dbgIn: TDBGrid; qryIn: TQuery; const Rect: TRect;
  DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
var 
  iValue: LongInt;
begin
  // color only the first field
  // nur erstes Feld einfärben
  if (DataCol = 0) then
  begin
    // Check the field value and assign a color
    // Feld-Wert prüfen und entsprechende Farbe wählen
    iValue := qryIn.FieldByName('HINWEIS_COLOR').AsInteger;
    case iValue of
      1: dbgIn.Canvas.Brush.Color := clGreen;
      2: dbgIn.Canvas.Brush.Color := clLime;
      3: dbgIn.Canvas.Brush.Color := clYellow;
      4: dbgIn.Canvas.Brush.Color := clRed;
    end;
    // Draw the field
    // Feld zeichnen
    dbgIn.DefaultDrawColumnCell(Rect, DataCol, Column, State);
  end;
end;

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  ColorGrid(DBGrid1, Query1, Rect, DataCol, Column, State);
end;

---

خواندن تمام ركوردهاي يك جدول در TstringGrid

کد:

---

Loading millions of records into a stringlist can be very slow }

procedure TForm1.SlowLoadingIntoStringList(StringList: TStringList);
begin
  StringList.Clear;
  with SourceTable do
  begin
    Open;
    DisableControls;
    try
      while not EOF do
      begin
        StringList.Add(FieldByName('OriginalData').AsString);
        Next;
      end;
    finally
      EnableControls;
      Close;
    end;
  end;
end;

{ This is much, much faster }
procedure TForm1.QuickLoadingIntoStringList(StringList: TStringList);
begin
  with CacheTable do
  begin
    Open;
    try
      StringList.Text := FieldByName('Data').AsString;
    finally
      Close;
    end;
  end;
end;

{ How can this be done?

  In Microsoft SQL Server 7, you can write a stored procedure that updates every night
  a cache table that holds all the data you want in a single column and row.
  In this example, you get the data from a SourceTable and put it all in a Cachetable.
  The CacheTable has one blob column and must have only one row.
  Here it is the SQL code: }


Create Table CacheTable
(Data Text NULL)
GO

Create 

procedure PopulateCacheTable as
  begin
  set NOCOUNT on
  DECLARE @ptrval binary(16), @Value varchar(600) -
  - a good Value for the expected maximum Length
  - - You must set 'select into/bulkcopy' option to True in order to run this sp
  DECLARE @dbname nvarchar(128)
  set @dbname = db_name()
EXEC sp_dboption @dbname, 'select into/bulkcopy', 'true'
- - Declare a cursor
DECLARE scr CURSOR for
SELECT  OriginalData + char(13) + char(10) - - each line in a TStringList is
separated by a #13#10
FROM    SourceTable
- - The CacheTable Table must have only one record
if EXISTS (SELECT * FROM CacheTable)
Update CacheTable set Data = ''
else
Insert CacheTable VALUES('')
- - Get a Pointer to the field we want to Update
SELECT @ptrval = TEXTPTR(Data) FROM CacheTable

Open scr
FETCH Next FROM scr INTO @Value
while @ @FETCH_STATUS = 0
begin - - This UPDATETEXT appends each Value to the 
end 
of the blob field
UPDATETEXT CacheTable.Data @ptrval NULL 0 @Value
FETCH Next FROM scr INTO @Value
end
Close scr
DEALLOCATE scr
- - Reset this option to False
EXEC sp_dboption @dbname, 'select into/bulkcopy', 'false'
end
GO

{ You may need to increase the BLOB SIZE parameter if you use BDE }

---

جلوگيري از ليست توماري شدن منو:

کد:

---

Procedure BreakMoreMenu(fSubMenu:TmenuItem;
          fMode:TMenuBreak=mbBarBreak);
var
  fMnuHeight:Integer;
  ScrHeight:Integer;
  Count:integer;
  i:integer;
  items:integer;
begin
fMnuHeight:=GetSystemMetrics(SM_CYMENU);
If fMnuHeight<1 then
  fMnuHeight:=4
else
  fMnuHeight:=fMnuHeight+3;
ScrHeight:=(screen.Height)-(fMnuHeight *5) ;
Count:=(ScrHeight div  fMnuHeight);//Menus in screen
items:=0;
for i:=0 to fSubMenu.Count-1 do begin
  If items>=Count then begin
    fSubMenu.Items[i].Break:=fMode;
    items:=0;
  end;
  items:=items+1;
end;
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;

---