Prenventing the user from positioning a form outside the screen work area

Problem/Question/Abstract:

How can I prevent the user from moving the form outside screen boundaries to guarantee the form is always visible inside the screen work area?

Answer:

We can know if a form has resized with the Resize event (OnResize property), but how do we know if a form has moved? Simply by capturing the WM_MOVE Windows message.

In the message event we call "inherited" to let the ancestors of TForm process the message. This will update the Left and Top properties that we can use along with Width and Height to see if the form is placed within the limits of the screen's work area (the portion of the screen not used by the system taskbar or by application desktop toolbars) and move it if not.

procedure TfrmMain.OnMove(var Msg: TWMMove);
var
  WorkArea: TRect;
begin
  inherited;
  if SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0) then
  begin
    if Left < WorkArea.Left then
      Left := WorkArea.Left
    else if Left + Width > WorkArea.Right then
      Left := WorkArea.Right - Width;
    if Top < WorkArea.Top then
      Top := WorkArea.Top
    else if Top + Height > WorkArea.Bottom then
      Top := WorkArea.Bottom - Height;
  end;
end;

The full source code of this example is available for download:

http://www.latiumsoftware.com/download/p0020.zip


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

How to strip numbers from an alphanumeric string

Problem/Question/Abstract:

How to strip numbers from an alphanumeric string

Answer:

function.StripNonNums(AText: string): string;
var
  i: integer;
  r: integer;
begin
  SetLength(Result, Length(AText));
  r := 1;
  for i := 1 to Length(AText) do
    if AText[i] in ['0'..'9'] then
    begin
      Result[r] := AText[i];
      Inc(r);
    end;
  SetLength(Result, r);
end;

How to blend two TBitmap's (2)

Problem/Question/Abstract:

I need to draw semi-transparent rectangles to highlight areas over an image. Any clues as to how to do this?

Answer:

This is particularly neat to use if you want to place text on a bitmap and guarantee that the text is readable without completely obscuring the image underneath; simply tint the area underneath the text with clBlack, then draw clWhite text on top (with Canvas.Brush.Style = bsClear).

Note that the TintBitmapRect procedure below requires that you're using pf32Bit bitmaps. It can be modified to work with other pixel formats, but that is an exercise for the reader.

{TColors have color components in blue-green-red order. 32-bit
bitmap pixels have color components in red-green-blue order. This function
allows conversion between the two orders.}

function SwapRedBlue(const Color: TColor): TColor;
begin
  Result := (Color and $FF0000) shr 16 or (Color and $00FF00) or (Color and $0000FF) shl 16;
end;

{Tint an arbitrary rectangular area of a bitmap with an arbitrary color}

procedure TintBitmapRect(const Bitmap: TBitmap; const Rect: TRect; const Color: TColor);
var
  Pixel: PLongWord;
  I: Integer;
  J: Integer;
  Color2: LongWord;
const
  Mask: LongWord = $00FEFEFE;
begin
  Assert(Bitmap.PixelFormat = pf32Bit);
  Color2 := SwapRedBlue(Color) and Mask;
  for I := Rect.Top to (Rect.Bottom - 1) do
  begin
    Pixel := Bitmap.ScanLine[I];
    Inc(Pixel, Rect.Left);
    for J := Rect.Left to (Rect.Right - 1) do
    begin
      Pixel^ := ((Pixel^ and Mask) + Color2) shr 1;
      Inc(Pixel);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  with Image1.Picture do
  begin
    Bitmap.PixelFormat := pf32Bit;
    TintBitmapRect(Bitmap, Rect(Bitmap.Width div 4, Bitmap.Height div 4,
      Bitmap.Width - Bitmap.Width div 4,
      Bitmap.Height - Bitmap.Height div 4), clRed);
  end;
end;

Disable the select and copy to clipboard capabilities in a TMemo

Problem/Question/Abstract:

How to disable the select and copy to clipboard capabilities in a TMemo

Answer:

Solve 1:

