How to display the contents of a directory and its subdirectories.
The procedure displays all files and directories (including subdirectories) contained in the directory entered as the function parameter. The results are stored a list of strings called List:
 
uses SysUtils

procedure STO_SearchDirectory(List: TStrings; Directory: String;
const Recursive: Boolean);
var
bFoundFile: Boolean;
mySearchRec: TSearchRec;
sFileName: String;
begin
Directory := IncludeTrailingPathDelimiter(Directory);
bFoundFile := FindFirst(Directory + '*.*', faAnyFile, mySearchRec) = 0;
while bFoundFile do
begin
    if (mySearchRec.Name[1] <> '.') then
    begin
      sFileName := Directory + mySearchRec.Name;
      if ((mySearchRec.Attr and faDirectory) = 0) then
      begin
        List.Add(sFileName);
      end
      else
      begin
        sFileName := IncludeTrailingPathDelimiter(sFileName);
        List.Add(sFileName);
          if Recursive then
          STO_SearchDirectory(List, sFileName, Recursive);
      end;
    end;
      bFoundFile := FindNext(mySearchRec) = 0;
end;
FindClose(mySearchRec);
end;

procedure Starter;
var
slFilenames: TStrings;
begin
slFileNames := TStringList.Create;
try
STO_SearchDirectory(slFileNames, 'C:\temp\', True);
finally
    slFileNames.Free;
end;
end;


How to search for text in a Memo component.
Implement a process to search for text in a in which you can enter multiple lines of text Memo control (control), it is not as complicated as it may appear. The example requires that the form is present a Memo Control (Memo1) and FindDialog component (called FindDialog1).
 
procedure TForm1.FindDialog1Find(Sender: TObject); 
var Buffer, Pos, tPointer : PChar; 
    BuffLength            : Word; 
begin 
   With Sender as TFindDialog do 
   begin 
      GetMem(tPointer, Length(FindText) + 1); 
      StrPCopy(tPointer, FindText); 
      BuffLength:= Memo1.GetTextLen + 1; 
      GetMem(Buffer,BuffLength); 
      Memo1.GetTextBuf(Buffer,BuffLength); 
      Pos:= Buffer + Memo1.SelStart + Memo1.SelLength; 
      Pos:= StrPos(Pos, tPointer); 
      if Pos = NIL then MessageBeep(0) 
      else 
      begin 
        Memo1.SelStart:= Pos - Buffer; 
        Memo1.SelLength:= Length(FindText); 
      end; 
      FreeMem(tPointer, Length(FindText) + 1); 
      FreeMem(Buffer,BuffLength); 
      Memo1.SetFocus; 
end; 
end;


As we are squeezing our processor?
We can know with these few lines of code to share our processor is working!
 
unit unit1;

interface 

uses 
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
ComCtrls, CommCtrl, StdCtrls, Menus,WinSpool, ExtCtrls, Buttons, Registry; 

type
TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    Timer1: TTimer;
    Button2: TButton;
    Label2: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
private
    { Private declarations }
    started : boolean;
    reg : TRegistry;
public
    { Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
num: array[0..1024] of byte;
begin
Reg := TRegistry.Create;
Reg.RootKey := HKEY_DYN_DATA; Reg.OpenKey('PerfStats\StartStat',false); 
Reg.ReadBinaryData('KERNEL\CPUUsage', num, Sizeof(num));
Reg.CloseKey;
started := true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
CPUU: integer;
begin
if started then
begin
    Reg.OpenKey('PerfStats\StatData', false);
    Reg.ReadBinaryData('KERNEL\CPUUsage', CPUU, SizeOf(Integer));
    Reg.CloseKey;
    Label1.Caption := IntToStr(CPUU) + '%';
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
num: array[0..1024] of byte;
begin
       Reg.OpenKey('PerfStats\StopStat', false);
       Reg.ReadBinaryData('KERNEL\CPUUsage', num, SizeOf(num));
       Reg.Free;
       Started := false;
end;
end.


How to map the hard drive.
In some applications you may have to create a logical drive that refers to a disk network path to a remote server. The suggested tip is concerned with "map" one in a completely automatic disk
 
DWORD WNetAddConnection2( 
    LPNETRESOURCE lpNetResource,  
    LPCTSTR lpPassword,
    LPCTSTR lpUsername,
    DWORD dwFlags 
   ); 

Function MappaDischi(LocalUnit, UserN, PassW: String): boolean; 
var 
  NRW: NetResource;
  Res: DWORD; begin 
  Result := False; 

  NRW.dwType := RESOURCETYPE_DISK; 
  NRW.lpLocalName := PChar(LocalUnit + ':');
  NRW.lpRemoteName := PChar('\\indirizzoIP\D$'); 
  NRW.lpProvider := ''; 

  Res = WNetAddConnection2(NRW, PChar(PassW), PChar(UserN), 
CONNECT_UPDATE_PROFILE) 

  Result := (Res <> NO_ERROR) 
  If Not Result Then ShowMessage('Non è possibile eseguire la mappatura); 
end;


How many applications we have installed in our system?
Using this TIPS we can know how many and which programs have installed on our computer.
 

procedure TForm1.Button1Click(Sender: TObject);
const
  REGKEYAPPS = 'SOFTWAREMicrosoftWindows
	               CurrentVersionUninstall';

var
  reg    : TRegistry;
  List1  : TStringList;
  List2  : TStringList;
  i, n   : integer;

begin
  reg    := TRegistry.Create;
  List1  := TStringList.Create;
  List2  := TStringList.Create;

  with reg do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey(REGKEYAPPS, false);
    GetKeyNames(List1);
  end;
  for i := 0 to List1.Count -1 do
  begin
    reg.OpenKey(REGKEYAPPS + '' + List1.Strings[i],false);
    reg.GetValueNames(List2);

    n := List2.IndexOf('DisplayName');
    if (n <> -1) and 
       (List2.IndexOf('UninstallString') <> -1) then
    begin
      ListBox1.Items.Add(
          (reg.ReadString(List2.Strings[n])));
    end;
  end;
  List.Free;
  List2.Free;
  reg.CloseKey;
  reg.Destroy;
end;


Save the clipboard to a file.
The following example is valid only for text data, but can be changed easily by acting on "CF_TEXT", changing TEXT with the type of data on the clipboard. For example in the case of text data you just make a call to SaveClipboardTextDataToFile () function followed by the file name: SaveClipboardTextDataToFile ('c: \ temp.txt') ;.
 

 function SaveClipboardTextDataToFile( sFileTo : string ) : boolean;
var
  ps1,
  ps2   : PChar;
  dwLen : DWord;
  tf    : TextFile;
  hData : THandle;
begin
  Result := False;
  with Clipboard do
  begin
    try
      Open;
      if( HasFormat( CF_TEXT ) ) then
      begin
        hData :=
          GetClipboardData( CF_TEXT );

        ps1 := GlobalLock( hData );
        dwLen := GlobalSize( hData );

        ps2 := StrAlloc( 1 + dwLen );

        StrLCopy( ps2, ps1, dwLen );

        GlobalUnlock( hData );
        
        AssignFile( tf, sFileTo );
        ReWrite( tf );
        Write( tf, ps2 );
        CloseFile( tf );

        StrDispose( ps2 );

        Result := True;
      end;
    finally
      Close;
    end;
  end;
end;


Date and time of creation and modification of a file.
The function FileAge () returns the date / time stamp (date and time of creation or modification) of a file. The value obtained by this function is an integer before being used must be converted into a TDateTime value (float). The following code shows how to do this ..
 
procedure TForm1.Button1Click(Sender: TObject);
var
  File_Name: string;
  DateTimeStamp: integer;
  Date_Time: TDateTime;
begin
  File_Name := 'c:\Documenti\test.doc';
  DateTimeStamp := FileAge(File_Name);
  // FileAge returns -1 if file not found
  if DateTimeStamp < 0 then
    ShowMessage('File non trovato')
  else begin
    // Converte nel formato TDateTime
    Date_Time := FileDateToDateTime(DateTimeStamp);
    Label1.Caption := DateToStr(Date_Time);
    Label2.Caption := TimeToStr(Date_Time);
  end;
end;


Photographing the screen.
Save in a bitmap what we see on the video. 
procedure TForm1.Button1Click(Sender: TObject);
var
  DeskTopDC: HDc;
  DeskTopCanvas: TCanvas;
  DeskTopRect: TRect;
  Bitmap: TBitmap;
begin
  DeskTopDC := GetWindowDC(GetDeskTopWindow);
  DeskTopCanvas := TCanvas.Create;
  DeskTopCanvas.Handle := DeskTopDC;
  DeskTopRect := Rect(0,0,Screen.Width,Screen.Height);
  Bitmap := TBitmap.Create;
  with Bitmap do
  begin
    Width := Screen.Width;
    Height:= Screen.Height;
    PixelFormat := pfDevice;
  end;
  Bitmap.Canvas.CopyRect(DeskTopRect,DeskTopCanvas,DeskTopRect);
  Bitmap.SaveToFile ('c:\temp\sample.bmp');
  Bitmap.Free;
  DesktopCanvas.Free;
  ReleaseDC(GetDeskTopWindow,DeskTopDC);
end;



Index

Go to page::  index, tips, programs, snap7, example , relax .