Select or find a TTreeView node by caption

Problem/Question/Abstract:

How to select or find a TTreeView node by caption

Answer:

Solve 1:

function GetNodeByCaption(NodeCaption: string): TTreeNode;
var
  X: Integer;
begin
  Result := nil;
  for X := 0 to TreeView1.Items.Count - 1 do
  begin
    if (TreeView1.Items[X].Caption = NodeCaption) then
      Result := TreeView1.Items[X];
    Break;
  end;
end;


Solve 2:

Returns a node based on the text property. Set AVisible to show the new node:

function GetNodeByText(ATree: TTreeView; AValue: string;
  AVisible: Boolean): TTreeNode;
var
  Node: TTreeNode;
begin
  Result := nil;
  if ATree.Count = 0 then
    Exit;
  Node := ATree.Items[0];
  while Node <> nil do
  begin
    if UpperCase(Node.Text) = AValue then
    begin
      Result := Node;
      if AVisible then
        Result.MakeVisible;
      Break;
    end;
    Node := Node.GetNext;
  end;
end;

How to copy a 2D array with picture greylevels to an image (2)

Problem/Question/Abstract:

I have been developing a program to display and manipulate medical images which consist of 2D arrays of greyscale values as described. As was observed, the Pixels property is way too slow. Here's what I discovered. I think you'll find it a big improvement.

Answer:

Assuming your data is stored in an array of bytes named TestArray, for example:


TestArray: array[0..127, 0..127] of byte { ... }

ArrayPtr := addr(TestArray); {ArrayPtr: pointer}


In this case we are going to display on the bitmap of a TImage component that has been dropped on the canvas and named Image1.


Image1.Picture.Bitmap.Width := 128;
Image1.Picture.Bitmap.Height := 128;


This is a Windows API function that will copy the bits in TestArray, pointed to by ArrayPtr, into an HBitmap structure, in this case Image1.Picture.Bitmap.Handle.


SetBitmapBits(Image1.Picture.Bitmap.Handle, sizeof(TestArray), ArrayPtr);
Image1.Refresh; {must refresh before changes are displayed}


You still have to deal with the palette, but this technique works great for me.

How to set the DisplayFormat of a TDateTime field to time only at runtime

Problem/Question/Abstract:

I'm running a simple query that returns a variable amount of columns somtimes with a DateTime column. How can I set at runtime the Displayformat property or any other way to format the column as a time only field. In other words, I can't seem to find where to set the DisplayFormat property at runtime.

Answer:

Here's one way:

procedure FormatDateFieldsAsTime(DS: TDataSet; TimeFormat: string);
var
  f: integer;
begin
  for f := 0 to DS.FieldCount - 1 do
    if DS.Fields[f] is TDateTimeField then
      TDateTimeField(DS.Fields[f]).DisplayFormat := TimeFormat;
end;

Apply this to the query after it's been run, like:

FormatDateFieldsAsTime(Query1, 'hh:mm:ss');