Use OnKeyDown and OnKeyPress handlers for the memo to catch the shortcuts for copy and cut and set key := 0 for them. Provide a handler for the OnContextMenu event in which you set Handled to true to prevent the default popup menu from coming up. That should do it.

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if ssCtrl in Shift then
    case Key of
      Ord('C'), Ord('X'), VK_INSERT: Key := 0;
    end
  else if (ssShift in Shift) and (Key = VK_DELETE) then
    Key := 0;
end;

procedure TForm1.Memo1ContextPopup(Sender: TObject; MousePos: TPoint;
  var Handled: Boolean);
begin
  Handled := true;
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
  if Key in [^C, ^X] then
    Key := #0;
end;


Solve 2:

The easiest way would be to set the Enabled property of the Memo (or Edit) control to False so that the control cannot receive events. This drawback to this method is the user won't be able to scroll the text and the disabled text looks bad.

In order to prevent the user from writing in the memo, we set its ReadOnly property to True.

To prevent the user from selecting text with the mouse, we generate the handler of the MouseMove event of the control and write the following code:

procedure TForm1.Memo1MouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  if ssLeft in Shift then
    Memo1.SelLength := 0;
end;

In order to prevent the user from performing a selection using the keyboard, we generate the handlers of the KeyDown and KeyUp events, assigning the OnKeyDown and OnKeyUp properties to the same procedure:

procedure TForm1.Memo1KeyDownUp(Sender: TObject;
  var Key: Word; Shift: TShiftState);
begin
  if (ssShift in Shift) and (Key in [VK_LEFT, VK_RIGHT, VK_UP,
    VK_DOWN, VK_PRIOR, VK_NEXT, VK_HOME, VK_END]) then
    Key := 0;
end;

How to eject and close a CD-ROM drive

Problem/Question/Abstract:

How to eject and close a CD-ROM drive

Answer:

Solve 1:

To open the CD-ROM:


mciSendString('Set cdaudio door open wait', nil, 0, handle);


To close the CD-ROM:


mciSendString('Set cdaudio door closed wait', nil, 0, handle);


Remember to include the MMSystem unit in your uses clause. Also note that you will get a Blue Screen on certain hardware, if you use this code.


Solve 2:

function CdClose(const Value: char): integer;
var
  strCommand: string;
  strError: array[0..MAX_PATH] of char;
begin
  strCommand := 'open ' + Value + ': type cdaudio alias xxx';
  MCISendString(PChar(strCommand), nil, 0, 0);
  strCommand := 'set xxx door closed';
  Result := MCISendString(PChar(strCommand), nil, 0, 0);
  strCommand := 'close xxx';
  MCISendString(PChar(strCommand), nil, 0, 0);
  if Result <> 0 then
    MCIGetErrorString(Result, strError, 255);
  MessageDlg(strError, mtError, [mbOK], 0);
end;

function CdOpen(const Value: char): integer;
var
  strCommand: string;
  strError: array[0..MAX_PATH] of char;
begin
  strCommand := 'open ' + Value + ': type cdaudio alias xxx';
  MCISendString(PChar(strCommand), nil, 0, 0);
  strCommand := 'set xxx door open';
  Result := MCISendString(PChar(strCommand), nil, 0, 0);
  strCommand := 'close xxx';
  MCISendString(PChar(strCommand), nil, 0, 0);
  if Result <> 0 then
    MCIGetErrorString(Result, strError, 255);
  MessageDlg(strError, mtError, [mbOK], 0);
end;


Solve 3:

procedure mcicheck(R: Cardinal);
var
  S: array[0..1023] of Char;
begin
  if R = 0 then
    exit;
  mciGetErrorString(R, S, SizeOf(S) - 1);
  raise Exception.Create(S);
end;

procedure MoveCDDoor(const Drive: string; Open: Boolean);
const
  Direction: array[Boolean] of Cardinal = (MCI_SET_DOOR_CLOSED, MCI_SET_DOOR_OPEN);
