Downloading a URL’s HTML

Problem/Question/Abstract:

Downloading a URL’s HTML

Answer:

The objects I present in this article allow you to download data from any URL using the GET method, using only the standard socket components included with Delphi 4+. The object (TabHTTPRequest) is capable of connecting directly to a web server and then requesting a file, the object can also pass a query string; as of this writing it can only get a file using the GET method and using a query string. If there is sufficient interest I can expand the object to also handle POST and cookies, as well as interpreting the result so the return header can be used, so let me know what you guys think!

TInternetURI – This object takes a URI (uniform resource indicator) and splits it into it’s various components to allow the GET object to accept a URL such as http://www.borland.com/delphi/ as a parameter. You do not need to use this object directly.  This object however, follows the complete RFC standard for HTTP addresses and can be used to interpret any URL into its various components.

TabHTTPRequest – This object is designed to connect to a web server and download the HTML, which can then be used in your application.

A couple examples:

URL:

http://www.borland.com/delphi/

CODE:

with TabHTTPRequest.Create do
begin
  Get('http://www.borland.com/delphi/');
  // Work with result (ex. mmURL.Text := ResultData.DataString);
  Free;
end; // with

URL:

http://www.borland.com/rad/delandcppletter.html

CODE:

with TabHTTPRequest.Create do
begin
  Get('http://www.borland.com/rad/delandcppletter.html’);
    // Work with result (ex. mmURL.Text := ResultData.DataString);
    Free;
end; // with

URL: (This is an actual search on yahoo)

http://google.yahoo.com/bin/query?p=delphi+3000&hc=0&hs=0

CODE:

with TabHTTPRequest.Create do
begin
  Get('http://google.yahoo.com/bin/query?p=delphi+3000&hc=0&hs=0');
  // Work with result (ex. mmURL.Text := ResultData.DataString);
  Free;
end; // with

Once get has been called you can access the HTML through the ResultData property:

mmHTML.Lines.Text := URLObject.ResultData.DataString;

I hope you found this article and function to be useful; I’d love to hear your comments, suggestions, etc.

The following is the source code for the functions described above, feel free to use the code in your own programs, but please leave my name and address intact!

I also have a complete test program available by request via e-mail.

// ---------------------------ooo------------------------------ \\
// ©2000 David Lederman
// dlederman@ssccompany.com
// ---------------------------ooo------------------------------ \\
unit abHTTPGet;

interface

uses
  Classes, Sysutils, ScktComp;

// ---------------------------ooo------------------------------ \\
// This type will crack a Uniform Resource Indicator
// ---------------------------ooo------------------------------ \\
type
  TInternetURI = class(TObject)
  private
    function CrackScheme(var URIData: string): string;
    function CrackLocation(var URIData: string): string;
    function CrackQuery(var URIData: string): string;
    function CrackParams(var URIData: string): string;
  public
    Scheme: string;
    NetLocation: string;
    Path: string;
    Query: string;
    Fragment: string;
    Params: string;
    constructor Create(URIData: string);
    destructor Destroy; override;
  end;

type
  TabHTTPRequest = class
  private
    iBuffer: string;
    Socket: TClientSocket;
  public
    ResultData: TStringStream;
    HostToConnect: string;
    PortToConnect: Integer;
    FileToGet: string;
    TimeOut: Integer;
    function Get: Boolean; overload;
    function Get(URL: string): Boolean; overload;
    constructor Create;
    destructor Destroy; override;
  end;

  // ---------------------------ooo------------------------------ \\
  // Global HTTP Routines
  // ---------------------------ooo------------------------------ \\
function TrimToToken(Token: Char; var DataToParse: string; CopyToken: Boolean = True;
  MaxCount: Integer = 1): string;
function TrimPastToken(Token: Char; var DataToParse: string; CopyToken: Boolean =
  True; MaxCount: Integer = 1): string;

implementation

{ TabHTTPRequest }

constructor TabHTTPRequest.Create;
begin
  // Simply Set Defaults
  HostToConnect := 'www.InternetToolsCorp.com';
  PortToConnect := 80;
  FileToGet := '/';
  TimeOut := 5000;
  // Create the socket object
  Socket := TClientSocket.Create(nil);
  Socket.ClientType := ctBlocking;
  // Create the result stream
  ResultData := TStringStream.Create('');
end;

destructor TabHTTPRequest.Destroy;
begin
  // Free the helper objects
  Socket.Free;
  ResultData.Free;
  inherited;
end;

function TabHTTPRequest.Get: Boolean;
var
  Waiter: TWinSocketStream;
  BufferData: array[0..4028] of char;
  DataRead: Integer;
  BufferString: string;
begin
  // Setup the Request
  Waiter := nil;
  iBuffer := '';
  Socket.Host := HostToConnect;
  Socket.Port := PortToConnect;
  // Reset the data stream
  ResultData.Size := 0;
  try
    // Do the request
    // Open the connection
  //  Socket.Open;
    Socket.Open;
    // Create the waiter
    Waiter := TWinSocketStream.Create(Socket.Socket, TimeOut);
    // Prepare the request
    BufferString := 'GET ' + FileToGet + ' HTTP/1.1' + #13#10 + 'Host: ' +
      HostToConnect + #13#10 + #13#10;
    // Write the Request
    Waiter.Write(BufferString[1], Length(BufferString));
    Waiter.Free;
    Waiter := nil;
    // Now process the result of the request
    while Socket.Socket.Connected do
    begin
      try
        // Create the waiter
        Waiter := TWinSocketStream.Create(Socket.Socket, TimeOut);
        // Wait for data
        if Waiter.WaitForData(TimeOut) then
        begin
          // Try to read a chunck of data
          DataRead := Waiter.Read(BufferData, SizeOf(BufferData));
          // Check if we got data
          if DataRead = 0 then
          begin
            // Get out
            Socket.Close;
          end
          else
          begin
            // Save the data to the stream
            ResultData.Write(BufferData, DataRead);
          end;
        end
        else
        begin
          Socket.Close;
        end;
      finally
        Waiter.Free;
        Waiter := nil;
      end;
    end;
    // close the socket
    if Socket.Active then
      Socket.Close;
    Result := True;
    // Clean up
    if Waiter <> nil then
      Waiter.Free;
  except
    // Free the waiter object
    if Waiter <> nil then
      Waiter.Free;
    // Close the socket if it's open
    if Socket.Active then
      Socket.Close;
    // reraise the exception
    raise;
  end;
end;

function TabHTTPRequest.Get(URL: string): Boolean;
begin
  // Crack the URL
  try
    // Make sure than a scheme is in place
    if Pos('://', URL) = 0 then
    begin
      // Simply Prepend the HTTP
      URL := 'http://' + URL;
    end;
    // Make sure that a / is in the URL
    if Pos('/', Copy(URL, 8, Length(URL))) = 0 then
    begin
      // Simply Append the trailing /
      URL := URL + '/';
    end;

    with TInternetURI.Create(URL) do
    begin
      // Check if there is a port in the net location
      if Pos(':', NetLocation) <> 0 then
      begin
        // Copy the host name
        HostToConnect := Copy(NetLocation, 1, Pos(':', NetLocation) - 1);
        // Copy the port
        PortToConnect := StrToInt(Copy(NetLocation, Pos(':', NetLocation) + 1,
          Length(NetLocation)));
      end
      else
      begin
        HostToConnect := NetLocation;
        PortToConnect := 80;
      end;
      FileToGet := '';
      // Set the File to get
      if Query <> '' then
        FileToGet := Path + '?' + Query;
      if FileToGet = '' then
        FileToGet := '/';
      Free
    end; // with
    // Now simply call get
    Result := Get;
  except
    raise;
  end;
end;

{ TInternetURI }

function TInternetURI.CrackLocation(var URIData: string): string;
var
  StartPos, EndPos: Integer;
begin
  // Step 1. - See if the network ID is here
  StartPos := Pos('//', URIData);
  // If the starting // is not found then there is no network location
  if StartPos = 0 then
    Exit;
  // Delete the first //
  Delete(URIData, StartPos, 2);
  // Now look for the trailing slash
  EndPos := Pos('/', URIData);
  if (EndPos = 0) or (EndPos = 1) then
    Exit;
  // Now Copy the String Upto the /
  Result := Copy(URIData, 1, EndPos - 1);
  // Now Delete the network location
  Delete(URIData, 1, EndPos - 1);
end;

function TInternetURI.CrackParams(var URIData: string): string;
var
  StartPos: Integer;
begin
  // Step 1. - See if the query is here
  StartPos := Pos(';', URIData);
  // If the starting ; is not found then there are no params
  if StartPos = 0 then
    Exit;
  // Copy the Params String
  Result := Copy(URIData, StartPos + 1, Length(URIData));
  Delete(URIData, StartPos, Length(URIData));
end;

function TInternetURI.CrackQuery(var URIData: string): string;
var
  StartPos: Integer;
begin
  // Step 1. - See if the query is here
  StartPos := Pos('?', URIData);
  // If the starting ? is not found then there is no query
  if StartPos = 0 then
    Exit;
  // Copy the Query String
  Result := Copy(URIData, StartPos + 1, Length(URIData));
  Delete(URIData, StartPos, Length(URIData));
end;

function TInternetURI.CrackScheme(var URIData: string): string;
const
  AllowedChars = ['A'..'Z', 'a'..'z', '0'..'9', '+', '-', '.'];
var
  tString, WorkData: string;
  i: Integer;
  StringLength: Integer;
  InValidScheme: Boolean;
begin
  // Step 1. - Get To The First
  WorkData := TrimToToken(':', URIData, False);
  if WorkData = '' then
  begin
    Result := '';
    Exit;
  end;
  // Get The String Length
  StringLength := Length(WorkData);
  // See if any invalid characters are in the system
  InValidScheme := False;
  for i := 1 to StringLength do
  begin
    // Check if the char is valid
    InValidScheme := (WorkData[i] in AllowedChars) = False;
    if InValidScheme then
      Break;
  end;
  if InValidScheme then
  begin
    // we need to return the data back to the string
    URIData := WorkData + ':' + URIData;
  end
  else
  begin
    Result := WorkData;
  end;
end;

constructor TInternetURI.Create(URIData: string);
begin
  // Step 1. - Copy The Fragment
  Fragment := TrimPastToken('#', URIData, False);
  // Step 2. - Crack the Scheme
  Scheme := CrackScheme(URIData);
  // Step 3. - Crack the Network Location
  NetLocation := CrackLocation(URIData);
  // Step 4. - Crack the Query
  Query := CrackQuery(URIData);
  // Step 5. - Crack the Parameters
  Params := CrackParams(URIData);
  // Finally !! Copy the Path (which should be all that is remaining)
  Path := URIData;
end;

destructor TInternetURI.Destroy;
begin
  inherited;

end;

// ---------------------------ooo------------------------------ \\
// Global routines for HTTP Processing
// ---------------------------ooo------------------------------ \\
// ---------------------------ooo------------------------------ \\
// This function will take the DataToParse and create a string
// list seperating the data using the user-defined tokens.
// ---------------------------ooo------------------------------ \\

function TokenizeString(Tokens: TSysCharSet; DataToParse: string): TStringList;
var
  StringLength: Integer;
  i, CurPos, StartPos: Integer;
  tempString: string;
begin
  try
    // Create the result set
    Result := TStringList.Create;
    // Get The String Length
    StringLength := Length(DataToParse);
    // Setup the search
    CurPos := 1;
    StartPos := 1;
    // Look for the tokens
    for i := 1 to StringLength do
    begin
      // Increment the current position
      Inc(CurPos);
      // See if the char is in the token list
      if DataToParse[i] in Tokens then
      begin
        // copy the string to current
        tempString := Copy(DataToParse, StartPos, (CurPos - 1) - StartPos);
        Result.Add(tempstring);
        StartPos := i + 1;
      end;
    end;
    // Copy the final string (if neccesary)
    if (StartPos - 1) <> StringLength then
    begin
      tempString := Copy(DataToParse, StartPos, StringLength);
      Result.Add(tempString);
    end;
  except
    Result.Free;
    Result := nil;
  end;
end;

// ---------------------------ooo------------------------------ \\
// This function will use the TokenizeString routine to get
// all the occurences of Token then return all the string to
// the right of MaxCount occurences.
// ---------------------------ooo------------------------------ \\

function TrimToToken(Token: Char; var DataToParse: string; CopyToken: Boolean = True;
  MaxCount: Integer = 1): string;
var
  i: Integer;
begin
  // First Tokenize the string
  with TokenizeString([Token], DataToParse) do
  begin
    // Check if there were any occurences of Token
    if Count = 0 then
    begin
      // Return blank then free and exit
      Result := '';
      Free;
      Exit;
    end;
    // reset the final string
    DataToParse := '';
    for i := 0 to (MaxCount - 1) do
    begin
      // concat the string
      if CopyToken then
        Result := Result + Strings[i] + Token
      else
        Result := Result + Strings[i];
    end;
    // Copy and remaining data
    for i := (MaxCount) to Pred(Count) do
    begin
      DataToParse := DataToParse + Strings[i];
    end;
    Free;
  end;
end;

// ---------------------------ooo------------------------------ \\
// This function will use the TokenizeString routine to get
// all the occurences of Token then return all the string to
// the left of MaxCount occurences.
// ---------------------------ooo------------------------------ \\

function TrimPastToken(Token: Char; var DataToParse: string; CopyToken: Boolean =
  True; MaxCount: Integer = 1): string;
var
  i: Integer;
begin
  // First Tokenize the string
  with TokenizeString([Token], DataToParse) do
  begin
    // Check if there were any occurences of Token
    if Count = 0 then
    begin
      // Return blank then free and exit
      Result := '';
      Free;
      Exit;
    end;
    // reset the final string
    DataToParse := '';
    for i := 0 to (MaxCount - 1) do
    begin
      // concat the string
      DataToParse := DataToParse + Strings[i];
    end;
    // Copy and remaining data
    for i := (MaxCount) to Pred(Count) do
    begin
      if CopyToken then
        Result := Result + Token + Strings[i]
      else
        Result := Result + Strings[i];
    end;
    Free;
  end;
end;

end.

How to position maximized forms

Problem/Question/Abstract:

I am working on a project that must keep the 640x480 pixel screen size. I would like to make it MDI. I've designed a small form with a menu and a tool bar (like Delphi's IDE). The user will click on this IDE like form and a new window will be display. Here is the problem: When the user maximizes this window, it goes to (0,0) thus hiding IDE form.

