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

نصب يك فايل 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;

---