var
  OP: TMCI_Open_Parms;
  id: Cardinal;
begin
  Fillchar(OP, SizeOf(OP), 0);
  OP.lpstrDeviceType := PChar(MCI_DEVTYPE_CD_AUDIO);
  OP.lpstrElementName := PChar(Drive);
  mcicheck(mciSendCommand(0, MCI_OPEN, MCI_WAIT or MCI_OPEN_TYPE or
    MCI_OPEN_TYPE_ID or MCI_OPEN_ELEMENT, Cardinal(@OP)));
  id := OP.wDeviceID;
  try
    mcicheck(mciSendCommand(id, MCI_SET, MCI_WAIT or Direction[Open], 0));
  finally
    mcicheck(mciSendCommand(id, MCI_CLOSE, MCI_WAIT, 0));
  end;
end;


Solve 4:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
  private
    { Private declarations }
    procedure WMDeviceChange(var Msg: TMessage); message WM_DEVICECHANGE;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

const
  DBT_DEVICEARRIVAL = $8000;
  DBT_DEVICEREMOVECOMPLETE = $8004;
  DBT_DEVTYP_VOLUME = 2; {logical volume}

type
  _DEV_BROADCAST_VOLUME = record
    dbcv_size,
      dbcv_devicetype,
      dbcv_reserved,
      dbcv_unitmask: DWORD;
    dbcv_flags: WORD;
  end;
  TDevBroadcastVolume = _DEV_BROADCAST_VOLUME;
  PDevBroadcastVolume = ^TDevBroadcastVolume;

procedure TForm1.WMDeviceChange(var Msg: TMessage);
var
  Disques: set of 0..25;
  nDisque: Integer;
  sMsg: string;
  Volume: PDevBroadcastVolume;
begin
  inherited;
  case Msg.WParam of
    DBT_DEVICEARRIVAL:
      sMsg := 'Disk inserted :';
    DBT_DEVICEREMOVECOMPLETE:
      sMsg := 'Disk ejected :';
  else
    Exit;
  end;
  Volume := PDevBroadcastVolume(Msg.LParam);
  if Volume^.dbcv_devicetype <> DBT_DEVTYP_VOLUME then
    Exit;
  DWORD(Disques) := Volume^.dbcv_unitmask;
  for nDisque := 0 to 25 do
  begin
    if not (nDisque in Disques) then
      Continue;
    sMsg := sMsg + #13 + Char(nDisque + Ord('A')) + ':\';
  end;
  ShowMessage(sMsg);
end;

end.

How to retrieve the icons of a MessageBox

Problem/Question/Abstract:

How can I retrieve the MessageBox images (MB_ICONINFORMATION, MB_ICONERROR etc.) for use in a TListView?

Answer:

You can use the LoadIcon API to get the images:

procedure TForm1.Button1Click(Sender: TObject);
const
  Size = 6;
  IconArray: array[0..Size - 1] of PChar = (IDI_APPLICATION, IDI_ASTERISK,
    IDI_EXCLAMATION,
    IDI_HAND, IDI_QUESTION, IDI_WINLOGO);
begin
  Image1.Picture.Icon.Handle := LoadIcon(0, IconArray[5]);
end;

How to set the private directory to the applications' subdirectory

Problem/Question/Abstract:

I'm wondering how one can set the privatedir. I don't mean in my program, but just so I know where the temp files go. Does the BDEcfg program do that? If so, where? I'm using BDE 4.0

Answer:

Your program sets the private directory, it's not in the cfg. If you don't set it in your program it defaults to the apps directory. If your app resides on a server in a multiple use environment this is not what you want. I add the following code to all my apps (I also limit my apps to one instance):