The DisplayFormat is available (assuming you're not creating any persistant fields for this dynamic query) from the query's (or other TDataSet's) Fields property.

How to specify a line break in a TRichEdit

Problem/Question/Abstract:

I need to be able to (preferrably dynamically as the user is typing text) to specify a line break of say 70 characters so that the cursor will go to a new line upon reaching the 70 character limit. Actually it would be best to break on the last word boundary but even a break at 70 characters would give me a start.

Answer:

I've had a play with this and the following is the best I could come up with quickly. At least it may give you a start:

Set a Variable called Backpace : Boolean = False ;

procedure GetCurrentRC(re1: TRichedit; var row, col: LongInt);
begin
  {Get Current Row and Column Values for Richedit Control}
  with re1 do
  begin
    Row := sendMessage(handle, EM_LINEFROMCHAR, Selstart, 0);
    Col := selstart - sendmessage(handle, EM_LINEINDEX, row, 0);
  end;
end;

procedure TForm1.re1SelectionChange(Sender: TObject);
var
  RTRow, RTCol: LongInt;
begin
  GetCurrentRC(re1, RTRow, RTCol);
  if (rtCol = 70) and (not Backspace) then
    re1.Lines[rtRow] := Memo1.Lines[rtRow] + #13#10;
end;

procedure TForm1.Re1KeyPress(Sender: TObject; var Key: Char);
begin
  {If Backspacing we don't want it to jump down again}
  if key = #8 then
    backspace := True
  else
    backspace := False;
end;

I think that's about right. You would have to search on the position of any space if you wanted to break on a word boundary.

How to paint an arc on a TCanvas

Problem/Question/Abstract:

How to paint an arc on a TCanvas

Answer:

procedure PlotArc(const Canvas: TCanvas; const Center: TPoint; const Radius: Integer;
  const StartAngle: Single; const StopAngle: Single);

  function GetPositionForAngle(const Angle: Single): TPoint;
  var
    CosAngle: Extended;
    SinAngle: Extended;
  begin
    SinCos(DegToRad(Angle), SinAngle, CosAngle);
    Result.X := Round(Center.X + Radius * SinAngle);
    Result.Y := Round(Center.Y - Radius * CosAngle);
  end;

var
  Index: Integer;
begin
  with GetPositionForAngle(StartAngle) do
    Canvas.MoveTo(X, Y);
  for Index := Ceil(StartAngle) to Floor(StopAngle) do
    with GetPositionForAngle(Index) do
      Canvas.LineTo(X, Y);
  with GetPositionForAngle(StopAngle) do
    Canvas.LineTo(X, Y);
end;

Save a TImagelist with all its images to a file

Problem/Question/Abstract:

How to save a TImagelist with all its images to a file

Answer:

There are ready-made methods for saving any component including all its children to a file. For writing components use WriteComponentResFile(path + source filename , component name source)

WriteComponentResFile('C:\imagelist1.bin', imagelist1);

For reading the data back to a component: component := ReadComponentResFile(path + source filename , component name traget)

imagelist1 := ReadComponentResFile('c:\imagelist1.bin', nil) as TImagelist;

Tip 1 - Reading the component will give the same name of the component written so don't try to load it to another component, even if it was the same type. You will get a duplicate name and delphi will crash. But you can jump over this as a programmer

Tip 2 - Get benfit of storing the heavy components inside compressed files, so you can get smaller programs

Floating toolbar

Problem/Question/Abstract:

Floating toolbar

Answer:

All you have to do is handle Windows' wm_NCHitTest message.
(Compare to the tip how to drag a window without a caption bar. It's the same technique.)


unit Dragmain;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
  inherited; { call the inherited message handler }
  if M.Result = htClient then { is the click in the client area?   }
    M.Result := htCaption; { if so, make Windows think it's     }
  { on the caption bar.                }
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Close;
end;

end.

IDE harddisk serial number (Part 2)

Problem/Question/Abstract:

In my previous article I described the way to extract s/n through call DeviceIoControl with DFP_RECEIVE_DRIVE_DATA control code. But on NT it works only under account with administrative priveleges. Now I've found the way to do this under 'everyone' account.

Answer:

Warning! On Win9x smartvsd.vxd must be installed: simply copy it from
\windows\system\ to \windows\system\iosubsys\ and reboot.

// (c) Alex Konshin    mailto:akonshin@earthlink.net      30 jul 2000

program IdeSN;

// PURPOSE: Simple console application that extract first IDE disk serial number.

{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils; // only for Win32Platform and SysErrorMessage

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

function GetIdeDiskSerialNumber: string;
type
  TSrbIoControl = packed record
    HeaderLength: ULONG;
    Signature: array[0..7] of Char;
    Timeout: ULONG;
    ControlCode: ULONG;
    ReturnCode: ULONG;
    Length: ULONG;
  end;
  SRB_IO_CONTROL = TSrbIoControl;
  PSrbIoControl = ^TSrbIoControl;

  TIDERegs = packed record
    bFeaturesReg: Byte; // Used for specifying SMART "commands".
    bSectorCountReg: Byte; // IDE sector count register
    bSectorNumberReg: Byte; // IDE sector number register
    bCylLowReg: Byte; // IDE low order cylinder value
    bCylHighReg: Byte; // IDE high order cylinder value
    bDriveHeadReg: Byte; // IDE drive/head register
    bCommandReg: Byte; // Actual IDE command.
    bReserved: Byte; // reserved.  Must be zero.
  end;
  IDEREGS = TIDERegs;
  PIDERegs = ^TIDERegs;

  TSendCmdInParams = packed record
    cBufferSize: DWORD;
    irDriveRegs: TIDERegs;
    bDriveNumber: Byte;
    bReserved: array[0..2] of Byte;
    dwReserved: array[0..3] of DWORD;
    bBuffer: array[0..0] of Byte;
  end;
  SENDCMDINPARAMS = TSendCmdInParams;
  PSendCmdInParams = ^TSendCmdInParams;

  TIdSector = packed record
    wGenConfig: Word;
    wNumCyls: Word;
    wReserved: Word;
    wNumHeads: Word;
    wBytesPerTrack: Word;
    wBytesPerSector: Word;
    wSectorsPerTrack: Word;
    wVendorUnique: array[0..2] of Word;
    sSerialNumber: array[0..19] of Char;
    wBufferType: Word;
    wBufferSize: Word;
    wECCSize: Word;
    sFirmwareRev: array[0..7] of Char;
    sModelNumber: array[0..39] of Char;
    wMoreVendorUnique: Word;
    wDoubleWordIO: Word;
    wCapabilities: Word;
    wReserved1: Word;
    wPIOTiming: Word;
    wDMATiming: Word;
    wBS: Word;
    wNumCurrentCyls: Word;
    wNumCurrentHeads: Word;
    wNumCurrentSectorsPerTrack: Word;
    ulCurrentSectorCapacity: ULONG;
    wMultSectorStuff: Word;
    ulTotalAddressableSectors: ULONG;
    wSingleWordDMA: Word;
    wMultiWordDMA: Word;
    bReserved: array[0..127] of Byte;
  end;
  PIdSector = ^TIdSector;

const
  IDE_ID_FUNCTION = $EC;
  IDENTIFY_BUFFER_SIZE = 512;
  DFP_RECEIVE_DRIVE_DATA = $0007C088;
  IOCTL_SCSI_MINIPORT = $0004D008;
  IOCTL_SCSI_MINIPORT_IDENTIFY = $001B0501;
  DataSize = sizeof(TSendCmdInParams) - 1 + IDENTIFY_BUFFER_SIZE;
  BufferSize = SizeOf(SRB_IO_CONTROL) + DataSize;
  W9xBufferSize = IDENTIFY_BUFFER_SIZE + 16;
var
  hDevice: THandle;
  cbBytesReturned: DWORD;
  pInData: PSendCmdInParams;
  pOutData: Pointer; // PSendCmdOutParams
  Buffer: array[0..BufferSize - 1] of Byte;
  srbControl: TSrbIoControl absolute Buffer;

  procedure ChangeByteOrder(var Data; Size: Integer);
  var
    ptr: PChar;
    i: Integer;
    c: Char;
  begin
    ptr := @Data;
    for i := 0 to (Size shr 1) - 1 do
    begin
      c := ptr^;
      ptr^ := (ptr + 1)^;
      (ptr + 1)^ := c;
      Inc(ptr, 2);
    end;
  end;

begin
  Result := '';
  FillChar(Buffer, BufferSize, #0);
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin // Windows NT, Windows 2000
    // Get SCSI port handle
    hDevice := CreateFile(
      '\\.\Scsi0:', // Note: '\\.\C:' requires administrative permissions.
      GENERIC_READ or GENERIC_WRITE,
      FILE_SHARE_READ or FILE_SHARE_WRITE,
      nil, OPEN_EXISTING, 0, 0);
    if hDevice = INVALID_HANDLE_VALUE then
      Exit;
    try
      srbControl.HeaderLength := SizeOf(SRB_IO_CONTROL);
      System.Move('SCSIDISK', srbControl.Signature, 8);
      srbControl.Timeout := 2;
      srbControl.Length := DataSize;
      srbControl.ControlCode := IOCTL_SCSI_MINIPORT_IDENTIFY;
      pInData := PSendCmdInParams(PChar(@Buffer)
        + SizeOf(SRB_IO_CONTROL));
      pOutData := pInData;
      with pInData^ do
      begin
        cBufferSize := IDENTIFY_BUFFER_SIZE;
        bDriveNumber := 0;
        with irDriveRegs do
        begin
          bFeaturesReg := 0;
          bSectorCountReg := 1;
          bSectorNumberReg := 1;
          bCylLowReg := 0;
          bCylHighReg := 0;
          bDriveHeadReg := $A0;
          bCommandReg := IDE_ID_FUNCTION;
        end;
      end;
      if not DeviceIoControl(hDevice, IOCTL_SCSI_MINIPORT,
        @Buffer, BufferSize, @Buffer, BufferSize,
        cbBytesReturned, nil) then
        Exit;
    finally
      CloseHandle(hDevice);
    end;
  end
  else
  begin // Windows 95 OSR2, Windows 98
    hDevice := CreateFile('\\.\SMARTVSD', 0, 0, nil,
      CREATE_NEW, 0, 0);
    if hDevice = INVALID_HANDLE_VALUE then
      Exit;
    try
      pInData := PSendCmdInParams(@Buffer);
      pOutData := @pInData^.bBuffer;
      with pInData^ do
      begin
        cBufferSize := IDENTIFY_BUFFER_SIZE;
        bDriveNumber := 0;
        with irDriveRegs do
        begin
          bFeaturesReg := 0;
          bSectorCountReg := 1;
          bSectorNumberReg := 1;
          bCylLowReg := 0;
          bCylHighReg := 0;
          bDriveHeadReg := $A0;
          bCommandReg := IDE_ID_FUNCTION;
        end;
      end;
      if not DeviceIoControl(hDevice, DFP_RECEIVE_DRIVE_DATA,
        pInData, SizeOf(TSendCmdInParams) - 1, pOutData,
        W9xBufferSize, cbBytesReturned, nil) then
        Exit;
    finally
      CloseHandle(hDevice);
    end;
  end;
  with PIdSector(PChar(pOutData) + 16)^ do
  begin
    ChangeByteOrder(sSerialNumber, SizeOf(sSerialNumber));
    SetString(Result, sSerialNumber, SizeOf(sSerialNumber));
  end;
end;

//=============================================================
var
  s: string;
  rc: DWORD;
begin
  s := GetIdeDiskSerialNumber;
  if s = '' then
  begin
    rc := GetLastError;
    if rc = 0 then
      WriteLn('IDE drive is not support SMART feature')
    else
      WriteLn(SysErrorMessage(rc));
  end
  else
    WriteLn('Disk serial number: ''', s, '''');
end.

See also IdeInfo2 on my homepage: http://home.earhlink.net/~akonshin/


Component Download: http://home.earthlink.net/~akonshin/files/IdeSN.zip

Getting the icon of an application, library or document

Problem/Question/Abstract:

How can I get the icon of an application or the icons in a DLL?

Answer:

ExtractAssociatedIcon

To get the icon of an application or document we can use this API  function (declared in the ShellAPI unit):

function ExtractAssociatedIcon(hInst: HINST; lpIconPath: PChar;
  var lpiIcon: Word): HICON; stdcall;

hInst: The application handle. This value is contained in the  predefined variable HInstance.

lpIconPath: A pointer to a character buffer that should contain a   null terminated string with the full path name of the application,   library (DLL) or document. If it is a document, the function will   place there the full pathname of the associated application from   where the icon was extracted, so we should allocate a buffer large   enough.

lpiIcon: The icon index (the first icon in the file has an index of 0). If lpIconPath specifies a document, then lpiIcon is set by the function (that's why it is passed by reference) to the index position of the actual icon taken from the associated executable (defined in the file association).

Return value:
If the function fails, it returns 0. If it succeeds, it returns an icon handle, which is an integer value Windows uses to identify the allocated resource. It is not necessary to call the API DestroyIcon to release the icon since it'll be deallocated automatically when the application finishes, although you can do it if you want.

Sample call

Now, what do we do with the icon handle? Normally what we want is an icon, namely and instance of the TIcon class. All we have to do is create a TIcon object and assign this handle to its Handle property. If later we assign the Handle property to another value, the previous icon will be automatically be released. The same happens if the TIcon object is freed. Here is an example that changes the icon of the form:

procedure TForm1.Button1Click(Sender: TObject);
var
  IconIndex: word;
  Buffer: array[0..2048] of char;
  IconHandle: HIcon;
begin
  StrCopy(@Buffer, 'C:\Windows\Help\Windows.hlp');
  IconIndex := 0;
  IconHandle := ExtractAssociatedIcon(HInstance, Buffer, IconIndex);
  if IconHandle <> 0 then
    Icon.Handle := IconHandle;
end;

GetAssociatedIcon

Unfortunately, ExtractAssociatedIcon fails if the file does not exists on disk, so we defined a procedure that gets the icon of a file whether it exists or not, and can also get the small icon (ideal for a TListView that can be shown in vsIcon or vsReport view styles). The procedure receives three parameters: the filename and two pointers to HICON (integer) variables: one for the large icon (32x32) and another one for the small icon (16x16). Any of them can be nil if you don't need one of these icons. The icons "returned" by the procedure must be freed with the DestroyIcon API. This will be done automatically if you assign the icon handle (HICON) to the Handle property of a TIcon object
(the icon will be released when this object gets freed or a new value is assigned to it).

uses
  Registry, ShellAPI;

type
  PHICON = ^HICON;

procedure GetAssociatedIcon(FileName: TFilename;
  PLargeIcon, PSmallIcon: PHICON);
// Gets the icons of a given file
var
  IconIndex: word; // Position of the icon in the file
  FileExt, FileType: string;
  Reg: TRegistry;
  p: integer;
  p1, p2: pchar;
label
  noassoc;
begin
  IconIndex := 0;
  // Get the extension of the file
  FileExt := UpperCase(ExtractFileExt(FileName));
  if ((FileExt <> '.EXE') and (FileExt <> '.ICO')) or
    not FileExists(FileName) then
  begin
    // If the file is an EXE or ICO and it exists, then
    // we will extract the icon from this file. Otherwise
    // here we will try to find the associated icon in the
    // Windows Registry...
    Reg := nil;
    try
      Reg := TRegistry.Create(KEY_QUERY_VALUE);
      Reg.RootKey := HKEY_CLASSES_ROOT;
      if FileExt = '.EXE' then
        FileExt := '.COM';
      if Reg.OpenKeyReadOnly(FileExt) then
      try
        FileType := Reg.ReadString('');
      finally
        Reg.CloseKey;
      end;
      if (FileType <> '') and Reg.OpenKeyReadOnly(
        FileType + '\DefaultIcon') then
      try
        FileName := Reg.ReadString('');
      finally
        Reg.CloseKey;
      end;
    finally
      Reg.Free;
    end;

    // If we couldn't find the association, we will
    // try to get the default icons
    if FileName = '' then
      goto noassoc;

    // Get the filename and icon index from the
    // association (of form '"filaname",index')
    p1 := PChar(FileName);
    p2 := StrRScan(p1, ',');
    if p2 <> nil then
    begin
      p := p2 - p1 + 1; // Position of the comma
      IconIndex := StrToInt(Copy(FileName, p + 1,
        Length(FileName) - p));
      SetLength(FileName, p - 1);
    end;
  end;
  // Attempt to get the icon
  if ExtractIconEx(pchar(FileName), IconIndex,
    PLargeIcon^, PSmallIcon^, 1) <> 1 then
  begin
    noassoc:
    // The operation failed or the file had no associated
    // icon. Try to get the default icons from SHELL32.DLL

    try // to get the location of SHELL32.DLL
      FileName := IncludeTrailingBackslash(GetSystemDir)
        + 'SHELL32.DLL';
    except
      FileName := 'C:\WINDOWS\SYSTEM\SHELL32.DLL';
    end;
    // Determine the default icon for the file extension
    if (FileExt = '.DOC') then
      IconIndex := 1
    else if (FileExt = '.EXE')
      or (FileExt = '.COM') then
      IconIndex := 2
    else if (FileExt = '.HLP') then
      IconIndex := 23
    else if (FileExt = '.INI')
      or (FileExt = '.INF') then
      IconIndex := 63
    else if (FileExt = '.TXT') then
      IconIndex := 64
    else if (FileExt = '.BAT') then
      IconIndex := 65
    else if (FileExt = '.DLL')
      or (FileExt = '.SYS')
      or (FileExt = '.VBX')
      or (FileExt = '.OCX')
      or (FileExt = '.VXD') then
      IconIndex := 66
    else if (FileExt = '.FON') then
      IconIndex := 67
    else if (FileExt = '.TTF') then
      IconIndex := 68
    else if (FileExt = '.FOT') then
      IconIndex := 69
    else
      IconIndex := 0;
    // Attempt to get the icon.
    if ExtractIconEx(pchar(FileName), IconIndex,
      PLargeIcon^, PSmallIcon^, 1) <> 1 then
    begin
      // Failed to get the icon. Just "return" zeroes.
      if PLargeIcon <> nil then
        PLargeIcon^ := 0;
      if PSmallIcon <> nil then
        PSmallIcon^ := 0;
    end;
  end;
end;

Sample call

This example will change the icon of your form:

procedure TForm1.Button1Click(Sender: TObject);
var
  SmallIcon: HICON;
begin
  GetAssociatedIcon('file.doc', nil, @SmallIcon);
  if SmallIcon <> 0 then
    Icon.Handle := SmallIcon;
end;

Copyright (c) 2001 Ernesto De Spirito
Visit: http://www.latiumsoftware.com/delphi-newsletter.php

Delphi translation of the IAutoComplete interface

Problem/Question/Abstract:

I'm looking for a Delphi translation of the IAutoComplete interface in Microsofts shldisp.h. Can anyone point me in the right direction, please?

Answer:

Here is the translation and a TEdit decendant I wrote a while back:

unit uAutoComplete;

interface

uses
  Windows, SysUtils, Controls, Classes, ActiveX, ComObj, stdctrls, Forms, Messages;

const
  IID_IAutoComplete: TGUID = '{00bb2762-6a77-11d0-a535-00c04fd7d062}';
  IID_IAutoComplete2: TGUID = '{EAC04BC0-3791-11d2-BB95-0060977B464C}';
  CLSID_IAutoComplete: TGUID = '{00BB2763-6A77-11D0-A535-00C04FD7D062}';
  IID_IACList: TGUID = '{77A130B0-94FD-11D0-A544-00C04FD7d062}';
  IID_IACList2: TGUID = '{470141a0-5186-11d2-bbb6-0060977b464c}';
  CLSID_ACLHistory: TGUID = '{00BB2764-6A77-11D0-A535-00C04FD7D062}';
  CLSID_ACListISF: TGUID = '{03C036F1-A186-11D0-824A-00AA005B4383}';
  CLSID_ACLMRU: TGUID = '{6756a641-de71-11d0-831b-00aa005b4383}';

type
  IACList = interface(IUnknown)
    ['{77A130B0-94FD-11D0-A544-00C04FD7d062}']
    function Expand(pszExpand: POLESTR): HResult; stdcall;
  end;

const
  {Options for IACList2}
  ACLO_NONE = 0; {don't enumerate anything}
  ACLO_CURRENTDIR = 1; {enumerate current directory}
  ACLO_MYCOMPUTER = 2; {enumerate MyComputer}
  ACLO_DESKTOP = 4; {enumerate Desktop Folder}
  ACLO_FAVORITES = 8; {enumerate Favorites Folder}
  ACLO_FILESYSONLY = 16; {enumerate only the file system}

type

  IACList2 = interface(IACList)
    ['{470141a0-5186-11d2-bbb6-0060977b464c}']
    function SetOptions(dwFlag: DWORD): HResult; stdcall;
    function GetOptions(var pdwFlag: DWORD): HResult; stdcall;
  end;

  IAutoComplete = interface(IUnknown)
    ['{00bb2762-6a77-11d0-a535-00c04fd7d062}']
    function Init(hwndEdit: HWND; const punkACL: IUnknown; pwszRegKeyPath,
      pwszQuickComplete: POLESTR): HResult; stdcall;
    function Enable(fEnable: BOOL): HResult; stdcall;
  end;

const
  {Options for IAutoComplete2}
  ACO_NONE = 0;
  ACO_AUTOSUGGEST = $1;
  ACO_AUTOAPPEND = $2;
  ACO_SEARCH = $4;
  ACO_FILTERPREFIXES = $8;
  ACO_USETAB = $10;
  ACO_UPDOWNKEYDROPSLIST = $20;
  ACO_RTLREADING = $40;

type

  IAutoComplete2 = interface(IAutoComplete)
    ['{EAC04BC0-3791-11d2-BB95-0060977B464C}']
    function SetOptions(dwFlag: DWORD): HResult; stdcall;
    function GetOptions(out pdwFlag: DWORD): HResult; stdcall;
  end;

  TEnumString = class(TInterfacedObject, IEnumString)
  private
    FStrings: TStringList;
    FCurrIndex: integer;
  public
    {IEnumString}
    function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
    function Skip(celt: Longint): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out enm: IEnumString): HResult; stdcall;
    {VCL}
    constructor Create;
    destructor Destroy; override;
  end;

  TACOption = (acAutoAppend, acAutoSuggest, acUseArrowKey);
  TACOptions = set of TACOption;

  TACSource = (acsList, acsHistory, acsMRU, acsShell);

  TACEdit = class(TEdit)
  private
    FACList: TEnumString;
    FAutoComplete: IAutoComplete;
    FACEnabled: boolean;
    FACOptions: TACOptions;
    FACSource: TACSource;
    function GetACStrings: TStringList;
    procedure SetACEnabled(const Value: boolean);
    procedure SetACOptions(const Value: TACOptions);
    procedure SetACSource(const Value: TACSource);
  protected
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property ACStrings: TStringList read GetACStrings;
    property ACEnabled: boolean read FACEnabled write SetACEnabled;
    property ACOptions: TACOptions read FACOptions write SetACOptions;
    property ACSource: TACSource read FACSource write SetACSource;
  end;

implementation

{ IUnknownInt }

function TEnumString.Clone(out enm: IEnumString): HResult;
begin
  Result := E_NOTIMPL;
  pointer(enm) := nil;
end;

constructor TEnumString.Create;
begin
  inherited Create;
  FStrings := TStringList.Create;
  FCurrIndex := 0;
end;

destructor TEnumString.Destroy;
begin
  FStrings.Free;
  inherited;
end;

function TEnumString.Next(celt: Integer; out elt; pceltFetched: PLongint): HResult;
var
  I: Integer;
  wStr: WideString;
begin
  I := 0;
  while (I < celt) and (FCurrIndex < FStrings.Count) do
  begin
    wStr := FStrings[FCurrIndex];
    TPointerList(elt)[I] := CoTaskMemAlloc(2 * (Length(wStr) + 1));
    StringToWideChar(wStr, TPointerList(elt)[I], 2 * (Length(wStr) + 1));
    Inc(I);
    Inc(FCurrIndex);
  end;
  if pceltFetched <> nil then
    pceltFetched^ := I;
  if I = celt then
    Result := S_OK
  else
    Result := S_FALSE;
end;

function TEnumString.Reset: HResult;
begin
  FCurrIndex := 0;
  Result := S_OK;
end;

function TEnumString.Skip(celt: Integer): HResult;
begin
  if (FCurrIndex + celt) <= FStrings.Count then
  begin
    Inc(FCurrIndex, celt);
    Result := S_OK;
  end
  else
  begin
    FCurrIndex := FStrings.Count;
    Result := S_FALSE;
  end;
end;

{ TACEdit }

constructor TACEdit.Create(AOwner: TComponent);
begin
  inherited;
  FACList := TEnumString.Create;
  FACEnabled := true;
  FACOptions := [acAutoAppend, acAutoSuggest, acUseArrowKey];
end;

procedure TACEdit.CreateWnd;
var
  Dummy: IUnknown;
  Strings: IEnumString;
begin
  inherited;
  if HandleAllocated then
  begin
    try
      Dummy := CreateComObject(CLSID_IAutoComplete);
      if (Dummy <> nil) and (Dummy.QueryInterface(IID_IAutoComplete, FAutoComplete) =
        S_OK) then
      begin
        case FACSource of
          acsHistory:
            Strings := CreateComObject(CLSID_ACLHistory) as IEnumString;
          acsMRU:
            Strings := CreateComObject(CLSID_ACLMRU) as IEnumString;
          acsShell:
            Strings := CreateComObject(CLSID_ACListISF) as IEnumString;
        else
          Strings := FACList as IEnumString;
        end;
        if S_OK = FAutoComplete.Init(Handle, Strings, nil, nil) then
        begin
          SetACEnabled(FACEnabled);
          SetACOptions(FACOptions);
        end;
      end;
    except
      {CLSID_IAutoComplete is not available}
    end;
  end;
end;

destructor TACEdit.Destroy;
begin
  FACList := nil;
  inherited;
end;

procedure TACEdit.DestroyWnd;
begin
  if (FAutoComplete <> nil) then
  begin
    FAutoComplete.Enable(false);
    FAutoComplete := nil;
  end;
  inherited;
end;

function TACEdit.GetACStrings: TStringList;
begin
  Result := FACList.FStrings;
end;

procedure TACEdit.SetACEnabled(const Value: boolean);
begin
  if (FAutoComplete <> nil) then
  begin
    FAutoComplete.Enable(FACEnabled);
  end;
  FACEnabled := Value;
end;

procedure TACEdit.SetACOptions(const Value: TACOptions);
const
  Options: array[TACOption] of integer = (ACO_AUTOAPPEND, ACO_AUTOSUGGEST,
    ACO_UPDOWNKEYDROPSLIST);
var
  Option: TACOption;
  Opt: DWORD;
  AC2: IAutoComplete2;
begin
  if (FAutoComplete <> nil) then
  begin
    if S_OK = FAutoComplete.QueryInterface(IID_IAutoComplete2, AC2) then
    begin
      Opt := ACO_NONE;
      for Option := Low(Options) to High(Options) do
      begin
        if (Option in FACOptions) then
          Opt := Opt or DWORD(Options[Option]);
      end;
      AC2.SetOptions(Opt);
    end;
  end;
  FACOptions := Value;
end;

procedure TACEdit.SetACSource(const Value: TACSource);
begin
  if FACSource <> Value then
  begin
    FACSource := Value;
    RecreateWnd;
  end;
end;

initialization
finalization
end.

Getting rid of the initial flash of a WS_MAXIMIZE child

Problem/Question/Abstract:

How can I open an MDI child form so that it's initially in a maximized state? Every time I try, it appears in its normal size, then maximizes visibly. I can't hide it because Delphi won't let me, and if I trick it by hiding it in CreateParams, it's maximized for a split second (just after OnShow()), then is reduced to normal size, then is re-maximized. This is all happening somewhere after OnShow() and I can't seem to stop it ... I just need it to open already maximized, and all ready to go. ... Help!

Answer:

One thing you might have noticed is that child forms set with the wsMaximized property have a visible flash when they're first created. First they're created in a normal state, then they maximize. This is more annoying than problematic.

For those of you who are experienced in mucking about with form properties, you might think that setting the form's window style to WS_MAXIMIZE in the CreateParams method would do the trick. Alas, that doesn't work either. But don't worry, there's a very simple solution.

One of the ways you can prevent the user from seeing background operations on a window is to prevent it from painting, then having it refresh after the changes have been made. To the user, it will appear as if the screen was automagically changed in the blink of an eye. With respect to opening up a maximized MDI child form in an MDI application, this is exactly the type of thing we're going to do.

The specific function that allows us to prevent screen painting is a WinAPI function called LockWindowUpdate. LockWindowUpdate takes a single parameter &mdash the handle of the window &mdash and prevents it from painting until LockWindowUpdate is called again with a parameter of '0.' So, with respect to our particular problem, to prevent a maximized MDI child from flashing at create, you enclose its create statement between two LockWindowUpdate calls like so:

LockWindowUpdate(MyMDIMainForm.Handle);
MyMDIChild := TMyMDIChild.Create(Application);
LockWindowUpdate(0);

Pretty simple, huh? Notice that I locked the screen painting with respect to the MDI form, not the MDI child. That's important, because if you tried to lock the update for the child, you'd get an error because the handle is invalid. In any case, use this technique for all your MDI applications to avoid the initial flash.

How to display hints always under the mouse cursor

Problem/Question/Abstract:

How to display hints always under the mouse cursor

Answer:

This code snippet shows how to make your popup hint windows behave more like normal windows apps. Instead of always being square under the control they belong to, they are based on where the mouse is. This uses the GetIconInfo API, which is only available for Win32.

Add the following to your main form's OnCreate event handler:


procedure TMainForm.FormCreate(Sender: TObject);
begin
  Application.OnShowHint := GetHintInfo;
end;


Add the following declaration to your main form's protected declartion:


procedure GetHintInfo(var HintStr: string; var CanShow: boolean; var HintInfo: THintInfo);


And, finally, add this procedure to your main form:


procedure TMainForm.GetHintInfo(var HintStr: string; var CanShow: boolean; var HintInfo: THintInfo);
var
  II: TIconInfo;
  Bmp: Windows.TBitmap;
begin
  with HintInfo do
  begin
    {Make sure we have a control that fired the hint}
    if HintControl = nil then
      exit;
    {Convert the cursor's coordinates from relative to hint to relative to screen}
    HintPos := HintControl.ClientToScreen(CursorPos);
    {Get some information about the cursor that is used for the hint control}
    GetIconInfo(Screen.Cursors[HintControl.Cursor], II);
    {Get some information about the bitmap representing the cursor}
    GetObject(II.hbmMask, SizeOf(Windows.TBitmap), @Bmp);
    {If the info did not include a color bitmap then the mask bitmap is really two bitmaps, an AND & XOR mask. Increment our Y position by the bitmap's height}
    if II.hbmColor = 0 then
      inc(HintPos.Y, Bmp.bmHeight div 2)
    else
      inc(HintPos.Y, Bmp.bmHeight);
    {Subtract out the Y hotspot position}
    dec(HintPos.Y, II.yHotSpot);
    {We are responsible for cleaning up the bitmap handles returned by GetIconInfo}
    DeleteObject(II.hbmMask);
    DeleteObject(II.hbmColor);
  end;
end;

Delphi controls MS Office applications

Problem/Question/Abstract:

Delphi controls MS Office applications

Answer:

How can you remote control MS Office applications from your Delphi application? The Answer is to use a TOLEContainer.

It requires some interface knowledge to use the right object(s) and their properties. Some samples are added to Delphi demos, but all of them are targeted at MSWord. I have posted examples for Internet Explorer elsewhere and here is a sample for MSExcel:


// procedure is activated when OleOject activates user interface
// procedure copies TStringGrid content to an (OleObject) Excel sheet

procedure TForm1.OleContainer1Activate(Sender: TObject);
var
  ExcelSheet: Variant;
  Count,
    Curent: Variant;
  i,
    j: Integer;
begin
  // first we read how many sheets are open in a specified Excel document
  Count := OleContainer1.OleObject.Application.Sheets.Count;

  // then we read the number of a sheet to witch user wants to add StringGrid content
  Curent := StrToInt(OKBottomDlg.Edit2.Text);

  if Curent <> 0 then
  begin
    if Curent <= Count then
      // if the sheet with index Curent exist then copy content
    begin
      // first we activate the desiered sheet object
      OleContainer1.OleObject.Application.Sheets[Count].Activate;
      // pass the object to a variant variable
      ExcelSheet := OleContainer1.OleObject.Application.ActiveSheet;

      // now we can do what ever we like with it
      ExcelSheet.name := OKBottomDlg.Edit3.Text + IntToStr(Count);
      for i := 0 to StringGrid1.RowCount do
      begin
        for j := 0 to StringGrid1.ColCount do
        begin
          ExcelSheet.Cells(i, j) := StringGrid1.Cells[j, i]
        end
      end;
      // here we copy the content
    end
    else // else if the sheet we are trying to access doesn't exsist
    begin
      // we add new sheets untill the requested
      // user's index is reached ( curent variable )
      for i := Count + 1 to Curent do
      begin
        OleContainer1.OleObject.Application.Sheets.Add
      end;
      // again we do as above
      OleContainer1.OleObject.Application.Sheets[Curent].Activate;
      ExcelSheet := OleContainer1.OleObject.Application.ActiveSheet;
      ExcelSheet.name := OKBottomDlg.Edit3.Text + IntToStr(Count);
      for i := 0 to StringGrid1.RowCount do
      begin
        for j := 0 to StringGrid1.ColCount do
        begin
          ExcelSheet.Cells(i, j) := StringGrid1.Cells[j, i]
        end
      end;
    end
  end;
end;

How to make the TJPEGImage component recognize the *.jpeg file extension

Problem/Question/Abstract:

How to make the TJPEGImage component recognize the *.jpeg file extension

Answer:

{ ... }
var
  MyImage: TImage;
begin
  JPEG := TJPEGImage.Create;
  try
    JPEG.LoadFromFile('C:\TEMP\SOMEIMAGE.JPEG');
    MainImage.Picture.Assign(JPEG);
    MainImage.Invalidate;
  finally
    JPEG.Free;
  end;

Retrieve a file's "Last Accessed" attribute

Problem/Question/Abstract:

Retrieve a file's "Last Accessed" attribute

Answer:

In Windows 95, you can see when a file was last accessed by right-clicking the file and selecting properties. You can retrieve this date easily with the following ready-to-use function:

function LastAccess(const filename: string): string;
var
  FileHandle: THandle;
  LocalFileTime: TFileTime;
  DosFileTime: DWORD;
  LastAccessedTime: TDateTime;
  FindData: TWin32FindData;
begin
  Result := ''; { never :-) }
  FileHandle := FindFirstFile(filename, FindData);
  if FileHandle <> INVALID_HANDLE_VALUE then
  begin
    Windows.FindClose(Handle);
    if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
    begin
      FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
      FileTimeToDosDateTime(LocalFileTime,
        LongRec(DosFileTime).Hi, LongRec(DosFileTime).Lo);
      LastAccessedTime := FileDateToDateTime(DosFileTime);
      Result := DateTimeToStr(LastAccessedTime);
    end;
  end;
end;

Set the resolution of your screen

Problem/Question/Abstract:

This article shows how to set the resolution of your screen I pasted my whole unit below.

Answer:

unit Unit4;

interface

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

type
  TForm4 = class(TForm)
    ComboBox1: TComboBox;
    BitBtn1: TBitBtn;
    Bevel1: TBevel;
    procedure ComboBox1Change(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure Label4Click(Sender: TObject);
    procedure Button1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Button1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure BitBtn1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form4: TForm4;
  Modes: array[0..255] of TDevMode;

implementation

uses cliprex2;

{$R *.DFM}

procedure TForm4.ComboBox1Change(Sender: TObject);
begin
  bitbtn1.Enabled := combobox1.ItemIndex >= 0;
  bitbtn1.enabled := true;
end;

procedure TForm4.FormCreate(Sender: TObject);
var
  DC: THandle;
  Bits: Integer;
  HRes: Integer;
  VRes: Integer;
  DM: TDevMode;
  ModeNum: LongInt;
  Ok: Bool;
  I: Byte;
begin

  DC := Canvas.Handle;
  Bits := GetDeviceCaps(DC, BITSPIXEL);
  HRes := GetDeviceCaps(DC, HORZRES);
  VRes := GetDeviceCaps(DC, VERTRES);

  ModeNum := 0;
  EnumDisplaySettings(nil, ModeNum, DM);
  Modes[ModeNum] := DM;
  Ok := True;
  while Ok do
  begin
    Inc(ModeNum);
    Ok := EnumDisplaySettings(nil, ModeNum, DM);
    Modes[ModeNum] := DM;
  end;

  for I := 0 to ModeNum - 1 do
  begin
    ComboBox1.Items.Add(Format('%d x %d, %d bits',
      [TDevMode(Modes[I]).dmPelsWidth,
      TDevMode(Modes[I]).dmPelsHeight,
        TDevMode(Modes[I]).dmBitsPerPel]));
    ComboBox1.ItemIndex := 0;
  end;
end;

procedure TForm4.FormActivate(Sender: TObject);

var
  DC: THandle;
  Bits: Integer;
  HRes: Integer;
  VRes: Integer;

begin

  DC := Canvas.Handle;
  Bits := GetDeviceCaps(DC, BITSPIXEL);
  HRes := GetDeviceCaps(DC, HORZRES);
  VRes := GetDeviceCaps(DC, VERTRES);

  combobox1.text := Format('%d x %d, %d bits', [HRes, VRes, Bits]);
  bitbtn1.enabled := false;
end;

procedure TForm4.Label4Click(Sender: TObject);
begin
  form4.hide;
end;

procedure TForm4.Button1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  bitbtn1.Font.Color := clblue;
end;

procedure TForm4.Button1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  bitbtn1.Font.Color := clblack;
end;

procedure TForm4.BitBtn1Click(Sender: TObject);
var
  NewMode: TDevMode;
  ChResult: LongInt;

begin
  NewMode := TDevMode(Modes[ComboBox1.ItemIndex]);
  NewMode.dmDisplayFrequency := 0;
  NewMode.dmDisplayFlags :=
    DM_BITSPERPEL and
    DM_PELSWIDTH and
    DM_PELSHEIGHT and
    DM_DISPLAYFLAGS;
  ChResult := ChangeDisplaySettings(NewMode, CDS_UPDATEREGISTRY);

  form4.hide;
end;

procedure TForm4.BitBtn1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  bitbtn1.font.color := clblue;
end;

procedure TForm4.BitBtn1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  bitbtn1.font.color := clblack;
end;

end.

How to extract icons from a program or DLL

Problem/Question/Abstract:

How can I extract an icon from another executable or DLL through code?

Answer:

Use the Windows API function ExtractIcon(), passing it the instance handle of your application, the path name of the application you wish to extract the icon from, and the number of the icon you wish to extract:

var
  TheIcon: TIcon;
begin
  TheIcon := TIcon.Create;
  TheIcon.Handle := ExtractIcon(hInstance, 'C:\PATH\SOMEPROG.EXE', 0);
  {Do something with the icon}
  TheIcon.Free;
end;

Create a polygon-shaped form using regions

Problem/Question/Abstract:

How to create a polygon-shaped form using regions

Answer:

To start with, we need to make an array of points of all corners of the form (there can be as many as you want). Next we use the Windows API call CreatePolygonRgn to get a handle to the region we have just defined. Finally we need to set this region the window we want to be that shape using another API call SetWindowRgn. To see this in effect create a new project and in the forms onCreate event have:

procedure TForm1.FormCreate(Sender: TObject);
var
  Region: HRgn;
  Points: array[0..11] of TPoint;
begin
  {Define the points of a W shape}
  Points[0] := Point(0, 0);
  Points[1] := Point(50, 0);
  Points[2] := Point(180, 200);
  Points[3] := Point(218, 100);
  Points[4] := Point(256, 200);
  Points[5] := Point(385, 0);
  Points[6] := Point(435, 0);
  Points[7] := Point(256, 300);
  Points[8] := Point(218, 200);
  Points[9] := Point(180, 300);
  {Define the region}
  Region := CreatePolygonRgn(Points, 10, ALTERNATE);
  {Set the window to have the above defined region}
  SetWindowRgn(Handle, Region, True);
end;

How to implement a 'Lasso'

Problem/Question/Abstract:

How to implement a 'Lasso'

Answer:

Here's a possible approach:

1. In the OnMouseDown event for the form that you are 'lasso-ing' controls on:


bMarquee := True;
{set a boolean so that you can differentiate between decisions that might have to be made during other mouse events}
ptOrigin := Point(X, Y); { get the starting point of the marquee }
ptMove := Point(X, Y); { initialize the stopping point }



Set the pen and brush attributes here or by calling a common procedure that can be reused elsewhere in the Unit.


Pen.Color := clBlack;
Pen.Width := 1;
Pen.Style := psDash;
Brush.Style := bsClear;


Then draw the marquee rectangle


DrawMarquee(ptOrigin, ptMove, pmNotXor);


2. In the OnMouseMove event for the form...


if bMarquee = True then
begin
  DrawMarquee(ptOrigin, ptMove, pmNotXor);
  DrawMarquee(ptOrigin, Point(X, Y), pmNotXor);
  ptMove := Point(X, Y);
  Canvas.Pen.Mode := pmCopy;
end;


3. In the OnMouseUp event for the form...


if bMarquee = True then
begin
  bMarquee := False;
  DrawMarquee(ptOrigin, Point(X, Y), pmNotXor);
  ptMove := Point(X, Y);
  {check for any intersections between the marquee frame and controls}
  { call the procedure that will highlight ( focus ) the desired controls}
end;


The DrawMarquee procedure...


procedure myForm.DrawMarquee(mStart, mStop: TPoint; AMode: TPenMode);
begin
  Canvas.Pen.Mode := AMode;
  Canvas.Rectangle(mStart.X, mStart.Y, mStop.X, mStop.Y);
end;

Get File Created, Modified and Accessed dates

Problem/Question/Abstract:

How to get File Created, Modified and Accessed dates

Answer:

This function will return Created,Modified and Accessed datetimes of a given file. The datetimes are returned as TDateTime variables passed by REFERENCE. The function returns true if the file was found, else false. The dates are the same as displayed by EXPLORER when file properties is selected

// ================================================================
// Return the three dates (Created,Modified,Accessed
// of a given filename. Returns FALSE if file cannot
// be found or permissions denied. Results are returned
// in TdateTime OUT parameters
// ================================================================

function GetFileTimes(FileName: string;
  out Created: TDateTime;
  out Modified: TDateTime;
  out Accessed: TDateTime): boolean;
var
  FileHandle: integer;
  Cmd: boolean;
  FTimeC, FTimeA, FTimeM: TFileTime;
  LTime: TFileTime;
  STime: TSystemTime;
begin
  FileHandle := FileOpen(FileName, fmShareDenyNone);
  Created := 0.0;
  Modified := 0.0;
  Accessed := 0.0;

  if FileHandle < 0 then
    Cmd := false
  else
  begin
    Cmd := true;
    GetFileTime(FileHandle, @FTimeC, @FTimeA, @FTimeM);
    FileClose(FileHandle);

    // Created
    FileTimeToLocalFileTime(FTimeC, LTime);
    if FileTimeToSystemTime(LTime, STime) then
    begin
      Created := EncodeDate(STime.wYear, STime.wMonth, STime.wDay);
      Created := Created + EncodeTime(STime.wHour, STime.wMinute, STime.wSecond,
        STime.wMilliSeconds);
    end;

    // Accessed
    FileTimeToLocalFileTime(FTimeA, LTime);
    if FileTimeToSystemTime(LTime, STime) then
    begin
      Accessed := EncodeDate(STime.wYear, STime.wMonth, STime.wDay);
      Accessed := Accessed + EncodeTime(STime.wHour, STime.wMinute, STime.wSecond,
        STime.wMilliSeconds);
    end;

    // Modified
    FileTimeToLocalFileTime(FTimeM, LTime);
    if FileTimeToSystemTime(LTime, STime) then
    begin
      Modified := EncodeDate(STime.wYear, STime.wMonth, STime.wDay);
      Modified := Modified + EncodeTime(STime.wHour, STime.wMinute, STime.wSecond,
        STime.wMilliSeconds);
    end;

  end;

  Result := Cmd;
end;

Filters for 256 color greyscale images

Problem/Question/Abstract:

Filters for 256 color greyscale images

Answer:

There are a lot of different filters that belong in different algorithm methods . A few things that are important to all methods:


Images must be 256 gray levels (I did not test them with color images)
We assume that image has the function RC (x, y) where x,y are the position of every pixel
0 < = X < = image_width - 1 and 0 < = Y < = Image_height - 1



Convolution filters

This is the most used method (also known as "moving window filters" and maybe you have already used it. For each pixel in range (1,1),(width-1,height-1) we calculate its new value using the following algorithm:



for j = 1 to height - 1
  for i = 1 to width - 1
  newcolor = a1 * RC(i, j - 1) + a2 * RC(i, j - 1) + a3 * RC(i + 1, j - 1) + b1 * RC(i - 1, j) + b2 * RC(i, j) +  b3 * RC(i + 1, j) + c1 * RC(i - 1, j + 1) + c2 * RC(i, j + 1) + c3 * RC(i + 1, j + 1);
newcolor = newcolor / kl;
newcolor = abs(newcolor);
if (newcolor > 255)newcolor = 255; {not greater than 255}
{do whatever you want here eg put new pixel color in a buffer}
end i
end j



Unfortunately in this method we have strange results in first & last row & column. That's why we start from row-column 1 (which is the second ) and we stop 1 row & column before end.

Here follow the names of the filters that belong into this method and the parameters a1..c3, kl that be used :



LOW_PASSn are noise removal filters. Images are getting smoother.
LAPLACE_ORIGINAL is Edge ehnancement filter.
LAPLACE is a special effect filter (looks like you type the image in abnormal paper)
LAPLACE_EDGE is Edge detection filter.
FOCUS is a sharpen filter (looks like you have changed the focus of the camera when
snapping the picture)


case LOW_PASS1: {
kl=9;
a1=1; a2=1; a3=1;
b1=1; b2=1; b3=1;
c1=1; c2=1; c3=1; break;
}
case LOW_PASS2: {
kl=10;
a1=1; a2=1; a3=1;
b1=1; b2=2; b3=1;
c1=1; c2=1; c3=1; break;
}
case LOW_PASS3: {
kl=16;
a1=1; a2=2; a3=1;
b1=2; b2=4; b3=2;
c1=1; c2=2; c3=1; break;
}
case LOW_PASS4: {
kl=5;
a1=0; a2=1; a3=0;
b1=1; b2=1; b3=1;
c1=0; c2=1; c3=0; break;
}
case LAPLACE_ORIGINAL: {
kl=1;
a1=-1; a2=-1; a3=-1;
b1=-1; b2=9; b3=-1;
c1=-1; c2=-1; c3=-1; break;
}
case LAPLACE: {
kl=1;
a1=1; a2=-2; a3=1;
b1=-2; b2=5; b3=-2;
c1=1; c2=-2; c3=1; break;
}
case LAPLACE_EDGE: {
kl=1;
a1=-1; a2=-1; a3=-1;
b1=-1; b2=8; b3=-1;
c1=-1; c2=-1; c3=-1; break;
}
case FOCUS: {
kl=1;
a1= 0; a2=-1; a3= 0;
b1=-1; b2= 5; b3=-1;
c1= 0; c2=-1; c3= 0; break;
}



Relief filter

Maxcolor is the maximum greyscale of the image. This is a very fancy filter. All new pixels have values near the (maxcolor/2) and for better results in viewing it is good to create a histogram equalization for the new image.



for j = 0 to height - 1
  for i = 0 to width - 1
  newcolor = RC(i, j) + ((maxcolor / 2) - RC(i - 2, j - 2));
newcolor = abs(newcolor); {hate negative values !!!}
if (newcolor > 255)newcolor = 255; {not greater than 255}
{do whatever you want here eg put new pixel color in a buffer}
end i
end j

Panel showing Enabled/Disabled in Children

Problem/Question/Abstract:

Often you disable all Controls within a Panel by simply setting the Enabled Property of the Panel. It works, however the user does not get any visual feedback.

Answer:

The following component code simply extends the Delphi Panel to properly show the Enabled State (True/False) within its children.

Extending the control is very simple. All  we need to do is to override and extend the default SetEnabled procedure. The new procedure will first call the original version and then rotate through all children and copy the state.

There is one drawback although, if there is a disabled control (XYZ) on the panel, you then disable the panel and enbale it again, the control (XYZ) will be enabled, too.

Anyway, often it is very useful. Here you go:

unit uRealPanel;

interface

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

type
  TRealPanel = class(TPanel)
  private
  protected
    procedure SetEnabled(Value: Boolean); override;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('gate(n)etwork', [TRealPanel]);
end;

{ TRealPanel }

procedure TRealPanel.SetEnabled(Value: Boolean);
var
  I: Integer;
begin
  inherited;
  if csDesigning in ComponentState then
    Exit;
  for I := 0 to Pred(ControlCount) do
    if Controls[I] is TWinControl then
      (Controls[I] as TWinControl).Enabled := Value;
end;

end.

How to search for a pattern in a file

Problem/Question/Abstract:

I need to locate a pattern in a file (both text and binary) - just like the Pos function does with the strings. Preferably, it should deal with FileStream. Straightforward solution first seemed kind of expensive - that is to just plainly go through the stream comparing patterns on every step.

Answer:

Solve 1:

You can do it that way but it is much faster to load chunks of data into a sizeable buffer and do the search in the buffer. Here is an example:

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: Word;
  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 2:

procedure TForm1.Button1Click(Sender: TObject);
var
  s: string;
  hFile: THandle;
  hFileMapObj: THandle;
  pSharedBuf: Pointer;
  Time0: Integer;
  p: PChar;
begin
  if not OpenDialog1.Execute then
    Exit;
  s := InputBox('Find', 'Match', '');
  Time0 := GetTickCount;
  hfile := 0;
  hFileMapObj := 0;
  pSharedBuf := nil;
  try
    hFile := FileOpen(OpenDialog1.FileName, fmOpenRead);
    Win32Check(hFileMapObj <> INVALID_HANDLE_VALUE);
    hFileMapObj := CreateFileMapping(hFile, nil, PAGE_READONLY, 0, 0, nil);
    Win32Check(hFileMapObj <> 0);
    pSharedBuf := MapViewOfFile(hFileMapObj, FILE_MAP_READ, 0, 0, 0);
    Win32Check(pSharedBuf <> nil);
    P := StrPos(PChar(pSharedBuf), PChar(s));
  finally
    if pSharedBuf <> nil then
      UnMapViewOfFile(pSharedBuf);
    if hFileMapObj <> 0 then
      CloseHandle(hFileMapObj);
    if hFile <> 0 then
      CloseHandle(hFile);
  end;
  if P = nil then
    Caption := Format('Not found, ticks=%d', [GetTickCount - Time0])
  else
    Caption := Format('Found it at pos %d, ticks=%d', [Integer(P - PChar(pSharedBuf)),
      GetTickCount - Time0]);
end;

How to centre a MessageBox on a form

Problem/Question/Abstract:

How to centre a MessageBox on a form

Answer:

{ ... }
msgCaption: PChar; {var to hold caption}
{ ... }

procedure pmChangeMessageBox(var Msg: TMessage); message WM_USER + 1024;

procedure TForm1.pmChangeMessageBox(var Msg: TMessage);
var
  MBHwnd: THandle;
  MBRect: TRect;
  x, y, w, h: integer;
begin
  MBHwnd := FindWindow(MAKEINTRESOURCE(WC_DIALOG), msgCaption);
  if (MBHwnd <> 0) then
  begin
    GetWindowRect(MBHWnd, MBRect);
    w := MBRect.Right - MBRect.Left;
    h := MBRect.Bottom - MBRect.Top;
    {center horizontal}
    x := Form1.Left + ((Form1.Width - w) div 2);
    {keep on screen}
    if x < 0 then
      x := 0
    else if x + w > Screen.Width then
      x := Screen.Width - w;
    {center vertical}
    y := Form1.Top + ((Form1.Height - h) div 2);
    {keep on screen}
    if y < 0 then
      y := 0
    else if y + h > Screen.Height then
      y := Screen.Height - h;
    SetWindowPos(MBHWnd, 0, x, y, 0, 0, SWP_NOACTIVATE or SWP_NOSIZE or
      SWP_NOZORDER);
  end;
end;

Example use:

PostMessage(Handle, WM_USER + 1024, 0, 0);
msgCaption := 'Confirm';
MessageBox(Handle, 'Save changes?', msgCaption, MB_ICONQUESTION or MB_YESNOCANCEL);

How to select all rows in a TDBGrid programmatically

Problem/Question/Abstract:

Can someone tell me how I can select all rows in a DBGrid in code by clicking a button?

Answer:

Something like this should work (untested):

procedure SelectAllinGrid(grid: TDBGrid);
var
  saveBK: TBookmark;
  i: integer;
begin
  with grid.DataSource.Dataset do
  begin
    for i := 0 to SelectedList.Count - 1 do
      FreeBookmark(SelectedList.Items[i]);
    SelectedList.Clear;
    saveBK := GetBookmark; { Save current record position }
    DisableControls;
    try
      First;
      while (not Eof) do
      begin
        SelectedList.Add(GetBookmark);
        Next;
      end;
    finally
      GotoBookmark(saveBK); { Restore original record position}
      Freebookmark(saveBK);
      EnableControls;
    end;
  end
end;

Implement a Win32 look and feel "Browse for Folder" directory picker

Problem/Question/Abstract:

I'm looking for code that will let me implement a Win32 look and feel "Browse for Folder" directory picker. Like the one used in Project Options - > Directories/ Conditionals interface.

Answer:

procedure TMainForm.BrowseFolderActionExecute(Sender: TObject);
var
  pidl, pidlSelected: PItemIDList;
  bi: TBrowseInfo;
  szDirName: array[0..260] of AnsiChar;
begin
  {Get the root PIDL of the network neighborhood tree}
  if SHGetSpecialFolderLocation(Handle, CSIDL_DESKTOP, pidl) = NOERROR then
  begin
    {Populate a BROWSEINFO structure}
    bi.hwndOwner := Handle;
    bi.pidlRoot := pidl;
    bi.pszDisplayName := szDirName;
    bi.lpszTitle := 'Select directory';
    bi.ulFlags := BIF_RETURNONLYFSDIRS;
    bi.lpfn := nil;
    bi.lParam := 0;
    bi.iImage := -1;
    {Display the "Browse For Folder" dialog box}
    pidlSelected := SHBrowseForFolder(bi);
    {NULL indicates that Cancel was selected from the dialog box}
    if pidlSelected < > nil then
    begin
      SHGetPathFromIDList(pidlSelected, szDirName);
      ShowMessage(szDirName);
      {Release the PIDL of the computer name}
      CoTaskMemFree(pidlSelected);
    end;
    {Release the PIDL of the network neighborhood tree}
    CoTaskMemFree(pidl);
  end;
end;

Code Insight

Problem/Question/Abstract:

Code Insight

Answer:

Here's a list of the new features in Delphi 3 which are collected under the name 'Code Insight':
Code Insight
Shortcut
Cancel Key
Extra
Code Completion
Ctrl Space
Esc
Can be sorted using right click in popup list.
Incremental search, up and down arrow, home and end keys for navigation.
Respects the visibility of the declared members of the class.
Code Parameters
Ctrl-Shift-Space
Esc

Argument Value List
Ctrl Space

Can be sorted using right click in popup list.
Must be specifically requested.
Displays constants, functions, and variables that are consistent with the argument required by the expression.
Code Templates
Ctrl J

if you type the short cut for the template and then Ctrl J you can skip the popup window.

The Code templates are stored in a ASCII file delphi32.dci which is stored in the Delphi\Bin Folder if you want to enter your templates in manually.

How to load a DLL from a resource file and save it to disk

Problem/Question/Abstract:

Is it possible to copy a DLL into my own executable using the IDE only for exporting it after in my program? For example, I create an executable Test.exe and in the IDE I want to attach a resource that contains the DLL. And when my program is running I can export this resource to put a file on my hard disk. Is there a way to do that?

Answer:

Create a file called "mydllres.rc". Edit it and insert the line MYDLL RT_RCDATA "Mydll.dll". Then call the Borland compiler for resouces (you may need to adjust the paths) with BRCC32 mydllres.rc .

This will produce a output file called mydllres.res. Under the implementation header in the main unit add the following: {$R mydllres.res}. This will add the resource to the project.

The following procedure will save it to a file:

procedure savedll;
var
  myres: TResourceStream;
begin
  myres := TResourceStream.Create(hInstance, PChar('MYDLL'), RT_RCDATA);
  myres.SaveToFile(ExtractFilepath(Application.exename) + 'mydll.dll');
  myres.destroy;
end;

Add Interfaces to a List

Problem/Question/Abstract:

It's more efficient to control Interfaces in a List and ask with QueryInterface() which objects support an Interface

Answer:

First we need some Interfaces (the same goes also in Kylix, pure Interfaces are independent from COM, it's a feature of ObjectPascal):

type
  IKiss = interface(IUnknown)
    ['{19A231B1-269F-45A2-85F1-6D8A629CC53F}']
    procedure kiss; stdcall;
  end;

  ISpeak = interface(IUnknown)
    ['{B7F6F015-88A6-47AC-9176-87B6E313962D}']
    procedure sayHello; stdcall;
  end;

Second the interfaces must be implemented:

TDog = class(TInterfacedObject, ISpeak)
public
  procedure sayHello; stdcall;
end;

TFrench = class(TInterfacedObject, ISpeak, IKiss)
public
  procedure kiss; stdcall;
  procedure sayHello; stdcall;
end;

TEnglish = class(TInterfacedObject, ISpeak)
public
  procedure sayHello; stdcall;
end;

e.g. the dog with

procedure TDog.sayHello;
begin
  showmessage('dog is barking wauwau');
end;

Now we add the instances of the interface in the list, using the defined type TInterfaceList so we are able to ask with QueryInterface if an object supports an Interface, in our example if a dog as an object can kiss or just sayhello:

procedure TForm1.btnCollectClick(Sender: TObject);
var
  collection: TInterfaceList;
  i: Integer;
  aObjspeak: ISpeak;
  aObjKiss: IKiss;
begin
  collection := TinterfaceList.create;
  try
    with collection do
    begin
      add(TEnglish.create);
      add(TFrench.create);
      add(TDog.create);
    end;
    for i := 0 to collection.count - 1 do
    begin
      aObjSpeak := collection[i] as ISpeak; //TFrench, TEnglish, TDog
      if aObjSpeak <> nil then
        aObjSpeak.sayHello;
      collection[i].queryInterface(IKiss, aObjKiss); //only TFrench
      if aObjKiss <> nil then
        aObjKiss.kiss;
    end;
  finally
    collection.free;
  end;
end;

RGB and HSV conversions

Problem/Question/Abstract:

Sometimes it is best to deal with colors as HSV rather than RGB. The artical explains a little bit what HSV is and includes source for converting between the two.

Answer:

HSV is Hue, Saturation, and Value.

HSV:

Hard to explain without a picture so you will have to use your imagination...

Hue:

Draw a circle in your head, the circle is 0 to 360 degrees (or 359 :-) ).  On the outer edge of the circle, place a red dot at 0 degrees, a green dot at 120 degrees and a blue dot at 240 degrees.  Those are the main points.  The other points between these 3 colors are interpolated... for example yellow is between red and green at 60 degrees (equal red + green = yellow), cyan is between green and blue at 180 degrees, magenta is between blue and red at 300 degrees.  Then between yellow and red is another and you keep breaking it down until your circle is full.  The outer edge from 0 to 360 degrees is the hue.

Saturation:

The center of the circle is white.  The color blends with the other colors to white as you go from the outside of the circle to the center.  The outer egde is saturation of 1 and the center is 0 (white).

Value:

Value is simply the intensity of the color.

You already know RGB I assume since you are a programmer.

I played around with my digital camera and took a picture of my brown computer chair.  I created an algorithm that turned my chair green.  It was easy with HSV, I simply used photoshop to see what the hue was of the chair.  Then I rotated the hue so that the chair was in the green range.  Boom, the chair was green.

Here they are:

http://www.eggcentric.com/eimages/greenchair.jpg
http://www.eggcentric.com/eimages/brownchair.jpg

Here is the source of procedures to convert between RGB and HSV and back again.  You can also download it from the link.

unit RGBHSV;
{
  William Egge, public@eggcentric.com
  http://www.eggcentric.com

  This unit converts between RGB and HSV color models.

  procedure HSVToRGB(const H, S, V: Single; out R, G, B: Single);
    in
    H = Hue.  Range is from 0..1.  0.5 = 180 degrees, 1 = 360. or H < 0 for gray
    S = Satration.  Range is 0..1 where 0 is white and 1 is no saturation.
    V = Value.  Range is 0..255

    out
    R = 0..255
    G = 0..255
    B = 0..255

    If H < 0 then the result is a gray value R=V, G=V, B=V

  procedure RGBToHSV(const R, G, B: Single; out H, S, V: Single);
    in
    R = 0..255
    G = 0..255
    B = 0..255

    out
    H = Hue. -1 for grey scale or range 0..1.  0..1 represents 0..360 degrees
    S = Saturation. Range = 0..1. 0 = white, 1 = no saturation.
    V = Value or intensity. Range 0..255
}

interface
uses
  Math;

procedure HSVToRGB(const H, S, V: Single; out R, G, B: Single);
procedure RGBToHSV(const R, G, B: Single; out H, S, V: Single);

implementation

procedure HSVToRGB(const H, S, V: Single; out R, G, B: Single);
const
  SectionSize = 60 / 360;
var
  Section: Single;
  SectionIndex: Integer;
  f: single;
  p, q, t: Single;
begin
  if H < 0 then
  begin
    R := V;
    G := R;
    B := R;
  end
  else
  begin
    Section := H / SectionSize;
    SectionIndex := Floor(Section);
    f := Section - SectionIndex;
    p := V * (1 - S);
    q := V * (1 - S * f);
    t := V * (1 - S * (1 - f));
    case SectionIndex of
      0:
        begin
          R := V;
          G := t;
          B := p;
        end;
      1:
        begin
          R := q;
          G := V;
          B := p;
        end;
      2:
        begin
          R := p;
          G := V;
          B := t;
        end;
      3:
        begin
          R := p;
          G := q;
          B := V;
        end;
      4:
        begin
          R := t;
          G := p;
          B := V;
        end;
    else
      R := V;
      G := p;
      B := q;
    end;
  end;
end;

procedure RGBToHSV(const R, G, B: Single; out H, S, V: Single);
var
  RGB: array[0..2] of Single;
  MinIndex, MaxIndex: Integer;
  Range: Single;
begin
  RGB[0] := R;
  RGB[1] := G;
  RGB[2] := B;

  MinIndex := 0;
  if G < R then
    MinIndex := 1;

  if B < RGB[MinIndex] then
    MinIndex := 2;

  MaxIndex := 0;
  if G > R then
    MaxIndex := 1;

  if B > RGB[MaxIndex] then
    MaxIndex := 2;

  Range := RGB[MaxIndex] - RGB[MinIndex];

  // Check for a gray level
  if Range = 0 then
  begin
    H := -1; // Can't determine on greys, so set to -1
    S := 0; // Gray is at the center;
    V := R; // could choose R, G, or B because they are all the same value.
  end
  else
  begin
    case MaxIndex of
      0: H := (G - B) / Range;
      1: H := 2 + (B - R) / Range;
      2: H := 4 + (R - G) / Range;
    end;
    S := Range / RGB[MaxIndex];
    V := RGB[MaxIndex];
    H := H * (1 / 6);
    if H < 0 then
      H := 1 + H;
  end;
end;

end.


Component Download: http://www.eggcentric.com/download/rgbhsv.zip

Insert text at bookmark positions of a Word document

Problem/Question/Abstract:

How to insert text at bookmark positions of a Word document

Answer:

procedure WordBookInsert(v: OleVariant; sgoto, sdata: string);
begin
  try
    {make sure we have passed a word.application level variant}
    if not varisempty(v) then
    begin
      V.Selection.goto(What := wdGoToBookmark, Name := sgoto);
      V.Selection.TypeText(Text := SDATA);
    end;
  except
    {trap OLE errors and display message if it fails}
    on E: sysutils.exception do
    begin
      showmessage(e.message);
    end;
  end;
end;