Answer:

Handle WM_GETMINMAXINFO, that allows you to specify position and size of the maximized window:


private
{ Private declarations }

procedure WMGetMinMaxInfo(var msg: TWMGetMinmaxInfo); message WM_GETMINMAXINFO;

procedure TForm2.WMGetMinMaxInfo(var msg: TWMGetMinmaxInfo);
var
  r: TRect;
begin
  inherited;
  SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0);
  r.top := Application.Mainform.Height + Application.Mainform.Top;
  with msg.MinMaxInfo^.ptMaxSize do
  begin
    x := r.right - r.left;
    y := r.bottom - r.top;
  end;
  msg.Minmaxinfo^.ptmaxPosition := r.TopLeft;
end;


This code will make the form use the full available screen area (minus taskbar) under the main form, you will need to modify it to limit it to a maximum of 640x480.

Export ALL tables from MS jet to CSV via ADO

Problem/Question/Abstract:

How to export All Tables in a Microsoft Jet DB to a CSV file

Answer:

procedure TMainForm.SaveAllTablesToCSV(DBFileName: string);
var
  InfoStr,
    FileName,
    RecString,
    WorkingDirectory: string;
  OutFileList,
    TableNameList: TStringList;
  TableNum,
    FieldNum: integer;
  VT: TVarType;
begin
  ADOTable1.Active := false;
  WorkingDirectory := ExtractFileDir(DBFileName);
  TableNameList := TStringList.Create;
  OutFileList := TStringList.Create;
  InfoStr := 'The following files were created' + #13#13;

  ADOConnection1.GetTableNames(TableNameList, false);
  for TableNum := 0 to TableNameList.Count - 1 do
  begin
    FileName := WorkingDirectory + '\' +
      TableNameList.Strings[TableNum] + '.CSV';
    Caption := 'Saving "' + ExtractFileName(FileName) + '"';
    ADOTable1.TableName := TableNameList.Strings[TableNum];
    ADOTable1.Active := true;
    OutFileList.Clear;

    ADOTable1.First;
    while not ADOTable1.Eof do
    begin

      RecString := '';
      for FieldNum := 0 to ADOTable1.FieldCount - 1 do
      begin
        VT := VarType(ADOTable1.Fields[FieldNum].Value);
        case VT of
          // just write the field if not a string
          vtInteger, vtExtended, vtCurrency, vtInt64:
            RecString := RecString + ADOTable1.Fields[FieldNum].AsString
        else
          // it IS a string so put quotes around it
          RecString := RecString + '"' +
            ADOTable1.Fields[FieldNum].AsString + '"';
        end; { case }

        // if not the last field then use a field separator
        if FieldNum < (ADOTable1.FieldCount - 1) then
          RecString := RecString + ',';
      end; { for FieldNum }
      OutFileList.Add(RecString);

      ADOTable1.Next;
    end; { while }

    OutFileList.SaveToFile(FileName);
    InfoStr := InfoStr + FileName + #13;
    ADOTable1.Active := false;

  end; { for  TableNum }
  TableNameList.Free;
  OutFileList.Free;
  Caption := 'Done';
  ShowMessage(InfoStr);
end;

procedure TMainForm.Button1Click(Sender: TObject);
const
  ConnStrA = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=';
  ConnStrC = ';Persist Security Info=False';
  ProvStr = 'Microsoft.Jet.OLEDB.4.0';
begin
  OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));
  if OpenDialog1.Execute then

  try
    ADOConnection1.ConnectionString :=
      ConnStrA + OpenDialog1.FileName + ConnStrC;
    ADOConnection1.Provider := ProvStr;
    ADOConnection1.Connected := true;
    ADOTable1.Connection := ADOConnection1;
    SaveAllTablesToCSV(OpenDialog1.FileName);
  except
    ShowMessage('Could not Connect to ' + #13 +
      '"' + OpenDialog1.FileName + '"');
    Close;
  end;

end;

How to check file and directory attributes

Problem/Question/Abstract:

How to check file and directory attributes

Answer:

The sample below works with the folder c:\temp .

procedure TForm1.Button1Click(Sender: TObject);
var
  Ergebnis: integer;
  Hidden: boolean;
  ReadOnly: boolean;
  Directory: boolean;
begin
  {Get the current file attributes and store them in a local bool variable.
  lbl_hidden, lbl_ReadOnly and lbl_Directory are TLabels}
  Ergebnis := fileGetAttr('C:\Temp');
  if Ergebnis and faHidden <> 0 then
  begin
    hidden := True;
    lbl_hidden.Caption := 'Hidden File';
  end
  else
  begin
    Hidden := False;
    lbl_hidden.Caption := 'Not a hidden file';
  end;
  if Ergebnis and faDirectory <> 0 then
  begin
    Directory := True;
    lbl_Directory.Caption := 'We have a directory';
  end
  else
  begin
    Directory := False;
    lbl_Directory.Caption := 'There is no directory';
  end;
  if Ergebnis and faReadOnly <> 0 then
  begin
    ReadOnly := True;
    lbl_ReadOnly.Caption := 'File is write-protected';
  end
  else
  begin
    ReadOnly := False;
    lbl_ReadOnly.Caption := 'File is not write-protected';
  end;
  refresh;
  sleep(4000);
  {Set attributes}
  FileSetAttr('C:\Temp', faHidden or faReadOnly or faDirectory);
  {Check set attributes and reset Ergebnis variable to original status}
  Ergebnis := FileGetAttr('C:\Temp');
  if Ergebnis and faHidden <> 0 then
  begin
    lbl_hidden.Caption := 'Attribute Hidden is set'; {TLabel}
    if not hidden then
      Ergebnis := Ergebnis xor fahidden;
  end
  else
    lbl_hidden.Caption := 'Attribute Hidden is not set';
  if Ergebnis and faReadOnly <> 0 then
  begin
    lbl_ReadOnly.Caption := 'Attribute Read Only is set';
    if not ReadOnly then
      Ergebnis := Ergebnis xor faReadOnly;
  end
  else
    lbl_ReadOnly.Caption := 'Attribute ReadOnly not set';
  if Ergebnis and faDirectory <> 0 then
  begin
    lbl_Directory.Caption := 'Directory set';
    if not Directory then
      Ergebnis := Ergebnis xor faDirectory;
  end
  else
    lbl_Directory.Caption := 'Directory not set';
  refresh;
  sleep(4000);
  {Reset attributes}
  FileSetAttr('C:\Temp', Ergebnis);
  {Check if attributes were reset correctly}
  Ergebnis := fileGetAttr('C:\Temp');
  if Ergebnis and faHidden <> 0 then
    lbl_hidden.Caption := 'Hidden file'
  else
    lbl_hidden.Caption := 'Not a hidden file';
  if Ergebnis and faDirectory <> 0 then
    lbl_Directory.Caption := 'We have a directory'
  else
    lbl_Directory.Caption := 'There is no directory';
  if Ergebnis and faReadOnly <> 0 then
    lbl_ReadOnly.Caption := 'File is write-protected'
  else
    lbl_ReadOnly.Caption := 'File is not write-protected';
  refresh;
end;

Include a JPEG in your EXE file

Problem/Question/Abstract:

Include a JPEG in your EXE file

Answer:

Create a resource script file MyPic.RC with Notepad and add the following line:

1  RCDATA  "Pic.jpg"

Then use Borland's Resource Compiler BRCC32.EXE (a commandline tool) to compile it into a .RES file:

BRCC32 MyPic.RC

Add a compiler directive to the source code of your program. It should immediately follow the form directive, as shown here:

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


Use the following code in your application:


procedure LoadJPEGfromEXE;
var
  MyJPG: TJPEGImage; // JPEG object
  ResStream: TResourceStream; // Resource Stream object
begin
  try
    MyJPG := TJPEGImage.Create;
    ResStream := TResourceStream.CreateFromID(HInstance, 1, RT_RCDATA);
    MyJPG.LoadFromStream(ResStream); // What!? Yes, that easy!
    Canvas.Draw(12, 12, MyJPG); // draw it to see if it really worked!
  finally
    MyJPG.Free;
    ResStream.Free;
  end;
end; // procedure

MSN tcp protocol issues

Problem/Question/Abstract:

More info about communicating with the msn service

Answer:

create additional features for the msn-delphi-clone found at torry's (see also my prev msn-article for also a ref to a delphi-code sample on torry)

[1]Connecting to msn server:

Connect: messenger.hotmail.com 1863
>>> VER 0 MSNP7 MSNP6 MSNP5 MSNP4 CVR0
<<< VER 0 MSNP7 MSNP6 MSNP5 MSNP4 CVR0
>>> INF 1
<<< INF 1 MD5
>>> USR 2 MD5 I example@passport.com
<<< XFR 2 NS 64.4.12.132:1863 0
Disconnect

Hier is MD5 het encryptie algoritme

[2]Get to the notification server:

Connect: 64.4.12.132 1863
>>> VER 3 MSNP7 MSNP6 MSNP5 MSNP4 CVR0
<<< VER 3 MSNP7 MSNP6 MSNP5 MSNP4 CVR0
>>> INF 4
<<< INF 4 MD5
>>> USR 5 MD5 I example@passport.com
<<< USR 5 MD5 S 1013928519.693957190
>>> USR 6 MD5 S 23e54a439a6a17d15025f4c6cbd0f6b5
<<< USR 6 OK example@passport.com My%20Screen%20Name 1
>>> CHG 7 NLN
<<< CHG 7 NLN
Continue Session . . .

[3] Change status msn user:

>>> CHG 8 AWY
<<< CHG 8 AWY
>>> CHG 9 NLN
<<< CHG 9 NLN
>>> CHG 10 HDN
<<< CHG 10 HDN

NLN Online
FLN Offline
HDN Appear Offline
IDL Idle
AWY Away
BSY Busy
BRB Be Right Back
PHN On the Phone
LUN Out to Lunch

[4] contactspersonen

There are four types of contact lists, each with a two letter code.

FL Forward List - Users on your contact list.
RL Reverse List - Users who have you on their contact list.
AL Allow List - Users who are allowed to see your status.
BL Block List - Users who are not allowed to see your status.

If there are no users on the requested list, the server will reply with 0 for both the user number and the total number of users, and there will be no fifth or sixth parameter. Below are some exampes of requesting lists.

>>> LST 10 FL
<<< LST 10 FL 21 1 3 example@passport.com Mike 0
<<< LST 10 FL 21 2 3 name_123@hotmail.com Name_123 2
<<< LST 10 FL 21 3 3 myname@msn.com My%20Name 0
>>> LST 11 BL
<<< LST 11 BL 3 0 0

[5] change your screen-name

>>> REA 25 example@passport.com My%20New%20Name
<<< REA 25 115 example@passport.com My%20New%20Name
>>> REA 26 example@passport.com fuck
<<< 209 26

[ErrCodes]When something goes wrong, the server sends an error command:

200 Syntax error
201 Invalid parameter
205 Invalid user
206 Domain name missing
207 Already logged in
208 Invalid username
209 Invalid fusername
210 User list full
215 User already there
216 User already on list
217 User not online
218 Already in mode
219 User is in the opposite list
280 Switchboard failed
281 Transfer to switchboard failed


300 Required field missing
302 Not logged in


500 Internal server error
501 Database server error
510 File operation failed
520 Memory allocation failed


600 Server is busy
601 Server is unavaliable
602 Peer nameserver is down
603 Database connection failed
604 Server is going down


707 Could not create connection
711 Write is blocking
712 Session is overloaded
713 Too many active users
714 Too many sessions
715 Not expected
717 Bad friend file


911 Authentication failed
913 Not allowed when offline
920 Not accepting new users


search google for MSN protocol for more info ...

Component for Saving User Settings automatically (using Tools API)

Problem/Question/Abstract:

There are many routines every Delphi programmer does on an almost daily basis. One of these routines is writing and retrieving user settings to/from the Windows Registry. More and more applications "remember" some of our favorite settings, like form position and size.
For the programmer it is an rather boring and time-consuming part to save all these settings, but the user is almost expecting such basic functionality. The TComponentStateRecorder component will help you to achieve this functionality by simply adding it to your form at design-time.

Answer:

Note: The component provided with this article was developed using Borland Delphi 5. It should work with Borland Delphi 4, too. For newer version, some adoptions are required, as Borland has renamed some of the units.

This is going to be a rather complex article. You should be familiar with object oriented programming, as well as have some experience in component writing. If not, simply download the component and come back at a later time and re-read this article. Take a look at the "How-to" section.

The Principle

Our component allows the programmer to set the Registry Key, where the settings will be saved. All recorded data will be written at the set location. The value name will be created using the component name, a colon and the property name. The value will be saved as string.

Any component on the same form as the Component State Recorder is placed upon, con be chosen to be saved.

The following property types of any chose component can be saved. The value of all properties will be converted into their string representation. Following property types can be used:

tkInteger
tkInt64
tkFloat
tkEnumeration
tkSet
tkChar
tkString
tkLString

The Component State Recorder publishes the SavedComponents collection, where all components, whose values should be recorded, can be added to. Every item (TSavedComponent) of this collection publishes another collection. All recorded properties (TSavedProperty) are saved within this collection.

Planning the Component State Recorder

The Component State Recorder, will be visible at design-time only, therefore we will create a descendant auf the TComponent class. We will name the class TComponentStateRecorder. The Component State Recorder has a property for the Registry key, where all the data will be recorded. Our default setting will be: \Software\Your Software\Component State Recorder\ + the forms name (RegistryKey). Further we will publish a collection, where all recorded components are listed, named (TSavedComponents).

The Saved Components collection (TSavedComponents) is a descendent of the TCollection from the Classes unit. Basically, we do not have to create our own logic for such collections, however, we will have to override some methods and introduce the items property. The items property will give us access to each saved component individually.

The Saved Component item class (TSavedComponent) is a descendent of the TCollectionItem class from the Classes unit. We will publish two new properties. The first property (ComponentName) allows us to choose the component that will be controlled. The second property is, once again, a collection, giving access to each controlled property, individually.

The Saved Properties collection (TSavedProperties) is a descendent of the TCollection from the Classes unit, too. Same rules apply to this collection, as for TSavedComponents. We will give access to zero or more saved property items through the items property.

The Saved Property item class (TSavedProperty) is a descendent of the TCollectionItem class from the Classes unit. We will publish two new properties. The first property allows us to choose the components property to be saved, the second allows us to set a default value, if the registry has no settings saved.

Loading and Saving the States

Our Component State Recorder class defines the private method

procedure DoStates(Action: TRecorderAction);

This method will both, load and save the current component state from/to the Windows Registry. For the programmer we will create two wrapper methods for loading and saving, which both will call this method internally.

DoStates will open access to the registry. Then it will iterate through all components in its collections and every property within its collection. Each property value will be set/loaded separately. When loading a value that is not in the registry, the Component State Recorder will use the default value provided during design time.

The Component State Recorder will check first, if the component requested exists. If not, it will continue with the next component. Then it will check for each property separately and will load/save them, if they exist within the component.

Creating Property Editors

Writing Property Editors is a rather easy task. Delphi provides many descendants of the TPropertyEditor class, that actually provide the logic needed to create your own. For this component we will simply create two string editors. The first editor will allow us to choose for the SavedComponent property from a drop-down list of all components on the form. The second editor will do the same for the SavedProperty property of the TSavedProperty collection item.

Basically we do the same for both of them. First, we will override the GetAttributes function, allowing us to determine the behavior of the property editor. We tell the Object Inspector, to provide a drop-down list of sorted values.

Result := [paValueList, paSortList];

Second, we will override the GetValues function. The function takes on parameter, a pointer to a procedure allowing us to add a string for each item in the list, individually.

Depending on the property editor, we will either return a name list of all components on the form or a list of all properties of a specific component.

Creating a Component Dialog

Writing a component editor involves little more attention than creating a property editor, but it allows us to get done much faster when selecting component properties for automated backup. Delphi provides us the TDefaultEditor class for creating property editors. We will override three methods.

GetVerbCount: We will return 1, because we need only one menu item
GetVerb: Returns the name of the menu item (shown if the programmer right-clicks the component at design-time)
ExecuteVerb: Executed when the programmer clicks (one of) our menu item.

Within the ExecuteVerb method we will create a form and show it to the programmer. There he/she can easily editor our component.

The Component Editor Form

This part is not harder than the rest, but still, it is the most complex, because, we have to design the programmers interface and control the whole Component State Recorder.



With this done, we will need to fill in the code. The Component Dialog class, called by Delphi must pass along the Component State Recorder Component being edited, as well as the Designer interface.

Delphi will not know, if we change the component in the editor, we must therefore notify Delphi about such matters by calling the Designer.Modified; method. This will inform Delphi of any changes and ask the programmer to save the changes to file, if the project is closed!

The remainder is pretty straight forward. The Tree List View will show all managed components and their managed properties. Each item will hold an pointer to their related collection item in the Component State Recorder. This way we can easily modify it on demand.

Putting the Component State Recorder to Work

The Component State Recorder will not automatically load and save the states for us. You will have to call the ComponentStateRecorder1.LoadStates method during the FormCreate event and the ComponentStateRecorder1.SaveStates method during the FormDestroy event.

The Component State Recorder Source Code

unit ComponentStateRecovery;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  TypInfo, DsgnIntf;