s := ' C:\AZPC\PRIVATE\' + ChangeFileExt(ExtractFileName(Application.ExeName), '.');
if not DirectoryExists(s) then
begin
  ForceDirectories(s);
  if not DirectoryExists(s) then
    ShowMessage('Unable to find and/or create the ' + #10 + s + #10 + ' directory '
      + #10 + ' the program will run, but not be fully functional.');
end;
Session.PrivateDir := s;

This sets the private directory to the exe name subdirectory on the C: drive.

More than one "NETDIR" for the BDE on one computer

Problem/Question/Abstract:

I want wy app to have its own 'NETDIR' setting so it won't conflict with other apps installed on the same computer.
Is it possible to use several settings for 'NETDIR' for BDE on the same computer?

Answer:

Yes. Every BDE session can have a different network control file location. The default 'NETDIR' setting in the BDE Admin should always point to the same physical location, but an application can change the location in it's BDE session by setting Session.NetFileDir before a BDE session is opened.

Note that you may have some difficulties while debugging if you don't also set the default 'NETDIR' on your development machine to the same as your program's.

Note: BDE sessions with different Session. NetFileDir cannot access the same tables concurrently.

Setting the Session. NetFileDir in your application, (or suite of applications) can isolate it from an incorrectly set default 'NETDIR'. I usually set NetFileDir to a location relative to the shared application .EXE file.

How to dynamically retrieve class information

Problem/Question/Abstract:

How to dynamically retrieve class information

Answer:

This will create an instance of the class specified in the GetClass call:

procedure TForm1.FormCreate(Sender: TObject);
begin
  {This only works for classes registered using RegisterClass}
  RegisterClasses([TButton, TForm]);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  CRef: TPersistentClass;
  PTI: PTypeInfo;
  AControl: TControl;
begin
  CRef := GetClass('TButton');
  if CRef <> nil then
  begin
    AControl := TControl(TControlClass(CRef).Create(Self));
    with AControl do
    begin
      Parent := Self;
      Width := 50;
      Height := 30;
    end;
    Inc(Id);
  end
  else
    MessageDlg('No such class', mtWarning, [mbOk], 0);
end;

How to retrieve version info of system DLL's

Problem/Question/Abstract:

Is there a way to read the Language ID of a file first, and then use it to construct the LocaleString?

Answer:

function GetFileTranslation(const Filename: string; FullName: Boolean = False):
  string;
var
  VerInfSize, Sz: Cardinal;
  LangID: Pointer;
  VerInfo: Pointer;
  Buf: array[0..255] of char;
begin
  Result := '';
  if FileExists(Filename) then
  begin
    VerInfSize := GetFileVersionInfoSize(PCHAR(Filename), Sz);
    if VerInfSize > 0 then
    begin
      VerInfo := AllocMem(VerInfSize);
      try
        GetFileVersionInfo(PCHAR(Filename), 0, VerInfSize, VerInfo);
        VerQueryValue(VerInfo, '\VarFileInfo\Translation', LangID, Sz);
        if LangID < > nil then
          case Ord(FullName) of
            0:
              Result := IntToHex(MakeLong(HiWord(Longint(LangID^)),
                LoWord(Longint(LangID^))), 8);
            1:
              if VerLanguageName(DWORD(LangID^), Buf, SizeOf(Buf)) > 0 then
                Result := Buf;
          end;
      finally
        FreeMem(VerInfo);
      end;
    end;
  end;
end;

Pass False as the second parameter to construct this string. Pass True to get the language name.

How to change the scrollbar position in a non-focused TMemo

Problem/Question/Abstract:

How to change the scrollbar position in a non-focused TMemo

Answer:

You'll have KeyPreview set true of course then:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  case Key of
    VK_Down: Memo1.Perform(Messages.EM_LINESCROLL, 0, 1);
    VK_UP: Memo1.Perform(Messages.EM_LINESCROLL, 0, -1);
    {and if HorzScrollbars are also used}
    VK_Left: Memo1.Perform(Messages.EM_LINESCROLL, -1, 0);
    VK_Right: Memo1.Perform(Messages.EM_LINESCROLL, 1, 0);
  end;
  {But where is the focus when you are doing this? Do you want the keystroke passed
  elsewhere? If not then}
  Key := 0;
end;

Force a TForm and all of its children to repaint

Problem/Question/Abstract:

I'm little confused about the Invalidate / Repaint methods. I need a TForm and all its child components (panels, frames/ forms) to be repainted at once. If I use Repaint, the child windows don't seem to be repainted. Is that ok? How can I repaint all controls at once?

Answer:

Here is one which will force the Form to repaint (and all its children)

RedrawWindow(Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN);

Get all classes registered on a form

Problem/Question/Abstract:

How can I get all classes that are currently registered in my application? Example: If I have a form with no components on it and I do something like ReadComponentRes and that *.dfm has a TEdit in it, I get an exception that TEdit is of unknown class. If I put one TEdit on that form and do ReadComponentRes again, everything goes OK. So, I guess TEdit is registered somewhere. Now I would like to find all registered classes so I would know which classes I can use in my *.dfm.

Answer:

There is no way to get at classes registered via RegisterClasses, since the list holding these is private to the classes unit. You can get at the classes registered on a form, however, since those use a table connected to the form classes class record. The following is based on some spelunking in the classes unit:

{defined in classes.pas}
type
  PFieldClassTable = ^TFieldClassTable;
  TFieldClassTable = packed record
    Count: Smallint;
    Classes: array[0..8191] of ^TPersistentClass;
  end;

function GetFieldClassTable(AClass: TClass): PFieldClassTable; assembler;
asm
  MOV EAX, [EAX].vmtFieldTable
  OR EAX, EAX
  JE @@1
  MOV EAX, [EAX + 2].Integer
  @@1:
end;
{end of quote from classes.pas}

procedure TForm1.Button1Click(Sender: TObject);

  procedure Display(const S: string);
  begin
    memo1.lines.add(S);
  end;

var
  pFCT: PFieldClassTable;
  aClass: TClass;
  i: SmallInt;
begin
  memo1.clear;
  aClass := Classtype;
  while aClass < > TPersistent do
  begin
    Display('Registered classes for class ' + aClass.Classname);
    pFCT := GetFieldClasstable(aClass);
    if not Assigned(pFCT) then
      Display('  No classes registered')
    else
    begin
      Display(format('  %d classes registered', [pFCT^.Count]));
      for i := 0 to pFCT^.Count - 1 do
        Display('  ' + pFCT^.Classes[i]^.ClassName);
    end;
    aClass := aClass.ClassParent;
  end;
end;

Introductory Principles of Indexed Searching

Problem/Question/Abstract:

Describe the principles of an Indexed search engine (like google). How this works when a lot of text information is compressed into an index - so that a search can be done within very short time.

Answer:

Introduction

There are really two main ways to search a large collection of text documents.  The simplest method would be to load each document and scan through it for the search terms, this would be referred to as a full text scan.  The second, much faster method is to create an index and then search the index.  An index is a list of terms found in a document or set of documents.  Each word only appears once per document so it is much shorter then the original document.  

Creating an index

Finding the words
In order to create an index you must first parse the document.  Parsing, is the process of picking out the individual tokens (terms or words) in a piece of text.  A parser is a type of state machine.  There are many existing parsing routines available.  "The Tomes of Delphi Algorithms and Data Structures" by Julian Bucknall contains many very good parsers.  An example.

A simple parser would scan through a string of text, starting at the beginning, looking at each character.  If it is a letter or number then it is part of a word, if it is white space or punctuation then it is a separator.  Each word is added to a list (i.e. TStringList) in the order it is found in the document.  Typically each word is converted to the same case (upper or lower).  

It is really important to consider what you are indexing and how your index will be used when creating your index and parsing.  For example if you are parsing HTML then you want to exclude most tags (with the obvious exception of META tags, which are handled specially).  Other times you might only want to index summery information about each document.  

Indexing the Words
Now that we have a parsed token list we need to index it.  The simplest index is just a list of each word found in a document, and a reference to the document.  This reference may be a URL, a document name or any other unique identifier (a GUID or a foreign key to another table describing the document).  A more complex index may include the number of times the word is found in the document or a ranking for where it is in the document (in the title, keyword section, first paragraph, middle, last, etc.)  This additional information stored with each word is part of what differentiates one search engine's performance from another.

Many times certain words are left out.  These are called stop words.  Stop words are common words, words that will not be searched on, or words that will not enhance the meaning of a search.  An example of stop words includes "THE, A, AN, AND, IF, BUT", words with numbers in them, or anything else you want to filter out.  Selecting stop words is another point of separation of performance.  

Some web search engines used to leave out words like "HTML" or "WEB" because they were so common while other search engines would include every word.  Other search engines start with a dictionary list and only index words found in that dictionary list.  This leads to trouble when you are indexing names, technical terms or anything else not found in your original dictionary.  

One time I was creating a search engine for a collection newsgroup articles.  I discovered that there was UUEncoded (similar to MIME or Base64) binaries in the articles.  This resulted in my parser finding words that were hundreds of characters long and total gibberish.  I decided to omit any word longer then 50 characters or shorter then 4.  Making the choices about what to include and what to omit is an important decision, and will vary based on what content you are indexing.

So here is an example table structure for your index:

Table: WordList

Document: Number (foreign key to Documents table)
Word : String[20] (if our longest word is 20 characters)
Count : Number (how many times the word is found)

The primary key would be a compound of Document and Word since each word is listed once per document.

Table: Documents

Document : Number(primary key index)
Title : string (title of document)
Location : string (URL or full filename and path)

Optionally you could include the entire document as a blob in this table.  You could also have other tables that lists terms (from the meta section of the document) or include authors.  Again this design choice depends on the type of documents you are indexing and the purpose of your search engine.

Searching Your Index

Once all the indexes are stored in a database you need to be able to search the index for a document.  A simple SQL statement to search for a document that contains a single word could look like this:

SELECT *
FROM WordList
WHERE Word = :v_search_term
ORDER BY Count DESC

This returns all documents containing your single search term and they are ordered by the number of times the word is found.  If you want to use SQL then to search on multiple terms involves an join for each term.  Instead you could retrieve a list for each term and then merge them manually.  This is where you would support AND, OR or NOT key words.  

If you want to allow phrase searching then you could search for each word in the phrase and then search those documents for the phrase.  The same technique could be used for the NEAR key word.  There are other more advanced techniques to do this that are much quicker, but they are beyond the scope of this document.

Once the hits are found and ranked then display the title of each document, possibly a summary or the context of the hits, and provide a way for your user to reach the document.

Variations

One thing Google does a little differently is they look at how pages are linked.  This works really well with the hyper linked nature of the web.  For example if you search for Borland most pages that mention Borland link to www.borland.com.  This is assumed to indicate that www.borland.com is a very important site about Borland.  Google also limits the number of hits you get on each domain.

Many search engines also rank pages higher if the search term appears in the URL or title of the page.  They also look at the description and keywords meta tags for ranking.  Some search engines will actually ignore a word if it appears too often in a page.  This weeds out sites that try to artificially inflate their rankings.  

Phonetics or Soundex is another technique that can be used.  This could be done with an additional table similar to the word table, but instead store the soundex value for the words instead of the actual word.  

Conclusion

Searching a shorter and well organized index is much quicker then searching an entire document.  Creating and searching an index takes a lot more planning and effort up front, but quickly pays off if the text is searched very often.  Typically the larger and more complex the index, the more effective the search.  If your index gets too large or complex then the search speed will degrade.  

There are off the shelf searching tools available to end users and developers alike.  dtSearch ( http://www.dtsearch.com ) makes a wide range of searching tools for both end users and all types of developers.  Tamarack Associates' Rubicon ( http://www.tamaracka.com ) is a search component for Delphi that provides a lot of flexibility, especially in storage options.  Both are extremely fast and useful, but don't let that stop you from designing your own, especially if you have a specialized need.

See also:

http://www.dtsearch.com/dtsoftware.html#Art_of_The_Text_Query