نکات برنامه نویسی در دلفی

[پسر خاک]

لیست تمام فایلهای موجود در یک دایرکتوری

procedure ListFileDir(Path: string; FileList: TStrings);

var

  SR: TSearchRec;

begin

  if FindFirst(Path + '*.*', faAnyFile, SR) = 0 then

  begin

    repeat

      if (SR.Attr <> faDirectory) then

      begin

        FileList.Add(SR.Name);

      end;

    until FindNext(SR) <> 0;

    FindClose(SR);

  end;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  ListFileDir('C:\WINDOWS\', ListBox1.Items);

end; 

[پسر خاک]

نصب یک فایل 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; 

[پسر خاک]

اضافه کردن اطلاعات به یک فایل EXE

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&#  41;);

    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; 

[پسر خاک]

سلام

بفرمایید:

uses

  ShellApi;

 

function CopyDir(const fromDir, toDir: string): Boolean;

var

  fos: TSHFileOpStruct;

begin

  ZeroMemory(@fos, SizeOf(fos));

  with fos do

  begin

    wFunc  := FO_COPY;

    fFlags := FOF_FILESONLY;

    pFrom  := PChar(fromDir + #0);

    pTo    := PChar(toDir)

  end;

  Result := (0 = ShFileOperation(fos));

end;

 

 

function MoveDir(const fromDir, toDir: string): Boolean;

var

  fos: TSHFileOpStruct;

begin

  ZeroMemory(@fos, SizeOf(fos));

  with fos do

  begin

    wFunc  := FO_MOVE;

    fFlags := FOF_FILESONLY;

    pFrom  := PChar(fromDir + #0);

    pTo    := PChar(toDir)

  end;

  Result := (0 = ShFileOperation(fos));

end;

 

function DelDir(dir: string): Boolean;

var

  fos: TSHFileOpStruct;

begin

  ZeroMemory(@fos, SizeOf(fos));

  with fos do

  begin

    wFunc  := FO_DELETE;

    fFlags := FOF_SILENT or FOF_NOCONFIRMATION;

    pFrom  := PChar(dir + #0);

  end;

  Result := (0 = ShFileOperation(fos));

end;

 

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  if cCopyDir('d:\download', 'e:\') = True then

    ShowMessage('Directory copied.');

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(GetInstalledWordVersi  on));

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').Que  ryInterface(_Application, WordApp);

    except

      WordApp := CoWordApplication.Create;

    end;

    WordApp.Documents.Add(EmptyParam, EmptyParam, EmptyParam, EmptyParam);

    WordApp.Visible := True;

    WordDoc := WordApp.ActiveDocument;

    OleCheck(WordDoc.QueryInterface(IDataObjec  t,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),Leng  th(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.OLED  B.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&#58  ; 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.Ca  ption).AsString := FieldByName(Items[i].FieldName).As  String;

                  end;

              ADOQuery.Post;

            end;

          Next;

        end;

    end;

 

  finally

  DBGrid.DataSource.DataSet.GotoBookmark(SavePla  ce);

  DBGrid.DataSource.DataSet.FreeBookmark(SavePla  ce);

  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&  #41;^[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\we  bservices\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').AsInteg  er;

    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').AsStrin  g);

        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 /}