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

How to create a wipe effect using regions

Problem/Question/Abstract:

How to create a wipe effect using regions

Answer:

This wipes anti-clockwise:


unit ClockWipe;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls;

type
  TPkt = array[0..361] of TPoint;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Image2: TImage;
    Button1: TButton;
    procedure FormPaint(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    procedure ClockWipe(re: TRect; Bmp: TBitmap);
    procedure SetPolygonRegion(Pkt: TPkt; PktCount: Integer; Bmp: TBitmap);
    function GetArcPoint(cPoint: TPoint; radius, winkel: Integer): TPoint;
  public
    { Public Declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Canvas.Draw(0, 0, Image1.Picture.Bitmap);
  ClockWipe(Image2.Picture.Bitmap.Canvas.ClipRect, Image2.Picture.Bitmap);
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  Canvas.Draw(0, 0, Image1.Picture.Bitmap);
end;

procedure TForm1.ClockWipe(re: TRect; Bmp: TBitmap);
var
  radius, winkel, cv: Integer;
  cP: TPoint;
  Pkt: TPkt;
begin
  radius := Round(Sqrt(Sqr((re.right - re.left) div 2) + Sqr((re.bottom - re.top) div 2)));
  cP := Point((re.right - re.left) div 2, (re.bottom - re.top) div 2);
  Pkt[0] := cP;
  for winkel := 0 to 360 do
    Pkt[winkel + 1] := GetArcPoint(cP, radius, winkel + 90);
  for cv := 0 to 361 do
    if (cv - 1) / 20 = (cv - 1) div 20 then
    begin
      Sleep(50);
      SetPolygonRegion(Pkt, cv + 1, Image2.Picture.Bitmap);
    end;
end;

procedure TForm1.SetPolygonRegion(Pkt: TPkt; PktCount: Integer; Bmp: TBitmap);
var
  Region: HRGN;
begin
  Region := CreatePolygonRGN(Pkt, PktCount, WINDING);
  if Region <> 0 then
  begin
    SelectClipRgn(Canvas.handle, Region);
    Canvas.Draw(0, 0, Bmp);
    SelectClipRgn(Canvas.handle, 0);
    DeleteObject(Region);
  end;
end;

function TForm1.GetArcPoint(cPoint: TPoint; radius, winkel: Integer): TPoint;
begin
  result.x := Round(cPoint.x + radius * Cos(winkel * 2 * pi / 360));
  result.y := Round(cPoint.y - radius * Sin(winkel * 2 * pi / 360));
end;

end.

How to change the screen resolution programmatically

Problem/Question/Abstract:

How to change the screen resolution programmatically

Answer:

Solve 1:

To change the screen resolution on a user's PC is bad programming style, but anyway:

{ ... }
type
  TDisplaySetting = record
    dsWidth, dsHeight, dsBPP: Cardinal {DWORD};
  end;
  { ... }

function ChangeDisplayMode(var Settings: TDisplaySetting): Boolean;
var
  I: Integer;
  DC: HDC;
  DevMode: TDevMode;
  Current: TDisplaySetting;
begin
  Result := FALSE;
  { Enumerate available display modes }
  I := 0;
  while EnumDisplaySettings(nil, I, DevMode) do
  begin
    { Check if this is desired settings }
    if (DevMode.dmPelsWidth = Settings.dsWidth) and (DevMode.dmPelsHeight =
      Settings.dsHeight)
      and (DevMode.dmBitsPerPel = Settings.dsBPP) then
    begin
      { Get Current Display Settings }
      DC := GetDC(0);
      with Current do
      begin
        dsWidth := GetDeviceCaps(DC, HORZRES);
        dsHeight := GetDeviceCaps(DC, VERTRES);
        dsBPP := GetDeviceCaps(DC, BITSPIXEL);
      end;
      ReleaseDC(0, DC);
      { Indicate what settings to change }
      DevMode.dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
      { Try to change settings }
      if ChangeDisplaySettings(DevMode, 0) = DISP_CHANGE_SUCCESSFUL then
      begin
        Result := TRUE;
        { Return previous settings if successful }
        Settings := Current;
      end;
      Break;
    end;
    Inc(I);
  end;
end;

Used like this:

var
  DS: TDisplaySettings;
begin
  DS.dsWidth := 800;
  DS.dsHeight := 600;
  DS.dsBPP := 24;
  { Change display mode }
  if ChangeDisplayMode(DS) then
  begin
    { DS now stores previous settings }
    { ... }
    { Restore original settings }
    ChangeDisplayMode(DS);
  end;
end;


Solve 2:

Here's a method I built to force 1024x768:

function SetDisplay1024x768: Boolean;
var
  DevMode: TDeviceMode;
begin
  EnumDisplaySettings(nil, 0, DevMode);
  DevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
  DevMode.dmPelsWidth := 1024;
  DevMode.dmPelsHeight := 768;
  Result := ChangeDisplaySettings(DevMode, CDS_UPDATEREGISTRY)
    = DISP_CHANGE_SUCCESSFUL;
end;


Answer 3:

function ChangeRes(X, Y, Frequency, ColorDepth: Cardinal): boolean;
var
  RetCode: Integer;
  MyDevMode: TDeviceMode;
begin
  EnumDisplaySettings(nil, 0, MyDevMode);
  MyDevMode.dmDisplayFrequency := Frequency;
  MyDevMode.dmPelsWidth := X;
  MyDevMode.dmPelsHeight := Y;
  MyDevMode.dmBitsPerPel := ColorDepth;
  MyDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL
    or DM_DISPLAYFREQUENCY;
  RetCode := ChangeDisplaySettings(MyDevMode, CDS_UPDATEREGISTRY);
  case RetCode of
    DISP_CHANGE_SUCCESSFUL, DISP_CHANGE_RESTART: Result := true;
  else
    Result := false;
  end;
  case RetCode of
    DISP_CHANGE_SUCCESSFUL:
      Writeln('DISP_CHANGE_SUCCESSFUL');
    DISP_CHANGE_RESTART:
      Writeln('DISP_CHANGE_RESTART');
    DISP_CHANGE_FAILED:
      Writeln('DISP_CHANGE_FAILED');
    DISP_CHANGE_BADMODE:
      Writeln('DISP_CHANGE_BADMODE');
    DISP_CHANGE_NOTUPDATED:
      Writeln('DISP_CHANGE_NOTUPDATED');
    DISP_CHANGE_BADFLAGS:
      Writeln('DISP_CHANGE_BADFLAGS');
    DISP_CHANGE_BADPARAM:
      Writeln('DISP_CHANGE_BADPARAM');
  else
    Writeln('DISP_CHANGE_OTHER_ERROR');
  end;
end;

Add a drop shadow to your app under XP

Problem/Question/Abstract:

Add a drop shadow to your app under XP

Answer:

Heres a nice way of adding a drop shadow to your application under Windows XP.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
  private
    { Private declarations }
  public
    { Public declarations }
  protected
    procedure CreateParams(var Params: TCreateParams); override; // Important !
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{------------------------------------------------------------}
// Here we check of the user is running Windows XP

function IsWinXP: Boolean;
begin
  Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and
    (Win32MajorVersion >= 5) and (Win32MinorVersion >= 1);
end;
{------------------------------------------------------------}

{------------------------------------------------------------}
// Check if it is Windows XP if all is OK then create the drop shadow

procedure TForm1.CreateParams(var Params: TCreateParams);
const
  CS_DROPSHADOW = $00020000;
begin
  inherited;
  if IsWinXP then
    Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW
  else
end;
{------------------------------------------------------------}

end.

This code also checks if it is running under Windows XP, if it is you get the drop shadow if not it does nothing.

Move a menu bar outside the visible screen

Problem/Question/Abstract:

Is there a way of hiding a TMainMenu?

Answer:

Yes, do not hide it. What you do is leave it visible (as well as caption bar and border) and then just size the whole window so that only the client area is visible, all the nonclient area, including the menu bar, simply lies outside the visible screen. The alternative is to use a toolbar menu instead of a standard menu bar.

{ ... }
private {in form declaration}

procedure WMGetMinMaxInfo(var msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;
{ ... }

procedure TForm1.WMGetMinMaxInfo(var msg: TWMGetMinMaxInfo);
begin
  inherited;
  with msg.MinMaxInfo^.ptMaxTrackSize do
  begin
    X := GetDeviceCaps(Canvas.handle, HORZRES) + (Width - ClientWidth);
    Y := GetDeviceCaps(Canvas.handle, VERTRES) + (Height - ClientHeight);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
const
  Rect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0);
  FullScreen: Boolean = False;
begin
  FullScreen := not FullScreen;
  if FullScreen then
  begin
    Rect := BoundsRect;
    SetBounds(Left - ClientOrigin.X, Top - ClientOrigin.Y,
      GetDeviceCaps(Canvas.handle, HORZRES) + (Width - ClientWidth),
      GetDeviceCaps(Canvas.handle, VERTRES) + (Height - ClientHeight));
    { Label2.caption := IntToStr(GetDeviceCaps(Canvas.handle, VERTRES)); }
  end
  else
    BoundsRect := Rect;
end;

Check if a console application is running in full screen mode

Problem/Question/Abstract:

I made a console application that at some point needs to know if it's running in a window or in full screen mode. I looked at Console API calls, but cannot find anything distinctive.

Answer:

The function IsConsoleFullscreen() works fine with W98 and ME, but not with 2000 (and XP, I presume). The GetConsoleDisplayMode function is also in Win2000 (not documented), at least with service pack 1 and up. To get the test to work on both series of platforms, you have to use LoadLibrary and GetProcAddress:

function IsConsoleFullscreen: Boolean;
type
  TGetConsoleDisplayMode = function(var lpdwMode: DWORD): Boolean; stdcall;
var
  Handle: THandle;
  DisplayMode: TGetConsoleDisplayMode;
  W: HWND;
  PID: Cardinal;
  R: TRect;
  CurMode: DWORD;
  PlatFormXP2000: Boolean;
begin
  Result := False;
  PlatFormXP2000 := False;
  Handle := LoadLibrary('kernel32.dll');
  if Handle <> 0 then
  begin
    @DisplayMode := GetProcAddress(Handle, 'GetConsoleDisplayMode');
    if @DisplayMode <> nil then
    begin
      PlatFormXP2000 := DisplayMode(CurMode);
      if PlatFormXP2000 then
        Result := (CurMode <> 0);
    end;
    FreeLibrary(Handle);
  end;
  if not PlatFormXP2000 then
  begin
    W := GetForegroundWindow;
    GetWindowThreadProcessId(W, @PID);
    if PID <> GetCurrentProcessID then
      exit;
    if not IsIconic(W) then
      exit;
    GetClientRect(W, R);
    Result := (R.Right = 0) and (R.Bottom = 0);
  end;
end;

How to develop a Control Panel applet

Problem/Question/Abstract:

I want to develop an own Application for Win9x Control Panel. First I thought I just have to rename an *.exe File to *.cpl, but that doesn't work. Now I heard, *.cpl files are Dynamic Link Libraries. So, which functions do I have to implement into my DLL interface?

Answer:

Creating a Control Panel Applet is a straight forward process. Simply create a Dynamic Link Library with the extension of .cpl (Control Panel Library) and place it in the Windows system directory. Each cpl file can support multiple control panel applets. The cpl will have a single function entry point called CPlApplet() that must be exported by name. All the following control panel messages will come through this single entry point:

Message:

CPL_INIT
Sent to indicate CPlApplet() was found. Return TRUE to continue the loading process.

CPL_GETCOUNT
Return the number of applets supported by the cpl.

CPL_INQUIRE
Sent for information about each applet supported by the cpl.lParam1 contains the zero based applet number for the inquiry. lParam2 points to a TCplInfo structure. The idIcon field of the TClpInfo structure should be initialized with the resource id for an icon to display, and the idName and idInfo fields should be initialized with the resource string id for the name and description string id.lData can contain applet defined data for use by the applet.

CPL_SELECT
Sent when the applet's icon has been selected by the user. lParam1 contains the applet number that was selected. lParam2 contains the applet's user defined lData value.

CPL_DBLCLK
Sent when the applet's icon has been double-clicked. lParam1 contains the applet number. lParam2 contains the applet's user defined lData value. This message initiates the display of the applet's dialog box.

CPL_STOP
Sent for each applet when the control panel is exiting. lParam1 contains the applet number. lParam2 contains the applet's user defined lData value. Any applet specific cleaning up should be performed during this call.

CPL_EXIT
Sent prior to the control panel call to FreeLibrary. Non-applet specific cleaning up should be performed during this call.

CPL_NEWINQUIRE
Same as CPL_INQUIRE except lParam2 is a pointer to a NEWCPLINFO structure.


Your control panel library will need some additional resources to function. You will need to create a resource file containing a string table containing both the name and description of your applet(s) and icons for each applet in your cpl. You can create a res file from a .rc (resource script file) using the BRCC.EXE or BRCC32.EXE command line resource compiler, or a WYSIWYG resource editor like Borland's Resource Workshop.

Example .rc file containing a string table with two strings and a pointer to a icon file resource:

STRINGTABLE
{
1, "TestApplet"
2, "My Test Applet"
}
2 ICON C:\SOMEPATH\CHIP.ICO

To compile the .rc file to a .res file that can be linked with your application, simply type on the dos command line the full path to the resource compiler, and the full path to the name of the .rc file to compile. Here is an example:

c:\Delphi\Bin\brcc32.exe c:\Delphi\MyRes.rc

When the compiler is finished, you should have a new file with the same name as the .rc file you've compiled, only with an extension of ".res".

If you are developing for multiple platforms, you should create both a 16 and 32 bit res file for linkage with your application.

The following is an example of a control panel applet that executes a secondary executable in response to the CPL_DBLCLK message. You can adapt the code to show a form or dialog box as well. The example is coded to compile for Win16 and Win32 environments.

To build the project, you will need to compile the above .rc file to a res file named either: TCPL32.RES or TCPL16.RES.

library TestCpl;

{$IFDEF WIN32}
uses
  SysUtils, Windows, Messages;

{$ELSE}

uses
  SysUtils, WinTypes, WinProcs, Messages;

{$ENDIF}
{$IFDEF WIN32}
{$R TCPL32.RES}
{$ELSE}
{$R TCPL16.RES}
{$ENDIF}

const
  NUM_APPLETS = 1;

{$IFDEF WIN32}
const
  CPL_DYNAMIC_RES = 0;
{$ENDIF}
const
  CPL_INIT = 1;
const
  CPL_GETCOUNT = 2;
const
  CPL_INQUIRE = 3;
const
  CPL_SELECT = 4;
const
  CPL_DBLCLK = 5;
const
  CPL_STOP = 6;
const
  CPL_EXIT = 7;
const
  CPL_NEWINQUIRE = 8;
{$IFDEF WIN32}
const
  CPL_STARTWPARMS = 9;
{$ENDIF}
const
  CPL_SETUP = 200;

{$IFNDEF WIN32}
type
  DWORD = LongInt;
{$ENDIF}

type
  TCplInfo = record
    idIcon: integer;
    idName: integer;
    idInfo: integer;
    lData: LongInt;
  end;
  PCplInfo = ^TCplInfo;

type
  TNewCplInfoA = record
    dwSize: DWORD;
    dwFlags: DWORD;
    dwHelpContext: DWORD;
    lData: LongInt;
    IconH: HIcon;
    szName: array[0..31] of char;
    szInfo: array[0..63] of char;
    szHelpFile: array[0..127] of char;
  end;
  PNewCplInfoA = ^TNewCplInfoA;

{$IFDEF WIN32}
type
  TNewCplInfoW = record
    dwSize: DWORD;
    dwFlags: DWORD;
    dwHelpContext: DWORD;
    lData: LongInt;
    IconH: HIcon;
    szName: array[0..31] of WChar;
    szInfo: array[0..63] of WChar;
    szHelpFile: array[0..127] of WChar;
  end;
  PNewCplInfoW = ^TNewCplInfoW;
{$ENDIF}

type
  TNewCplInfo = TNewCplInfoA;
type
  PNewCplInfo = ^TNewCplInfoA;

function CPlApplet(hWndCPL: hWnd; iMEssage: integer; lParam1: longint;
  lParam2: longint): Longint{$IFDEF WIN32} stdcall;
{$ELSE}; export;
{$ENDIF}
begin
  case iMessage of
    CPL_INIT:
      begin
        Result := 1;
        exit;
      end;
    CPL_GetCount:
      begin
        Result := NUM_APPLETS;
        exit;
      end;
    CPL_Inquire:
      begin
        PCplInfo(lParam2)^.idIcon := 2;
        PCplInfo(lParam2)^.idName := 1;
        PCplInfo(lParam2)^.idInfo := 2;
        PCplInfo(lParam2)^.lData := 0;
        Result := 1;
        exit;
      end;
    CPL_NewInquire:
      begin
        PNewCplInfo(lParam2)^.dwSize := sizeof(TNewCplInfo);
        PNewCplInfo(lParam2)^.dwHelpContext := 0;
        PNewCplInfo(lParam2)^.lData := 0;
        PNewCplInfo(lParam2)^.IconH := LoadIcon(hInstance, MakeIntResource(2));
        lStrCpy(@PNewCplInfo(lParam2)^.szName, 'TestCPL');
        lStrCpy(PNewCplInfo(lParam2)^.szInfo, 'My Test CPL');
        PNewCplInfo(lParam2)^.szHelpFile[0] := #0;
        Result := 1;
        exit;
      end;
    CPL_SELECT:
      begin
        Result := 0;
        exit;
      end;
    CPL_DBLCLK:
      begin
        WinExec('Notepad.exe', SW_SHOWNORMAL);
        Result := 1;
        exit;
      end;
    CPL_STOP:
      begin
        Result := 0;
        exit;
      end;
    CPL_EXIT:
      begin
        Result := 0;
        exit;
      end
  else
    begin
      Result := 0;
      exit;
    end;
  end;
end;

exports CPlApplet name 'CPlApplet';

begin
end.