type
  TSavedProperty = class;
  TSavedComponent = class;
  TComponentStateRecorder = class;

  // single property that will be saved
  TSavedProperty = class(TCollectionItem)
  private
    // name of property to be saved
    FPropertyName: string;
    // default value if property does not exist
    FDefaultValue: string;
    procedure SetPropertyName(const Value: string);
    procedure SetDefaultValue(const Value: string);
    function GetRegistryValue: string;
    procedure SetRegistryValue(const Value: string);
  protected
    function GetDisplayName: string; override;
  public
    constructor Create(aCollection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
  published
    property PropertyName: string read FPropertyName write SetPropertyName;
    property RegistryValue: string read GetRegistryValue write SetRegistryValue;
    property DefaultValue: string read FDefaultValue write SetDefaultValue;
  end;

  TSavedProperties = class(TCollection)
  private
    // owner of this collection
    FSavedComponent: TSavedComponent;
    function GetItem(Index: Integer): TSavedProperty;
    procedure SetItem(Index: Integer; const Value: TSavedProperty);
  protected
    function GetOwner: TPersistent; override;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(aSavedComponent: TSavedComponent);
    function Add: TSavedProperty;
    property SavedComponent: TSavedComponent read FSavedComponent;
    property Items[Index: Integer]: TSavedProperty read GetItem write SetItem;
  published
  end;

  TSavedComponent = class(TCollectionItem)
  private
    // name of component to be saved
    FComponentName: string;
    // properties of 'this' component to be saved
    FSavedProperties: TSavedProperties;
    procedure SetSavedProperties(const Value: TSavedProperties);
    procedure SetComponentName(const Value: string);
  protected
    function GetDisplayName: string; override;
  public
    constructor Create(aCollection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property SavedProperties: TSavedProperties
      read FSavedProperties
      write SetSavedProperties;
    property ComponentName: string read FComponentName write SetComponentName;
  end;

  TSavedComponents = class(TCollection)
  private
    // owner of this collection
    FComponentStateRecorder: TComponentStateRecorder;
    function GetItem(Index: Integer): TSavedComponent;
    procedure SetItem(Index: Integer; const Value: TSavedComponent);
  protected
    function GetOwner: TPersistent; override;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(aComponentStateRecorder: TComponentStateRecorder);
    function Add: TSavedComponent;
    property Items[Index: Integer]: TSavedComponent read GetItem write SetItem;
  published
  end;

  // action of the record (save to registry - or - load from registry)
  TRecorderAction = (raSave, raLoad);

  TComponentStateRecorder = class(TComponent)
  private
    // components of owner form to be saved
    FSavedComponents: TSavedComponents;
    // registry key - where form components will be saved
    FRegistryKey: string;
    procedure SetSavedComponents(const Value: TSavedComponents);
    procedure SetRegistryKey(const Value: string);
    procedure DoStates(Action: TRecorderAction);
  protected
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    procedure SaveStates;
    procedure LoadStates;
  published
    property SavedComponents: TSavedComponents
      read FSavedComponents
      write SetSavedComponents;
    property RegistryKey: string read FRegistryKey write SetRegistryKey;
  end;

procedure Register;

implementation

uses
  Registry;

procedure Register;
begin
  // register component
  RegisterComponents('gate(n)etwork', [TComponentStateRecorder]);
end;

function GetPropertyAsString(
  Component: TComponent; PropInfo: PPropInfo
  ): string;
begin
  with PropInfo^ do
    case PropType^.Kind of
      tkInteger:
        // get integer value
        Result := IntToStr(GetOrdProp(Component, PropInfo));
      tkInt64:
        // get integer (64 bit) value
        Result := IntToStr(GetOrdProp(Component, PropInfo));
      tkFloat:
        // get float value
        Result := FloatToStr(GetFloatProp(Component, PropInfo));
      tkEnumeration:
        // get enumeration value
        Result := GetEnumProp(Component, PropInfo);
      tkSet:
        // get set value
        Result := GetSetProp(Component, PropInfo);
      tkChar:
        // get single character value
        Result := Chr(GetOrdProp(Component, PropInfo));
      tkString, tkLString:
        // get string value
        Result := GetStrProp(Component, PropInfo);
    else
      Result := '';
    end;
end;

procedure SetPropertyFromString(
  Component: TComponent; PropInfo: PPropInfo; Value: string
  );
begin
  try
    with PropInfo^ do
      case PropType^.Kind of
        tkInteger:
          // set integer value
          SetOrdProp(Component, PropInfo, StrToIntDef(
            Value, GetOrdProp(Component, PropInfo)
            ));
        tkInt64:
          // set integer (64 bit) value
          SetInt64Prop(Component, PropInfo, StrToIntDef(
            Value, GetInt64Prop(Component, PropInfo)
            ));
        tkFloat:
          // set float value
          SetFloatProp(Component, PropInfo, StrToFloat(Value));
        tkEnumeration:
          // set enumeration value
          SetEnumProp(Component, PropInfo, Value);
        tkSet:
          // set set value
          SetSetProp(Component, PropInfo, Value);
        tkChar:
          // set single character value
          SetOrdProp(Component, PropInfo, Ord(Value[1]));
        tkString, tkLString:
          // set string value
          SetStrProp(Component, PropInfo, Value);
      end;
  except
  end;
end;

{ TSavedProperty }

procedure TSavedProperty.Assign(Source: TPersistent);
begin
  if Source is TSavedProperty then
  begin
    // assign all local values
    FPropertyName := TSavedProperty(Source).FPropertyName;
    FDefaultValue := TSavedProperty(Source).FDefaultValue;
  end
  else
  begin
    inherited Assign(Source);
  end;
end;

constructor TSavedProperty.Create(aCollection: TCollection);
begin
  inherited Create(aCollection);
  // set default values
  FPropertyName := '';
  FDefaultValue := '';
end;

function TSavedProperty.GetDisplayName: string;
begin
  // return property name or components name
  if FPropertyName <> '' then
    Result := FPropertyName
  else
    Result := inherited GetDisplayName;
end;

function TSavedProperty.GetRegistryValue: string;
begin
  // the registry value is created by the component and property names
  Result :=
    TSavedProperties(Collection).FSavedComponent.ComponentName + ':' +
    FPropertyName;
end;

procedure TSavedProperty.SetDefaultValue(const Value: string);
begin
  FDefaultValue := Value;
end;

procedure TSavedProperty.SetPropertyName(const Value: string);
var
  PropInfo: PPropInfo;
  TmpComponent: TComponent;
  CSR: TComponentStateRecorder;
begin
  // set property name
  FPropertyName := Value;
  // set default value on-demand
  if FDefaultValue = '' then
  begin
    // get state recorder
    CSR := TSavedComponents(
      TSavedProperties(Collection).FSavedComponent.Collection
      ).FComponentStateRecorder;
    // at design-time only, load components current value as default
    if csDesigning in CSR.ComponentState then
    begin
      // load the named component (or form)
      if
        TSavedProperties(Collection).FSavedComponent.ComponentName =
        CSR.Owner.Name then
        TmpComponent := CSR.Owner
      else
        TmpComponent := CSR.Owner.FindComponent(
          TSavedProperties(Collection).FSavedComponent.ComponentName
          );
      // check whether component was found
      if TmpComponent <> nil then
      begin
        // get property information
        PropInfo := GetPropInfo(TmpComponent.ClassInfo, Value);
        // check whether property information where found
        if PropInfo <> nil then
          // load current property value
          FDefaultValue := GetPropertyAsString(
            TmpComponent, PropInfo
            );
      end;
    end;
  end;
end;

procedure TSavedProperty.SetRegistryValue(const Value: string);
begin
  // ignore
end;

{ TSavedProperties }

function TSavedProperties.Add: TSavedProperty;
begin
  Result := TSavedProperty(inherited Add);
end;

constructor TSavedProperties.Create(aSavedComponent: TSavedComponent);
begin
  inherited Create(TSavedProperty);
  FSavedComponent := aSavedComponent;
end;

function TSavedProperties.GetItem(Index: Integer): TSavedProperty;
begin
  Result := TSavedProperty(inherited GetItem(Index));
end;

function TSavedProperties.GetOwner: TPersistent;
begin
  Result := FSavedComponent;
end;

procedure TSavedProperties.SetItem(Index: Integer; const Value: TSavedProperty);
begin
  inherited SetItem(Index, Value);
end;

procedure TSavedProperties.Update(Item: TCollectionItem);
begin
  inherited;
  // nothing to do
end;

{ TSavedComponent }

procedure TSavedComponent.Assign(Source: TPersistent);
begin
  if Source is TSavedComponent then
  begin
    // load values from source
    FComponentName := TSavedComponent(Source).FComponentName;
    FSavedProperties.Assign(TSavedComponent(Source).SavedProperties);
  end
  else
  begin
    inherited Assign(Source);
  end;
end;

constructor TSavedComponent.Create(aCollection: TCollection);
begin
  inherited Create(aCollection);
  FSavedProperties := TSavedProperties.Create(Self);
end;

destructor TSavedComponent.Destroy;
begin
  if not (
    csDesigning in
    TSavedComponents(Collection).FComponentStateRecorder.ComponentState
    ) then
  begin
    // in desgin-time mode, the designer will free the objects for us
    FSavedProperties.Free;
    FSavedProperties := nil;
  end;
  inherited Destroy;
end;

function TSavedComponent.GetDisplayName: string;
begin
  if FComponentName <> '' then
    Result := FComponentName
  else
    Result := inherited GetDisplayName;
end;

procedure TSavedComponent.SetComponentName(const Value: string);
begin
  FComponentName := Value;
end;

procedure TSavedComponent.SetSavedProperties(const Value: TSavedProperties);
begin
  FSavedProperties.Assign(Value);
end;

{ TSavedComponents }

function TSavedComponents.Add: TSavedComponent;
begin
  Result := TSavedComponent(inherited Add);
end;

constructor TSavedComponents.Create(
  aComponentStateRecorder: TComponentStateRecorder
  );
begin
  inherited Create(TSavedComponent);
  FComponentStateRecorder := aComponentStateRecorder;
end;

function TSavedComponents.GetItem(Index: Integer): TSavedComponent;
begin
  Result := TSavedComponent(inherited GetItem(Index));
end;

function TSavedComponents.GetOwner: TPersistent;
begin
  Result := FComponentStateRecorder;
end;

procedure TSavedComponents.SetItem(
  Index: Integer; const Value: TSavedComponent
  );
begin
  inherited SetItem(Index, Value);
end;

procedure TSavedComponents.Update(Item: TCollectionItem);
begin
  inherited;
  // nothing to do
end;

{ TComponentStateRecorder }

constructor TComponentStateRecorder.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  FSavedComponents := TSavedComponents.Create(Self);
  FRegistryKey :=
    '\Software\Your Software\Component State Recorder\' + TForm(aOwner).Name;
end;

destructor TComponentStateRecorder.Destroy;
begin
  FSavedComponents.Free;
  FSavedComponents := nil;
  inherited Destroy;
end;

procedure TComponentStateRecorder.DoStates(Action: TRecorderAction);
var
  RegistryOpened: Boolean;
  I, J: Integer;
  PropInfo: PPropInfo;
  TmpComponent: TComponent;
  SO: TSavedComponent;
  SP: TSavedProperty;
begin
  with TRegistry.Create do
  try
    // generally save settings for the user!
    RootKey := HKEY_CURRENT_USER;
    // open the registry key
    RegistryOpened := OpenKey(RegistryKey, True);
    try
      // iterate through all Components to be saved
      for I := 0 to Pred(FSavedComponents.Count) do
      begin
        // get current component
        SO := FSavedComponents.Items[I];
        // check, whether component name is set
        if SO.ComponentName = '' then
          Continue;
        // check, whether component is the owner form
        if SO.ComponentName = (Owner as TForm).Name then
          // use the owner forme
          TmpComponent := (Owner as TForm)
        else
          // find component on the owner form
          TmpComponent := (Owner as TForm).FindComponent(SO.ComponentName);
        // check component
        if TmpComponent = nil then
          // not found on form, check next in collection
          Continue;
        // iterate through all properties to be saved (of current Component)
        for J := 0 to Pred(SO.SavedProperties.Count) do
        begin
          // get current property
          SP := SO.SavedProperties.Items[J];
          // check, whether property name is set
          if SP.PropertyName = '' then
            Continue;
          // get property info pointer
          PropInfo := GetPropInfo(TmpComponent.ClassInfo, SP.PropertyName);
          // check for property
          if PropInfo = nil then
            // it does not exists, try next
            Continue;
          // registry access ?
          if RegistryOpened then
            // yes, save or load?
            if Action = raSave then
              // save
              WriteString(
                SP.RegistryValue, GetPropertyAsString(TmpComponent, PropInfo)
                )
            else
              {// load, does value exist? } if ValueExists(SP.RegistryValue) then
                // yes, load
                SetPropertyFromString(
                  TmpComponent, PropInfo, ReadString(SP.RegistryValue)
                  )
              else
                // no, get default
                SetPropertyFromString(TmpComponent, PropInfo, SP.DefaultValue)
            else
              // no registry access, in load mode?
              if Action = raLoad then
                // yes, load default
                SetPropertyFromString(TmpComponent, PropInfo, SP.DefaultValue);
        end;
      end;
    finally
      if RegistryOpened then
        CloseKey;
    end;
  finally
    Free;
  end;
end;

procedure TComponentStateRecorder.LoadStates;
begin
  DoStates(raLoad);
end;

procedure TComponentStateRecorder.SaveStates;
begin
  DoStates(raSave);
end;

procedure TComponentStateRecorder.SetRegistryKey(const Value: string);
begin
  if Value = '' then
    FRegistryKey :=
      '\Software\Your Software\Component State Recorder\' + TForm(Owner).Name
  else
    FRegistryKey := Value;
end;

procedure TComponentStateRecorder.SetSavedComponents(
  const Value: TSavedComponents
  );
begin
  FSavedComponents.Assign(Value);
end;

end.


The Property and Component Editors Source

unit frmDesignTimeEditor;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Buttons, ComCtrls, ComponentStateRecovery, DsgnIntf,
  TypInfo;

type
  // component editor for the TComponentStateRecorder class
  TCSRDesignEditor = class(TDefaultEditor)
  protected
  public
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
    procedure ExecuteVerb(Index: Integer); override;
  end;

  // property editor that lists all properties of a component at design-time
  TPropertyNameEditor = class(TStringProperty)
  public
    procedure GetValues(Proc: TGetStrProc); override;
    function GetAttributes: TPropertyAttributes; override;
  end;

  // property editor that lists all components at design-time
  TComponentNameEditor = class(TStringProperty)
  public
    procedure GetValues(Proc: TGetStrProc); override;
    function GetAttributes: TPropertyAttributes; override;
  end;

  TfrmCSRDesigner = class(TForm)
    Panel1: TPanel;
    Label1: TLabel;
    edtRegKey: TEdit;
    Panel2: TPanel;
    btnOK: TBitBtn;
    trvCollections: TTreeView;
    Panel3: TPanel;
    lblComponent: TLabel;
    cmbComponent: TComboBox;
    grpProperty: TGroupBox;
    lblPropertyName: TLabel;
    cmbPropertyName: TComboBox;
    lblDefaultValue: TLabel;
    edtDefaultValue: TEdit;
    btnAddComponent: TButton;
    btnRemove: TButton;
    btnAddProperty: TButton;
    procedure btnOKClick(Sender: TObject);
    procedure trvCollectionsChange(Sender: TObject; Node: TTreeNode);
    procedure btnAddComponentClick(Sender: TObject);
    procedure cmbComponentChange(Sender: TObject);
    procedure edtRegKeyChange(Sender: TObject);
    procedure cmbPropertyNameChange(Sender: TObject);
    procedure edtDefaultValueChange(Sender: TObject);
    procedure btnAddPropertyClick(Sender: TObject);
    procedure btnRemoveClick(Sender: TObject);
  private
    FCSR: TComponentStateRecorder;
    FDesigner: IFormDesigner;
    procedure SetCSR(const Value: TComponentStateRecorder);
    procedure ShowProperties(Name: string);
    procedure UpdateForSelectedNode;
    procedure SetDesigner(const Value: IFormDesigner);
  public
    property CSR: TComponentStateRecorder read FCSR write SetCSR;
    property Designer: IFormDesigner read FDesigner write SetDesigner;
  end;

var
  frmCSRDesigner: TfrmCSRDesigner;

procedure Register;

implementation

{$R *.DFM}

procedure Register;
begin
  // register component
  RegisterComponents('gate(n)etwork', [TComponentStateRecorder]);
  // register property editors (they will provide drop-down lists to the OI)
  RegisterPropertyEditor(
    TypeInfo(string), TSavedComponent, 'ComponentName', TComponentNameEditor
    );
  RegisterPropertyEditor(
    TypeInfo(string), TSavedProperty, 'PropertyName', TPropertyNameEditor
    );
  // register component editor
  RegisterComponentEditor(TComponentStateRecorder, TCSRDesignEditor);
end;

{ TCSRDesignEditor }

procedure TCSRDesignEditor.ExecuteVerb(Index: Integer);
begin
  with TfrmCSRDesigner.Create(Application) do
  try
    Designer := Self.Designer;
    CSR := TComponentStateRecorder(Component);
    ShowModal;
  finally
    Free;
  end;
end;

function TCSRDesignEditor.GetVerb(Index: Integer): string;
begin
  if Index = 0 then
    Result := 'Edit all recorded Properties...'
  else
    Result := '';
end;

function TCSRDesignEditor.GetVerbCount: Integer;
begin
  Result := 1;
end;

{ TPropertyNameEditor }

function TPropertyNameEditor.GetAttributes: TPropertyAttributes;
begin
  // the property editor will provide a sorted list of possible values
  Result := [paValueList, paSortList];
end;

procedure TPropertyNameEditor.GetValues(Proc: TGetStrProc);
var
  I, Count: Integer;
  PropInfos: PPropList;
  TmpComponent: TComponent;
  SC: TSavedComponent;
begin
  // check property type
  if not (GetComponent(0) is TSavedProperty) then
    Exit;
  // get TSavedComponent (parent object)
  SC := TSavedProperties(
    TSavedProperty(GetComponent(0)).Collection
    ).SavedComponent;
  // find the corresponding component
  if SC.ComponentName = Designer.Form.Name then
    TmpComponent := Designer.Form
  else
    TmpComponent := Designer.GetComponent(SC.ComponentName);
  // quit if component was not found
  if TmpComponent = nil then
    Exit;
  // determine the property count
  Count := GetPropList(TmpComponent.ClassInfo, [
    tkInteger, tkInt64, tkFloat, tkEnumeration, tkSet, tkChar, tkString,
      tkLString
      ], nil);
  // reserve memory needed for property informations
  GetMem(PropInfos, Count * SizeOf(PPropInfo));
  try
    // load property list
    GetPropList(TmpComponent.ClassInfo, [
      tkInteger, tkInt64, tkFloat, tkEnumeration, tkSet, tkChar, tkString,
        tkLString
        ], PropInfos);
    // save to object inspector list
    for I := 0 to Pred(Count) do
      Proc(PropInfos^[I]^.Name);
  finally
    // free resources
    FreeMem(PropInfos);
  end;
end;

{ TComponentNameEditor }

function TComponentNameEditor.GetAttributes: TPropertyAttributes;
begin
  // the property editor will provide a sorted list of possible values
  Result := [paValueList, paSortList];
end;

procedure TComponentNameEditor.GetValues(Proc: TGetStrProc);
var
  I: Integer;
begin
  // return name of form
  if Designer.Form.Name <> '' then
    Proc(Designer.Form.Name);
  // return names of all components
  for I := 0 to Pred(Designer.Form.ComponentCount) do
    if Designer.Form.Components[I].Name <> '' then
      Proc(Designer.Form.Components[I].Name);
end;

{ TfrmCSRDesigner }

procedure TfrmCSRDesigner.btnAddComponentClick(Sender: TObject);
var
  Node: TTreeNode;
  SC: TSavedComponent;
begin
  SC := CSR.SavedComponents.Add;
  Node := trvCollections.Items.AddChild(nil, SC.DisplayName);
  trvCollections.Selected := Node;
  Node.Data := SC;
  UpdateForSelectedNode;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.btnAddPropertyClick(Sender: TObject);
var
  Node: TTreeNode;
  SP: TSavedProperty;
begin
  if trvCollections.Selected = nil then
    Exit;
  if trvCollections.Selected.Data = nil then
    Exit;
  if not (TObject(trvCollections.Selected.Data) is TSavedComponent) then
    Exit;
  SP := TSavedComponent(trvCollections.Selected.Data).SavedProperties.Add;
  Node :=
    trvCollections.Items.AddChild(trvCollections.Selected, SP.DisplayName);
  Node.Data := SP;
  trvCollections.Selected := Node;
  UpdateForSelectedNode;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.btnOKClick(Sender: TObject);
begin
  ModalResult := mrOK;
end;

procedure TfrmCSRDesigner.btnRemoveClick(Sender: TObject);
begin
  if trvCollections.Selected = nil then
    Exit;
  if trvCollections.Selected.Data = nil then
    Exit;
  if (TObject(trvCollections.Selected.Data) is TSavedComponent) then
  begin
    TSavedComponent(trvCollections.Selected.Data).Collection.Delete(
      TSavedComponent(trvCollections.Selected.Data).Index
      );
    trvCollections.Items.Delete(trvCollections.Selected);
  end;
  if (TObject(trvCollections.Selected.Data) is TSavedProperty) then
  begin
    TSavedProperty(trvCollections.Selected.Data).Collection.Delete(
      TSavedProperty(trvCollections.Selected.Data).Index
      );
    trvCollections.Items.Delete(trvCollections.Selected);
  end;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.cmbComponentChange(Sender: TObject);
begin
  if trvCollections.Selected = nil then
    Exit;
  if trvCollections.Selected.Data = nil then
    Exit;
  if not (TObject(trvCollections.Selected.Data) is TSavedComponent) then
    Exit;
  TSavedComponent(trvCollections.Selected.Data).ComponentName :=
    cmbComponent.Text;
  trvCollections.Selected.Text :=
    TSavedComponent(trvCollections.Selected.Data).DisplayName;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.cmbPropertyNameChange(Sender: TObject);
begin
  if trvCollections.Selected = nil then
    Exit;
  if trvCollections.Selected.Data = nil then
    Exit;
  if not (TObject(trvCollections.Selected.Data) is TSavedProperty) then
    Exit;
  TSavedProperty(trvCollections.Selected.Data).DefaultValue := '';
  TSavedProperty(trvCollections.Selected.Data).PropertyName :=
    cmbPropertyName.Text;
  trvCollections.Selected.Text :=
    TSavedProperty(trvCollections.Selected.Data).DisplayName;
  edtDefaultValue.Text :=
    TSavedProperty(trvCollections.Selected.Data).DefaultValue;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.edtDefaultValueChange(Sender: TObject);
begin
  if trvCollections.Selected = nil then
    Exit;
  if trvCollections.Selected.Data = nil then
    Exit;
  if not (TObject(trvCollections.Selected.Data) is TSavedProperty) then
    Exit;
  TSavedProperty(trvCollections.Selected.Data).DefaultValue :=
    edtDefaultValue.Text;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.edtRegKeyChange(Sender: TObject);
begin
  FCSR.RegistryKey := edtRegKey.Text;
  Designer.Modified;
end;

procedure TfrmCSRDesigner.SetCSR(const Value: TComponentStateRecorder);
var
  I, J: Integer;
  SC: TSavedComponent;
  SP: TSavedProperty;
  SCNode, SPNode: TTreeNode;
begin
  FCSR := Value;
  // load registry key
  edtRegKey.Text := FCSR.RegistryKey;
  trvCollections.Items.Clear;
  // parse all selected components
  for I := 0 to Pred(FCSR.SavedComponents.Count) do
  begin
    SC := FCSR.SavedComponents.Items[I];
    SCNode := trvCollections.Items.AddChild(nil, SC.DisplayName);
    SCNode.Data := SC;
    // parse all selected properties
    for J := 0 to Pred(SC.SavedProperties.Count) do
    begin
      SP := SC.SavedProperties.Items[J];
      SPNode := trvCollections.Items.AddChild(SCNode, SP.DisplayName);
      SPNode.Data := SP;
    end;
  end;
  // select the first item in the list
  if trvCollections.Items.Count > 0 then
    trvCollections.Selected := trvCollections.Items.Item[0];
  if Designer <> nil then
  begin
    // return name of form
    if Designer.Form.Name <> '' then
      cmbComponent.Items.Add(Designer.Form.Name);
    // return names of all components
    for I := 0 to Pred(Designer.Form.ComponentCount) do
      if Designer.Form.Components[I].Name <> '' then
        cmbComponent.Items.Add(Designer.Form.Components[I].Name);
  end;
  // show state of selection
  UpdateForSelectedNode;
end;

type
  TEnableStates = (esComponent, esProperty);
  TEnableStateSet = set of TEnableStates;

procedure TfrmCSRDesigner.SetDesigner(const Value: IFormDesigner);
begin
  FDesigner := Value;
end;

procedure TfrmCSRDesigner.ShowProperties(Name: string);
var
  I, Count: Integer;
  PropInfos: PPropList;
  TmpComponent: TComponent;
begin
  // clear list
  cmbPropertyName.Clear;
  // stop if no component name is provided
  if Name = '' then
    Exit;
  //  get component
  if CSR.Owner.Name = Name then
    TmpComponent := CSR.Owner
  else
    TmpComponent := CSR.Owner.FindComponent(Name);
  // stop if component was not found
  if TmpComponent = nil then
    Exit;
  // determine the property count
  Count := GetPropList(TmpComponent.ClassInfo, [
    tkInteger, tkInt64, tkFloat, tkEnumeration, tkSet, tkChar, tkString,
      tkLString
      ], nil);
  // reserve memory needed for property informations
  GetMem(PropInfos, Count * SizeOf(PPropInfo));
  try
    // load property list
    GetPropList(TmpComponent.ClassInfo, [
      tkInteger, tkInt64, tkFloat, tkEnumeration, tkSet, tkChar, tkString,
        tkLString
        ], PropInfos);
    // save to object inspector list
    for I := 0 to Pred(Count) do
      cmbPropertyName.Items.Add(PropInfos^[I]^.Name);
  finally
    // free resources
    FreeMem(PropInfos);
  end;
end;

procedure TfrmCSRDesigner.trvCollectionsChange(Sender: TObject;
  Node: TTreeNode);
begin
  UpdateForSelectedNode;
end;

procedure TfrmCSRDesigner.UpdateForSelectedNode;
var
  CompName, PropertyName: string;
  EnableStates: TEnableStateSet;
begin
  EnableStates := [];
  Name := '';
  if trvCollections.Selected <> nil then
    if trvCollections.Selected.Data <> nil then
    begin
      if TObject(trvCollections.Selected.Data) is TSavedComponent then
      begin
        cmbComponent.Text :=
          TSavedComponent(trvCollections.Selected.Data).ComponentName;
        EnableStates := EnableStates + [esComponent];
        cmbPropertyName.Text := '';
        edtDefaultValue.Text := '';
        trvCollections.Selected.Text :=
          TSavedComponent(trvCollections.Selected.Data).DisplayName;
        CompName := '';
        PropertyName := '';
      end;
      if TObject(trvCollections.Selected.Data) is TSavedProperty then
      begin
        EnableStates := EnableStates + [esProperty];
        CompName :=
          TSavedProperties(TSavedProperty(
          trvCollections.Selected.Data
          ).Collection).SavedComponent.ComponentName;
        cmbComponent.Text := CompName;
        PropertyName :=
          TSavedProperty(trvCollections.Selected.Data).PropertyName;
        cmbPropertyName.Text := Name;
        edtDefaultValue.Text :=
          TSavedProperty(trvCollections.Selected.Data).DefaultValue;
        trvCollections.Selected.Text :=
          TSavedProperty(trvCollections.Selected.Data).DisplayName;
      end;
    end;
  cmbComponent.Enabled := esComponent in EnableStates;
  lblComponent.Enabled := esComponent in EnableStates;
  btnAddProperty.Enabled := esComponent in EnableStates;
  cmbPropertyName.Enabled := esProperty in EnableStates;
  lblPropertyName.Enabled := esProperty in EnableStates;
  edtDefaultValue.Enabled := esProperty in EnableStates;
  lblDefaultValue.Enabled := esProperty in EnableStates;
  grpProperty.Enabled := esProperty in EnableStates;
  btnRemove.Enabled := EnableStates <> [];
  ShowProperties(CompName);
  cmbPropertyName.Text := PropertyName;
  trvCollections.Update;
end;

end.

Component Download: http://www.geocities.com/wischnewski.geo/articles/d3k/csr/

How to find a string in a file

Problem/Question/Abstract:

I have an array of char called FBuffer1. Let's say: StrCopy(FBuffer1,'Test'). I also have a file, let's say File1.exe. I would like to find a very quick way to be able to localize the string "test" in the file1.exe

Answer:

Solve 1:

One way is to remove the file access problems. Load the whole file into a TMemoryStream, then search the stream. Example:

{ ... }
var
  tmem: TMemoryStream;
  buf: array[1..4] of Char;
begin
  zeromemory(@buf, 4);
  tmem := TMemoryStream.Create;
  tmem.loadfromfile('test1.exe');
  tmem.position := 0;
  while tmem.position <> tmem.size do
  begin
    buf[1] := buf[2];
    buf[2] := buf[3];
    buf[3] := buf[4];
    tmem.read(buf[4], 1);
    if compare(buf, 'hello') then
      Memo1.Lines.Add('match found at position ' + Inttostr(tmem.position));
  end;
  tmem.destroy;
end;


Solve 2:

I was working on just that some time ago. Here is my project file with some alternative functions and a time test. Just paste the following listing into a text file, rename the file to Project1.dpr, open the file in Delphi and run it.

{$APPTYPE CONSOLE}

program Project1;

uses
  Windows, SysUtils;

function ScanString(SourceStart, SourceEnd, Search: PChar; CaseSensitive: Boolean): PChar;
var
  SourcePtr: PChar;
  SourceChr: Char;
  SearchPos: DWord;
  SearchPtr: PChar;
begin
  Result := nil;
  if SourceStart > SourceEnd then
    Exit;
  if not CaseSensitive then
    CharUpperBuff(Search, Length(Search));
  SourcePtr := SourceStart;
  SearchPos := 0;
  SearchPtr := Search;
  while SourcePtr <= SourceEnd do
  begin
    SourceChr := SourcePtr^;
    if not CaseSensitive then
      CharUpperBuff(@SourceChr, 1);
    if SourceChr = SearchPtr^ then
    begin
      Inc(SearchPtr);
      if SearchPtr^ = #0 then
      begin
        Result := SourcePtr - SearchPos;
        Break;
      end;
      Inc(SearchPos);
    end
    else if SearchPos > 0 then
    begin
      SearchPos := 0;
      SearchPtr := Search;
    end;
    Inc(SourcePtr);
  end;
end;

function ScanStringNew(SourceStart, SourceEnd, SearchStr: PChar;
  CaseSensitive: Boolean): PChar;
var
  SourcePtr: PChar;
  ScanLen: DWord;
  ScanPos: DWord;
  ScanStr: PChar;
  ScanPtr: PChar;
  ScanUppStr: PChar;
  ScanUppPtr: PChar;
  ScanLowStr: PChar;
  ScanLowPtr: PChar;
begin
  Result := nil;
  if SourceStart > SourceEnd then
    Exit;
  ScanLen := Length(SearchStr);
  if not CaseSensitive then
  begin
    GetMem(ScanUppStr, ScanLen);
    CopyMemory(ScanUppStr, SearchStr, ScanLen);
    CharUpperBuff(ScanUppStr, ScanLen);
    GetMem(ScanLowStr, ScanLen);
    CopyMemory(ScanLowStr, SearchStr, ScanLen);
    CharLowerBuff(ScanLowStr, ScanLen);
  end
  else
  begin
    ScanUppStr := SearchStr;
    ScanLowStr := SearchStr;
  end;
  ScanPos := 0;
  ScanUppPtr := ScanUppStr;
  ScanLowPtr := ScanLowStr;
  SourcePtr := SourceStart;
  ScanPtr := ScanStr;
  while SourcePtr <= SourceEnd do
  begin
    if (SourcePtr^ = ScanUppPtr^) or (SourcePtr^ = ScanLowPtr^) then
    begin
      Inc(ScanPos);
      if ScanPos = ScanLen then
      begin
        Result := SourcePtr - ScanPos + 1;
        Break;
      end;
      Inc(ScanUppPtr);
      Inc(ScanLowPtr);
    end
    else if ScanPos > 0 then
    begin
      ScanPos := 0;
      ScanUppPtr := ScanUppStr;
      ScanLowPtr := ScanLowStr;
    end;
    Inc(SourcePtr);
  end;
  if not CaseSensitive then
  begin
    FreeMem(ScanUppStr, ScanLen);
    FreeMem(ScanLowStr, ScanLen);
  end;
end;


function ScanStringAsm(SourceStart, SourceEnd, SearchStr: PChar;
  CaseSensitive: Boolean): PChar;
var
  ScanLen: DWord;
  ScanPos: DWord;
  ScanStr: PChar;
  ScanPtr: PChar;
  ScanUppStr: PChar;
  ScanUppPtr: PChar;
  ScanLowStr: PChar;
  ScanLowPtr: PChar;
begin
  if SourceStart > SourceEnd then
    Exit;
  ScanLen := Length(SearchStr);
  if not CaseSensitive then
  begin
    GetMem(ScanUppStr, ScanLen);
    CopyMemory(ScanUppStr, SearchStr, ScanLen);
    CharUpperBuff(ScanUppStr, ScanLen);
    GetMem(ScanLowStr, ScanLen);
    CopyMemory(ScanLowStr, SearchStr, ScanLen);
    CharLowerBuff(ScanLowStr, ScanLen);
  end
  else
  begin
    ScanUppStr := SearchStr;
    ScanLowStr := SearchStr;
  end;
  GetMem(ScanStr, ScanLen * 2 + 2);
  ScanPos := ScanLen;
  ScanPtr := ScanStr;
  ScanUppPtr := ScanUppStr;
  ScanLowPtr := ScanLowStr;
  while ScanPos > 0 do
  begin
    ScanPtr^ := ScanUppPtr^;
    Inc(ScanPtr);
    Inc(ScanUppPtr);
    ScanPtr^ := ScanLowPtr^;
    Inc(ScanPtr);
    Inc(ScanLowPtr);
    Dec(ScanPos);
  end;
  ScanPtr^ := #0;

  asm
      {Register use:
      EDI - pointer to source char
      ESI - pointer to par of scan chars
      AL - current source char
      EBX - match length counter
      ECX - source length counter
      DX - current par of scan chars}

  end;
  


if not CaseSensitive then
begin
FreeMem(ScanUppStr, ScanLen);
  

FreeMem(ScanLowStr, ScanLen);
end;
  

FreeMem(ScanStr, ScanLen * 2 + 2);
  
end;
  

end;

if not CaseSensitive then
begin
  FreeMem(ScanUppStr, ScanLen);

  FreeMem(ScanLowStr, ScanLen);

end;

FreeMem(ScanStr, ScanLen * 2 + 2);

end;


{Preserve registers:}
PUSH EBX {Preserve registers EBX, EDI, ESI:}
PUSH EDI
PUSH ESI
{Initialize registers:}
MOV EDI, SourceStart {Move addr SourceStart to EDI}
MOV ECX, SourceEnd {Calculate source length in ECX:}
SUB ECX, EDI
INC ECX
MOV ESI, ScanStr {Move addr ScanStr to ESI}
MOV DX, WORD[ESI] {Move first par of scan chars to DX}
xor EBX, EBX {Set EBX (match counter) to 0}
@01: {Main test loop:}
MOV AL, BYTE[EDI] {Move current source char to AL}
INC EDI {Inc EDI to point to next source char}
CMP AL, DL {Compare AL with scan char in DL (uppcase)}
JE@10 {Jump to @10 if equal (match)}
CMP AL, DH {Compare AL with scan char in DH (lowcase)}
JE@10 {Jump to @10 if equal (match)}
TEST EBX, EBX {Test EBX (match counter)}
JZ@02 {Jump to @02 if zero (i.e. first scan char)}
SUB ESI, EBX {Move ESI back to start of scan string:}
SUB ESI, EBX
MOV DX, WORD[ESI] {Move first par of scan chars to DX}
xor EBX, EBX {Set EBX to 0}
@02: {Next loop:}
DEC ECX {Dec ECX (source length counter)}
JNZ@01 {Jump back to @01 if not zero}
MOV Result, 0 {Move nil to Result (match not found)}
JMP@99 {Jump to @99}
@10: {Char match found:}
INC EBX {Inc EBX (match length counter):}
ADD ESI, 2 {Move ESI to next par of scan chars:}
MOV DX, WORD[ESI] {Move this par of scan chars to DX}
CMP DL, 0 {Compare char in DL with #0 (end of string)}
JNE@02 {Jump to @02 if not equal (test next char)}
{Match found:}
SUB EDI, EBX {Move EDI back to first char in match}
MOV Result, EDI {Move addr of match to Result}
@99: {Restore registers:}
POP ESI
POP EDI
POP EBX
end;

if not CaseSensitive then
begin
  FreeMem(ScanUppStr, ScanLen);
  FreeMem(ScanLowStr, ScanLen);
end;
FreeMem(ScanStr, ScanLen * 2 + 2);
end;


procedure TimeTest2;
var
  Time1: DWord;
  Time2: DWord;
  Search: string;
  TestName: string;
  TestFile: file;
  TestSize: DWord;
  TestBuff: PChar;
  TestScan: PChar;
  TestPtr: PChar;
  TestPos: Integer;
  HitCount: Integer;
  n, i, j: Integer;
  c: Char;
  Show: Boolean;
begin
  n := 20;
  Show := false;
  Search := 'WINDOWS';

  {TestBuff := PChar(Search);
  TestScan := TestBuff;
  c := TestScan^;
  Time1 := GetTickCount;
  for i := 1 to 10000000 do
  begin
    if TestBuff^ = c then
    begin
    end;
  end;
  Time2 := GetTickCount;
  WriteLn('Tickcount : ', Time2 - Time1);
  Exit;}

  TestName := 'c:\windows\help\getstart.chm';
  AssignFile(TestFile, TestName);
  Reset(TestFile, 1);
  TestSize := FileSize(TestFile);
  GetMem(TestBuff, TestSize);
  BlockRead(TestFile, TestBuff^, TestSize);
  CloseFile(TestFile);

  WriteLn;
  WriteLn('Scaning for "', Search, '"  ', n, ' times');
  WriteLn('in file: ', TestName, '  size: ', TestSize, ' bytes');

  HitCount := 0;
  Time1 := GetTickCount;
  for i := 1 to n do
  begin
    TestScan := TestBuff;
    repeat
      if TestScan <> TestBuff then
        Inc(TestScan, Length(Search));
      TestScan := ScanString(TestScan, TestBuff + TestSize - 1, PChar(Search), false);
      if TestScan <> nil then
      begin
        Inc(HitCount);
        if Show then
        begin
          Write(HitCount, '  ');
          TestPtr := TestScan;
          for TestPos := 1 to Length(Search) do
          begin
            Write(TestPtr^);
            Inc(TestPtr);
          end;
          WriteLn;
          ReadLn;
        end;
      end;
    until TestScan = nil;
  end;
  Time2 := GetTickCount;
  WriteLn('  Tickcount ScanString   : ', Time2 - Time1: 5, 'ms', '  hitcount:', HitCount);
  HitCount := 0;
  Time1 := GetTickCount;
  for i := 1 to n do
  begin
    TestScan := TestBuff;
    repeat
      if TestScan <> TestBuff then
        Inc(TestScan, Length(Search));
      TestScan := ScanStringNew(TestScan, TestBuff + TestSize - 1, PChar(Search), false);
      if TestScan <> nil then
      begin
        Inc(HitCount);
        if Show then
        begin
          Write(HitCount, '  ');
          TestPtr := TestScan;
          for TestPos := 1 to Length(Search) do
          begin
            Write(TestPtr^);
            Inc(TestPtr);
          end;
          WriteLn;
          ReadLn;
        end;
      end;
    until TestScan = nil;
  end;
  Time2 := GetTickCount;
  WriteLn('  Tickcount ScanStringNew: ', Time2 - Time1: 5, 'ms', '  hitcount:', HitCount);
  HitCount := 0;
  Time1 := GetTickCount;
  for i := 1 to n do
  begin
    TestScan := TestBuff;
    repeat
      if TestScan <> TestBuff then
        Inc(TestScan, Length(Search));
      TestScan := ScanStringAsm(TestScan, TestBuff + TestSize - 1, PChar(Search), false);
      if TestScan <> nil then
      begin
        Inc(HitCount);
        if Show then
        begin
          Write(HitCount, '  ');
          TestPtr := TestScan;
          for TestPos := 1 to Length(Search) do
          begin
            Write(TestPtr^);
            Inc(TestPtr);
          end;
          WriteLn;
          ReadLn;
        end;
      end;
    until TestScan = nil;
  end;
  Time2 := GetTickCount;
  WriteLn('  Tickcount ScanStringAsm: ', Time2 - Time1: 5, 'ms', '  hitcount:', HitCount);
  FreeMem(TestBuff, TestSize);
end;

begin
  TimeTest2;
  WriteLn;
  WriteLn('** press enter to close **');
  ReadLn;
end.


Solve 3:

function ScanFile(const filename: string; const forString: string; caseSensitive: Boolean): LongInt;
{ returns position of string in file or -1, if not found }
const
  BufferSize = $8001; { 32K + 1 bytes }
var
  pBuf, pEnd, pScan, pPos: Pchar;
  filesize: LongInt;
  bytesRemaining: LongInt;
  bytesToRead: Integer;
  F: file;
  SearchFor: Pchar;
  oldMode: Word;
begin
  Result := -1; { assume failure }
  if (Length(forString) = 0) or (Length(filename) = 0) then
    Exit;
  SearchFor := nil;
  pBuf := nil;
  { open file as binary, 1 byte recordsize }
  AssignFile(F, filename);
  oldMode := FileMode;
  FileMode := 0; { read-only access }
  Reset(F, 1);
  FileMode := oldMode;
  try { allocate memory for buffer and pchar search string }
    SearchFor := StrAlloc(Length(forString) + 1);
    StrPCopy(SearchFor, forString);
    if not caseSensitive then { convert to upper case }
      AnsiUpper(SearchFor);
    GetMem(pBuf, BufferSize);
    filesize := System.Filesize(F);
    bytesRemaining := filesize;
    pPos := nil;
    while bytesRemaining > 0 do
    begin
      { calc how many bytes to read this round }
      if bytesRemaining >= BufferSize then
        bytesToRead := Pred(BufferSize)
      else
        bytesToRead := bytesRemaining;
      { read a buffer full and zero-terminate the buffer }
      BlockRead(F, pBuf^, bytesToRead, bytesToRead);
      pEnd := @pBuf[bytesToRead];
      pEnd^ := #0;
      { scan the buffer. Problem: buffer may contain #0 chars! So we treat it as
      a concatenation of zero-terminated strings. }
      pScan := pBuf;
      while pScan < pEnd do
      begin
        if not caseSensitive then { convert to upper case }
          AnsiUpper(pScan);
        pPos := StrPos(pScan, SearchFor); { search for substring }
        if pPos <> nil then
        begin { Found it! }
          Result := FileSize - bytesRemaining + LongInt(pPos) - LongInt(pBuf);
          Break;
        end;
        pScan := StrEnd(pScan);
        Inc(pScan);
      end;
      if pPos <> nil then
        Break;
      bytesRemaining := bytesRemaining - bytesToRead;
      if bytesRemaining > 0 then
      begin
        { no luck in this buffers load. We need to handle the case of the search
        string spanning two chunks of file now. We simply go back a bit in the file
        and read from there, thus inspecting some characters twice }
        Seek(F, FilePos(F) - Length(forString));
        bytesRemaining := bytesRemaining + Length(forString);
      end;
    end;
  finally
    CloseFile(F);
    if SearchFor <> nil then
      StrDispose(SearchFor);
    if pBuf <> nil then
      FreeMem(pBuf, BufferSize);
  end;
end;


Solve 4:

One option is to just read the entire file into a single string. The old-fashioned way is to use BlockRead. You could also use a file stream. Once you have it in a single string you can use any normal string operations, even if there are embedded null bytes or CR/LF's.

procedure TForm1.Button1Click(Sender: TObject);
var
  s: string;
  f: file;
  p: integer;
begin
  AssignFile(f, 'c:\winnt\system32\mspaint.exe');
  FileMode := 0;
  Reset(f, 1);
  SetLength(s, FileSize(f));
  BlockRead(f, s[1], FileSize(f));
  CloseFile(f);
  p := pos('This program cannot be run in DOS mode', s);
  Label1.Caption := 'Found at : ' + IntToStr(p);
end;

Creating a simple Icon Handler for the Windows Explorer

Problem/Question/Abstract:

Some of you might have wondered how automatically every Icon file automatically displays its own icon in the windows explorer. Especially some design and paint applications use this possibility to show the content of a file rather than the same icon for all of them.

Answer:

Getting across the point

This article shows you how to create a simple icon handler for windows text (*.txt) files that will display the first characters rather than the default icon.


Default view


Text icons using Icon Handler

The sample given here will only show you the outline of such a project, but this should be sufficient to get you started on your journey. The Icon handler will create large icons only, so the explorer will shrink them rather ugly. However, it is rather simple to extend the functionality.

Getting started

We'll have to create an in-process server DLL that will export the interfaces IExtractIcon and IPersistFile. Most of the methods we need to declare do not need to be actually implemented, because they are never used. We will simply return E_NOTIMPL for these methods. All we have to do is to provide handling for three of the methods.

Load

The Windows Explorer will pass along the file name of the file we have to create the icon for. We'll simple save the name in a variable.

GetIconLocation

We'll tell the Windows Explorer that it must call yet another procedure, because we must create the icon from scratch. Further we set some flags for caching and similar handling.

Extract

That's were we actually create the Icon. First we extract the desired size of the icon. Next, we create the bitmaps for the AND mask and the XOR mask. On the XOR mask we will write up to the first 3 lines of text from the text file. This does not really give a preview, however it shows the point for custom icons.

Last we are going to tell windows to create the icon desired and return it to the explorer. And we are done.

Registering the Icon Handler

First we will have to access the Registry. Assuming that your Text files will point to the entry HKCR\txtfile we will first back-up the old icon handler (key: DefaultIcon) and then set the new one. Further we register the IconHandler (Key: ShellEx\IconHandler). That's it.

To simplify the task of registering/deregistering the icon handler I have created a new class that is derived from TTypedComObjectFactory. There I'll simple override the method UpdateRegistry and we are done.

You can either register the DLL directly from Delphi or simply use Windows RegSvr32 utility.

Create your project

Create a new ACTIVE X library, add a type library to it and create a COM Object and name it TxtIcon. Finally paste the code below into the TxtIcon unit and compile it.

Note: You may have to restart the computer (or the Windows Explorer using the Task Manager) to see the changes take effect.

You can simply download the code using this link.

THE CODE

unit TxtIcon;

interface

uses
  Windows, ActiveX, Classes, ComObj, TxtViewer_TLB, StdVcl, ShlObj;

type
  TTxtIcon = class(TTypedComObject, ITxtIcon, IExtractIcon, IPersistFile)
  private
    FCurrFile: WideString;
  protected
    {Declare ITxtIcon methods here}
    // IExtractIcon
    function GetIconLocation(uFlags: UINT; szIconFile: PAnsiChar; cchMax: UINT;
      out piIndex: Integer; out pwFlags: UINT): HResult; stdcall;
    function Extract(pszFile: PAnsiChar; nIconIndex: UINT;
      out phiconLarge, phiconSmall: HICON; nIconSize: UINT): HResult; stdcall;
    // IPersist
    function GetClassID(out classID: TCLSID): HResult; stdcall;
    // IPersistFile
    function IsDirty: HResult; stdcall;
    function Load(pszFileName: POleStr; dwMode: Longint): HResult;
      stdcall;
    function Save(pszFileName: POleStr; fRemember: BOOL): HResult;
      stdcall;
    function SaveCompleted(pszFileName: POleStr): HResult;
      stdcall;
    function GetCurFile(out pszFileName: POleStr): HResult;
      stdcall;
  end;

  TIconHandlerFactory = class(TTypedComObjectFactory)
  protected
  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;

implementation

uses
  SysUtils, ComServ, Graphics, Registry;

{ TTxtIcon }

function TTxtIcon.Extract(pszFile: PAnsiChar; nIconIndex: UINT;
  out phiconLarge, phiconSmall: HICON; nIconSize: UINT): HResult;
var
  IconSize, I: Integer;
  MaskAnd, MaskXor: TBitmap;
  IconInfo: TIconInfo;
  SL: TStringList;
begin
  // draw the large icon
  IconSize := Lo(nIconSize);

  // create and prepare AND mask
  MaskAnd := TBitmap.Create;
  try
    MaskAnd.Monochrome := true;
    MaskAnd.Width := IconSize;
    MaskAnd.Height := IconSize;

    MaskAnd.Canvas.Brush.Color := clBlack;
    MaskAnd.Canvas.FillRect(Rect(0, 0, IconSize, IconSize));

    // create and prepare XOR mask

    MaskXor := TBitmap.Create;
    try
      MaskXor.Width := IconSize;
      MaskXor.Height := IconSize;

      MaskXor.Canvas.Brush.Color := clWhite;
      MaskXor.Canvas.FillRect(Rect(0, 0, IconSize, IconSize));
      MaskXor.Canvas.Font.Color := clNavy;

      // load file
      SL := TStringList.Create;
      try
        try
          SL.LoadFromFile(FCurrFile);
          I := 0;
          // paint up to three lines of text onto the canvas
          while (I < SL.Count) and (I < 3) do
          begin
            MaskXor.Canvas.TextOut(0, I * 15, SL.Strings[I]);
            Inc(I);
          end;
        except
          // user may not have access rights
          MaskXor.Canvas.TextOut(0, 0, '???');
        end;
      finally SL.Free;
      end;

      // create icon for explorer
      IconInfo.fIcon := true;
      IconInfo.xHotspot := 0;
      IconInfo.yHotspot := 0;
      IconInfo.hbmMask := MaskAnd.Handle;
      IconInfo.hbmColor := MaskXor.Handle;
      // return large icon
      phiconLarge := CreateIconIndirect(IconInfo);
      // signal success
      Result := S_OK;

    finally MaskAnd.Free;
    end;
  finally MaskXor.Free;
  end;
end;

function TTxtIcon.GetClassID(out classID: TCLSID): HResult;
begin
  classID := CLASS_TxtIcon;
  Result := S_OK;
end;

function TTxtIcon.GetCurFile(out pszFileName: POleStr): HResult;
begin
  Result := E_NOTIMPL;
end;

function TTxtIcon.GetIconLocation(uFlags: UINT; szIconFile: PAnsiChar;
  cchMax: UINT; out piIndex: Integer; out pwFlags: UINT): HResult;
begin
  piIndex := 0;
  pwFlags := GIL_DONTCACHE or GIL_NOTFILENAME or GIL_PERINSTANCE;
  Result := S_OK;
end;

function TTxtIcon.IsDirty: HResult;
begin
  Result := E_NOTIMPL;
end;

function TTxtIcon.Load(pszFileName: POleStr; dwMode: Integer): HResult;
begin
  FCurrFile := pszFileName;
  Result := S_OK;
end;

function TTxtIcon.Save(pszFileName: POleStr; fRemember: BOOL): HResult;
begin
  Result := E_NOTIMPL;
end;

function TTxtIcon.SaveCompleted(pszFileName: POleStr): HResult;
begin
  Result := E_NOTIMPL;
end;

{ TIconHandlerFactory }

procedure TIconHandlerFactory.UpdateRegistry(Register: Boolean);
var
  ClsID: string;
begin
  ClsID := GUIDToString(ClassID);
  inherited UpdateRegistry(Register);
  if Register then
  begin
    with TRegistry.Create do
    try
      RootKey := HKEY_CLASSES_ROOT;
      if OpenKey('txtfile\DefaultIcon', True) then
      try
        WriteString('backup', ReadString(''));
        WriteString('', '%1');
      finally
        CloseKey;
      end;
      if OpenKey('txtfile\shellex\IconHandler', True) then
      try
        WriteString('', ClsID);
      finally
        CloseKey;
      end;
    finally
      Free;
    end;
  end
  else
  begin
    with TRegistry.Create do
    try
      RootKey := HKEY_CLASSES_ROOT;
      if OpenKey('txtfile\DefaultIcon', True) then
      try
        if ValueExists('backup') then
        begin
          WriteString('', ReadString('backup'));
          DeleteValue('backup');
        end;
      finally
        CloseKey;
      end;
      if OpenKey('txtfile\shellex', True) then
      try
        if KeyExists('IconHandler') then
          DeleteKey('IconHandler');
      finally
        CloseKey;
      end;
    finally
      Free;
    end;
  end;
end;

initialization
  TIconHandlerFactory.Create(
    ComServer, TTxtIcon, Class_TxtIcon, ciMultiInstance, tmApartment
    );
end.


Component Download: http://www.gatenetwork.com/delphi-samples/iconhandler.zip

Adding a Custom Button to the Caption Bar with System Menu and Hint

Problem/Question/Abstract:

How to add a custom button to the caption bar with a System Menu and HINT!!!!

Answer:

That code can create a button to the caption bar, create a MenuItem in System menu and create a Hint to the button!
Just put the code above in your Unit and change the "FrmMainForm" to your Form name, and other small things like Text of Hint

private
{ Private declarations }

procedure WMNCPAINT(var msg: Tmessage); message WM_NCPAINT;
procedure WMNCACTIVATE(var msg: Tmessage); message WM_NCACTIVATE;
procedure WMNCMOUSEDOWN(var msg: Tmessage); message WM_NCLBUTTONDOWN;
procedure WMNCMOUSEMOVE(var Msg: TMessage); message WM_NCMOUSEMOVE;
procedure WMMOUSEMOVE(var Msg: TMessage); message WM_MOUSEMOVE;
procedure WMLBUTTONUP(var msg: Tmessage); message WM_LBUTTONUP;
procedure WNCLBUTTONDBLCLICK(var msg: Tmessage); message
  WM_NCLBUTTONDBLCLK;
procedure WMNCRBUTTONDOWN(var msg: Tmessage); message WM_NCRBUTTONDOWN;
procedure WMNCHITTEST(var msg: Tmessage); message WM_NCHITTEST;
procedure WMSYSCOMMAND(var msg: Tmessage); message WM_SYSCOMMAND;

{...}

var
  {...}
  Pressed: Boolean;
  FocusLost: Boolean;
  Rec: TRect;
  NovoMenuHandle: THandle;
  PT1: TPoint;
  FHintshow: Boolean;
  FHint: THintWindow;
  FHintText: string;
  FHintWidth: Integer;

  {...}

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

procedure TFrmMainForm.WMSYSCOMMAND(var Msg: TMessage);
begin
  if Msg.WParam = LongInt(NovoMenuHandle) then
    //*********************************************
    //The button was clicked! Put you function here
    //*********************************************
    inherited;
end;

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

procedure TFrmMainForm.WMNCHITTEST(var Msg: TMessage);
var
  Tmp: Boolean;
begin
  if Pressed then
  begin
    Tmp := FocusLost;
    PT1.X := Msg.LParamLo - FrmMainForm.Left;
    PT1.Y := Msg.LParamHi - FrmMainForm.Top;
    if PTInRect(Rec, PT1) then
      FocusLost := False
    else
      FocusLost := True;
    if FocusLost <> Tmp then
      InvalidateRect(FrmMainForm.Handle, @Rec, True);
  end;
  inherited;
end;

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

procedure TFrmMainForm.WMLBUTTONUP(var Msg: TMessage);
var
  Tmp: Boolean;
begin
  ReleaseCapture;
  Tmp := Pressed;
  Pressed := False;
  if Tmp and PTInRect(Rec, PT1) then
  begin
    InvalidateRect(FrmMainForm.Handle, @Rec, True);
    FHintShow := False;
    FHint.ReleaseHandle;
    //*********************************************
    //The button was clicked! Put you function here
    //*********************************************
  end
  else
    inherited;
end;

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

procedure TFrmMainForm.WNCLBUTTONDBLCLICK(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top;
  if not PTInRect(Rec, PT1) then
    inherited;
end;

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

procedure TFrmMainForm.WMNCRBUTTONDOWN(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top;
  if not PTInRect(Rec, PT1) then
    inherited;
end;

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

procedure TFrmMainForm.WMNCMOUSEDOWN(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top;
  FHintShow := False;
  if PTInRect(Rec, PT1) then
  begin
    Pressed := True;
    FocusLost := False;
    InvalidateRect(FrmMainForm.Handle, @Rec, True);
    SetCapture(TWinControl(FrmMainForm).Handle);
  end
  else
  begin
    FrmMainForm.Paint;
    inherited;
  end;
end;

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

//That function Create a Hint

procedure TFrmMainForm.WMNCMOUSEMOVE(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top;
  if PTInRect(Rec, PT1) then
  begin
    FHintWidth := FHint.Canvas.TextWidth(FHintText);
    if (FHintShow = False) and (Length(Trim(FHintText)) <> 0) then
      FHint.ActivateHint(
        Rect(
        Mouse.CursorPos.X,
        Mouse.CursorPos.Y + 20,
        Mouse.CursorPos.X + FHintWidth + 10,
        Mouse.CursorPos.Y + 35
        ),
        FHintText
        );
    FHintShow := True;
  end
  else
  begin
    FHintShow := False;
    FHint.ReleaseHandle;
  end;
end;

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

procedure TFrmMainForm.WMMOUSEMOVE(var Msg: TMessage);
begin
  FHintShow := False;
  FHint.ReleaseHandle;
end;

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

procedure TFrmMainForm.WMNCACTIVATE(var Msg: TMessage);
begin
  InvalidateRect(FrmMainForm.Handle, @Rec, True);
  inherited;
end;

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

procedure TFrmMainForm.WMNCPAINT(var Msg: TMessage);
begin
  InvalidateRect(FrmMainForm.Handle, @Rec, True);
  inherited;
end;

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

procedure TFrmMainForm.FormPaint(Sender: TObject);
var
  Border3D_Y, Border_Thickness, Btn_Width,
    Button_Width, Button_Height: Integer;
  MyCanvas: TCanvas;
begin
  MyCanvas := TCanvas.Create;
  MyCanvas.Handle := GetWindowDC(FrmMainForm.Handle);
  Border3D_Y := GetSystemMetrics(SM_CYEDGE);
  Border_Thickness := GetSystemMetrics(SM_CYSIZEFRAME);
  Button_Width := GetSystemMetrics(SM_CXSIZE);
  Button_Height := GetSystemMetrics(SM_CYSIZE);

  //It make a square button, but if you want a different button
  //just change that var to your width.
  Btn_Width := Border3D_Y + Border_Thickness + Button_Height - (2
    * Border3D_Y) - 1;

  Rec.Left := FrmMainForm.Width - (3 * Button_Width + Btn_Width);
  Rec.Right := FrmMainForm.Width - (3 * Button_Width + 03);
  Rec.Top := Border3D_Y + Border_Thickness - 1;
  Rec.Bottom := Rec.Top + Button_Height - (2 * Border3D_Y);
  FillRect(MyCanvas.Handle, Rec, HBRUSH(COLOR_BTNFACE + 1));
  if not Pressed or Focuslost then
    DrawEdge(MyCanvas.Handle, Rec, EDGE_RAISED, BF_SOFT or BF_RECT)
  else if Pressed and not Focuslost then
    DrawEdge(MyCanvas.Handle, Rec, EDGE_SUNKEN, BF_SOFT or
      BF_RECT);

  //It draw a the application icon to the button. Easy to change.
  DrawIconEX(MyCanvas.Handle, Rec.Left + 4, Rec.Top + 3,
    Application.Icon.Handle, 8, 8, 0, 0, DI_NORMAL);

  MyCanvas.Free;
end;

{... }

procedure TFrmMainForm.FormCreate(Sender: TObject);

{... }

InsertMenu(GetSystemMenu(Handle, False), 4, MF_BYPOSITION +
  MF_STRING, NovoMenuHandle, pchar('TEXT OF THE MENU'));
Rec := Rect(0, 0, 0, 0);
FHintText := 'Put the text of your Hint HERE';
FHint := THintWindow.Create(Self);
FHint.Color := clInfoBk;
//You can change the background color of the Hint