Retrieve a list of all installed applications

Problem/Question/Abstract:

Retrieve a list of all installed applications

Answer:

Under Windows 95, 98, ME, NT and Windows 2000 it is common habit that applications write their installation information into the registry under

HKEY_LOCAL_MACHINE\Software\Mirosoft\Windows\CurrentVersion\UnInstall

Each application has a subkey there and at least defines a display name and an uninstall string.
On my system here I noticed that Allaire Homesite left its installation stamp in HKEY_CURRENT_USER instead of HKEY_LOCAL_MACHINE. So to be save, one might want to scan below HKEY_CURRENT_USER as well. The following sample application retrieves the installed applications and version number - feel free to use it or download it.




{sc-----------------------------------------------------------------------

  -------------------------------------------------------------------
  TForm1.FormCreate                                              9%   5

  Download
-----------------------------------------------------------------------sc}
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  Registry;

{$R *.DFM}

{sc-----------------------------------------------------------------------
  Name:       TForm1.FormCreate
  Parameters:
     Sender
  Returns:
     -
  Cyclometric Complexity: 5               ,   3 comments in 32 lines = 9%

  Purpose:
    Retrieve installed apps and collect some info about them

  Date     Coder    CRC Comment
  02/18/01 Tiemann  58  Initial version!
-----------------------------------------------------------------------sc}

procedure TForm1.FormCreate(Sender: TObject);
var
  aList: TStrings;
  i: Integer;
  sVersion: string;
const
  sUninstall = 'Software\Microsoft\Windows\CurrentVersion\UnInstall';
begin
  // enumerate installed applications
  aList := TStringList.Create;

  with TRegistry.Create do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    if OpenKey(sUninstall, False) then
    begin
      GetKeyNames(aList);
      CloseKey;

      for i := 0 to aList.Count - 1 do
      begin
        if OpenKey(sUninstall +
          '\' +
          aList[i], False) then
        begin
          // collect some info about the installed stuff
          if ValueExists('DisplayVersion') then
            sVersion := 'Version ' + ReadString('DisplayVersion')
          else
            sVersion := '';

          ListBox1.Items.Add(aList[i] + #9 + sVersion);
          CloseKey
        end;
      end;
    end;
    // free the registry object
    Free
  end;
  aList.Free
end;

end.

How to free a component in a message handler

Problem/Question/Abstract:

Is it possible to free a component inside its own event handler?

Answer:

Not safely. You never know what the code after your free statement will still try to do with the (now invalid) self reference.

Do it the way forms implement the Release method: post a user message to the form, passing the control to delete as parameter, then free the control in the message handler:


const
  UM_DELETEOBJECT = WM_USER + 666;
type
  TUMDeleteObject = packed record
    Msg: Cardinal;
    Obj: TObject;
    Unused: Longint;
    Result: Longint;
  end;

  {in form declaration, private section}

procedure UMDeleteObject(var msg: TUMDeleteObject); message UM_DELETEOBJECT;

procedure TaaDEOutputFrm.UMDeleteObject(var msg: TUMDeleteObject);
begin
  msg.Obj.Free;
end;

procedure TaaDEOutputFrm.PanelClick(Sender: TObject);
begin
  if Sender is TPanel then
    PostMessage(handle, UM_DELETEOBJECT, wparam(sender), 0);
end;

How to set the properties of a component at runtime

Problem/Question/Abstract:

I want to set the font property of all my forms, buttons, labels, etc. on 50 different forms. How do I go about doing this? Is there some RTTI procedure or just using the "as" operator? I need this procedure to be recursive, too.

Answer:

You can use RTTI to do this. Here is how to change a particular component:

procedure TForm1.BtnClick(Sender: TObject);
var
  p: PPropInfo;
  f: TFont;
begin
  f := TFont.Create;
  {Setup the font properties}
  f.Name := 'Arial';
  p := GetPropInfo(Sender.ClassInfo, 'Font');
  if Assigned(p) then
    SetOrdProp(Sender, p, Integer(f));
  f.Free;
end;

To get at all the forms loop through the Screen global variable. For each form loop through its Components list calling the above procedure (or something close). If you only create your components at design time that is it. If you create some at runtime and the owner is not the form, then for each component loop through its Components list recursively to get at all the owned components.

Round Time to a quarter

Problem/Question/Abstract:

How to round Time to a quarter
Exemple 11:18:21 ----> 11:15:00

Answer:

function Quarter(T: TTime): TTime;
var
  H, M, S, ms: Word;
begin
  DecodeTime(T, H, M, S, ms);
  M := (M div 15) * 15;
  S := 0;
  Result := EncodeTime(H, M, S, ms);
end;

How to scroll a TListBox with keyboard FlushLeft, Left, Right, FlushRight

Problem/Question/Abstract:

How to scroll a TListBox with keyboard FlushLeft, Left, Right, FlushRight

Answer:

uses
  math;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  i, n: Integer;
begin
  for i := 0 to 25 do
    listbox1.items.add(StringOfChar(Char(33 + i), Random(50) + 50));
  canvas.Font := listbox1.font;
  n := 0;
  for i := 0 to listbox1.Items.count - 1 do
    n := Max(n, canvas.TextWidth(listbox1.Items[i]));
  listbox1.ScrollWidth := n;
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  Scrolllistbox(SB_LEFT);
end;

procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
  Scrolllistbox(SB_PAGELEFT);
end;

procedure TForm1.SpeedButton3Click(Sender: TObject);
begin
  Scrolllistbox(SB_PAGERIGHT);
end;

procedure TForm1.SpeedButton4Click(Sender: TObject);
begin
  Scrolllistbox(SB_RIGHT);
end;

procedure TForm1.ScrollListbox(scrollcode: Word);
begin
  listbox1.perform(WM_HSCROLL, scrollcode, 0);
  listbox1.perform(WM_HSCROLL, SB_ENDSCROLL, 0);
end;

initialization
  randomize;
end.

Creating a System Restore Point

Problem/Question/Abstract:

The following example demonstrates how to create and cancel restore points.

Answer:

To create a new System Restore Point in Windows XP, click Start -> All Programs -> Accessories -> System Tools -> System Restore.

The following two examples show two ways how to do this with Delphi.

{*****************************************************}
{1. Using the Microsoft Scripting Control}

  {
  If you haven't installed the Microsoft Scripting Control yet
  (TScriptControl component), get it
  from http://www.msdn.microsoft.com/scripting/

  Once you've downloaded and run the installation, start Delphi and go to the
  Component | Import ActiveX Control... menu.
  Select "Microsoft Script Control 1.0" from the Listbox amd click "Install"
  to install the component into Delphi's palette.
  What you should end up with now is a TScriptControl component on your ActiveX tab.
  Start a new application, and drop a TButton, and a
  TScriptControl onto the main form.
  In the OnClick event of Button1, put the following code:
  }

procedure TForm1.Button1Click(Sender: TObject);
var
  sr: OLEVAriant;
begin
  ScriptControl1.Language := 'VBScript';
  sr := ScriptControl1.Eval('getobject("winmgmts:\\.\root\default:Systemrestore")');
  if sr.CreateRestorePoint('Automatic Restore Point', 0, 100) = 0 then
    ShowMessage('New Restore Point successfully created.')
  else
    ShowMessage('Restore Point creation Failed!');
end;

{*****************************************************}
{2. Using the SRSetRestorePoint() API from SrClient.dll}

// Translation from SRRestorePtAPI.h
const
  // Type of Event
  BEGIN_SYSTEM_CHANGE = 100;
  END_SYSTEM_CHANGE = 101;
  // Type of Restore Points
  APPLICATION_INSTALL = 0;
  CANCELLED_OPERATION = 13;
  MAX_DESC = 64;
  MIN_EVENT = 100;

  // Restore point information
type
  PRESTOREPTINFOA = ^_RESTOREPTINFOA;
  _RESTOREPTINFOA = packed record
    dwEventType: DWORD; // Type of Event - Begin or End
    dwRestorePtType: DWORD; // Type of Restore Point - App install/uninstall
    llSequenceNumber: INT64; // Sequence Number - 0 for begin
    szDescription: array[0..MAX_DESC] of CHAR;
      // Description - Name of Application / Operation
  end;
  RESTOREPOINTINFO = _RESTOREPTINFOA;
  PRESTOREPOINTINFOA = ^_RESTOREPTINFOA;

  // Status returned by System Restore

  PSMGRSTATUS = ^_SMGRSTATUS;
  _SMGRSTATUS = packed record
    nStatus: DWORD; // Status returned by State Manager Process
    llSequenceNumber: INT64; // Sequence Number for the restore point
  end;
  STATEMGRSTATUS = _SMGRSTATUS;
  PSTATEMGRSTATUS = ^_SMGRSTATUS;

function SRSetRestorePointA(pRestorePtSpec: PRESTOREPOINTINFOA; pSMgrStatus:
  PSTATEMGRSTATUS): Bool;
  stdcall; external 'SrClient.dll' Name 'SRSetRestorePointA';

// Example how to create and cancel a previous restore point.
// Ref: http://tinyurl.com/78pv

procedure TForm1.Button1Click(Sender: TObject);
const
  CR = #13#10;
var
  RestorePtSpec: RESTOREPOINTINFO;
  SMgrStatus: STATEMGRSTATUS;
begin
  // Initialize the RESTOREPOINTINFO structure
  RestorePtSpec.dwEventType := BEGIN_SYSTEM_CHANGE;
  RestorePtSpec.dwRestorePtType := APPLICATION_INSTALL;
  RestorePtSpec.llSequenceNumber := 0;
  RestorePtSpec.szDescription := 'SAMPLE RESTORE POINT';

  if (SRSetRestorePointA(@RestorePtSpec, @SMgrStatus)) then
  begin
    ShowMessage('Restore point set. Restore point data:' + CR +
      'Sequence Number: ' + Format('%d', [SMgrStatus.llSequenceNumber]) + CR +
      'Status: ' + Format('%u', [SMgrStatus.nStatus]));

    // Restore Point Spec to cancel the previous restore point.
    RestorePtSpec.dwEventType := END_SYSTEM_CHANGE;
    RestorePtSpec.dwRestorePtType := CANCELLED_OPERATION;
    RestorePtSpec.llSequenceNumber := SMgrStatus.llSequenceNumber;

    // This is the sequence number returned by the previous call.
    // Canceling the previous restore point
    if (SRSetRestorePointA(@RestorePtSpec, @SMgrStatus)) then
      ShowMessage('Restore point canceled. Restore point data:' + CR +
        'Sequence Number: ' + Format('%d', [SMgrStatus.llSequenceNumber]) + CR +
        'Status: ' + Format('%u', [SMgrStatus.nStatus]))

    else
      ShowMessage('Couldn''t cancel restore point.');
  end
  else
    ShowMessage('Couldn''t set restore point.');
end;
end;

Retrieve list of installed fonts

Problem/Question/Abstract:

Retrieve list of installed fonts

Answer:

Is there an easy way to get all installed fonts in the Win95 system (for use in a font browser) without opening up the fonts directory and decoding the font names from all the font files?

Yes, it is really simple.
See the TScreen.Fonts property. Fonts is a string list object containing the names of the system's available fonts. Use the properties and methods of string list objects to retrieve the individual values.

You can also use the Assign method to copy the list to another string list object:

ListBox1.Items.Assign(Screen.Fonts);

Tagged Command Line Parameters

Problem/Question/Abstract:

I needed a flexible way to handle command line parameters. The standard Delphi ParamStr() and FindCmdLineSwitch were not flexible enough as I needed parameter values to be in any order.

Answer:

The FindCmdLineSwitch was not capable of this because a perfect match is searched for ie. /dsn=oracle1 or /dsn oracle1 would fail, as in the first case searching for FindCmdLineSwitch('dsn',['-','/'],true) would result in false
as "dsn=oracle1" is the switch. In the second case the search would resolve to true, but the second part of the switch is a completely separate parameter and might or might not be a part of /dsn.

I decided to use Tagged Parameter values to solve the value problem

eg.  dsn=oracle1 pass=fred123   {values bound to a param tag}

and use FindCmdLineSwitch for simple boolean switches

eg. /auto -auto etc.            {switch present true or false}

Using a simple but effective function

GetParamVal(const TaggedParm : string;  IgnoreCase : boolean = true) : string;

and Delphi's FindCmdLineSwitch() one can very easily determine
the values of command lines such as

MyExe dsn=oracle1 /auto pass=pass123
MyExe /auto pass=pass123 dsn=oracle1

The order of the parameters and switches are now irrelevant.

eg.

DataBase1.AliasName := GetParamVal('dsn');
if GetParamVal('pass') <> 'manager' then ....
if FindCmdLineSwitch('auto',['-','/'],true) then ....

function GetParamVal(const TaggedParm: string;
  IgnoreCase: boolean = true): string;
var
  Cmd: string;
  i, Len: integer;
  Comp1, Comp2: string;
begin
  Cmd := '';
  Comp1 := TaggedParm + '=';
  if IgnoreCase then
    Comp1 := UpperCase(Comp1);

  Len := length(Comp1);

  for i := 1 to ParamCount do
  begin
    Comp2 := copy(ParamStr(i), 1, Len);
    if IgnoreCase then
      Comp2 := UpperCase(Comp2);
    if (Comp1 = Comp2) then
    begin
      Cmd := trim(copy(ParamStr(i), Len + 1, length(ParamStr(i))));
      break;
    end;
  end;

  Result := UpperCase(Cmd);
end;

Get the version of Windows at runtime

Problem/Question/Abstract:

How can I get the version of Windows at runtime?

Answer:

Use the WinAPI call to GetVersion. GetVersion returns 3.1 for Win 3.1, 3.11, WfW 3.11 and Win NTwhen called from a 16-bit app in any of these environments, and 3.95 for Win95.

Also from a 16-bit app, you can detect NT with the following (thanks to Peter Below):

const
  WF_WINNT = $4000;
  IsNT := (GetWinFlags and WF_WINNT) <> 0;

Unfortunately, the above doesn't work for the 32-bit programs that you will be compiling in Delphi 2.0. For that, you have to use the new Win32 API call: GetVersionEx. GetVersionEx supercedes GetVersion for all 32-bit applications. Instead of returning a numeric value as in GetVersion, it fills the contents of a variable of a record of type TOSVersionInfo, from which you can gather much more detailed information about the Windows environment in which your program is running. Let's look at the various record elements of TOSVersionInfo:

The Window.PAS file lists TOSVersionInfo as the following:

TOSVersionInfoA = record
  dwOSVersionInfoSize: DWORD;
  dwMajorVersion: DWORD;
  dwMinorVersion: DWORD;
  dwBuildNumber: DWORD;
  dwPlatformId: DWORD;
  szCSDVersion: array[0..127] of AnsiChar; { Maintenance string for PSS usage }
end;
TOSVersionInfo := TOSVersionInfoA;

Notice that TOSVersionInfo is actually an assignment from another type, TOSVersionInfoA. There are actually two different version info types: TOSVersionInfoA and TOSVersionInfoW. The only difference between the two is in the szCSDVersion element. For the 'A' version info type, it's of an array of AnsiChar. The 'W' version info type is of an array of WideChar.

For our purposes, we're only interested in the 'A' type. Look at the table below to see what various elements represent:

Elements of TOSVersionInfo

Element
Type
Description
dwOSVersionInfoSize
DWORD
This element carries the memory size of the TOSVersionInfo variable. In fact, to use GetVersionEx, you have to initialize this element to SizeOf(TOSVersionInfo). Otherwise, the function will return a failure.
dwMajorVersion
DWORD
This is the major release number for Windows, which is on the left-hand side of the period. For example, it would be the '3' for version 3.51
dwMinorVersion
DWORD
This is the portion of the release number on the right-hand side of the period. It would be the '51' in 3.51
dwBuildNumber
DWORD
Build numbers aren't readily apparent in Windows 3.1x versions, but show up often in Win95 and NT. Just a finer level of versioning.
dwPlatformId
DWORD
This parameter tells you what level of Win32(s) your system is. It returns one of the three following constants:  
VER_PLATFORM_WIN32s = 0;  VER_PLATFORM_WIN32_WINDOWS = 1;  VER_PLATFORM_WIN32_NT = 2;
For most folks, this will probably be the element they'll use the most.
szCSDVersion
array[0..127] of AnsiChar
This parameter provides additional textual information about the version. For NT, it would list the Service Pack level installed.


How you employ this is entirely up to you. If you're writing apps that need to know what version of Windows they're running under, a function like this is essential. For example, let's say you write a Winsock application under Windows 95. With that type of app, you can address either a 16-bit Winsock DLL or a 32- bit Winsock. A good example of this is CompuServe Information Manager for Windows. It comes with its own 16-bit Winsock, but can also use WinNT's native WSOCK32.DLL as its winsock. It's obviously a matter of looking under the hood of Windows to decide what to use.

I have source code to share with you. This is a simple unit I built to display in string format all the elements of the TOSVersionInfo type. If you want to build the form to use this code, just follow these simple steps:

Start a new project
Drop the following on the form: six TEdits, six TLabels and a TButton.
Then insert the code below for the TButton's OnClick event, and that's it!

The TLabels should be named dwOSVersionInfoSize, dwMajorVersion, dwMinorVersion, dwBuildNumber, dwPlatformId, and szCSDVersion, respectively.

unit u;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    Edit5: TEdit;
    Edit6: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  verInfo: TOSVERSIONINFO;
  str: string;
  I: Word;
begin
  verInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  if GetVersionEx(verInfo) then
  begin
    Edit1.Text := IntToStr(verInfo.dwOSVersionInfoSize);
    Edit2.Text := IntToStr(verInfo.dwMajorVersion);
    Edit3.Text := IntToStr(verInfo.dwMinorVersion);
    Edit4.Text := IntToStr(verInfo.dwBuildNumber);
    case verInfo.dwPlatformId of
      VER_PLATFORM_WIN32s: Edit5.Text := 'Win16 running Win32s';
      VER_PLATFORM_WIN32_WINDOWS: Edit5.Text := 'Win32 Windows, probably Win95';
      VER_PLATFORM_WIN32_NT: Edit5.Text := 'WinNT, full 32-bit';
    end;

    str := '';

    for I := 0 to 127 do
      str := str + verInfo.szCSDVersion[I];

    Edit6.Text := str;
  end
end;

end.

The program above doesn't have tangible uses other than getting information, but it's a good way to dig into the TOSVersionInfo record. You can even use GetVersionEx on a splash screen to add a little "intelligence" to your apps.

How to generate a wave file and play it backwards

Problem/Question/Abstract:

How to generate a wave file and play it backwards

Answer:

Here's some code that plays a *.wav file backwards. It shows how *.wav files are generated.


procedure Interchange(hpchPos1, hpchPos2: PChar; wLength: word);
var
  wPlace: word;
  bTemp: char;
begin
  for wPlace := 0 to wLength - 1 do
  begin
    bTemp := hpchPos1[wPlace];
    hpchPos1[wPlace] := hpchPos2[wPlace];
    hpchPos2[wPlace] := bTemp
  end
end;

procedure ReversePlay(const szFileName: string);
var
  mmioHandle: HMMIO;
  mmckInfoParent: MMCKInfo;
  mmckInfoSubChunk: MMCKInfo;
  dwFmtSize, dwDataSize: DWORD;
  pFormat: PWAVEFORMATEX;
  wBlockSize: word;
  hpch1, hpch2: PChar;
  waveOutHAndle: Integer;
  data: PChar;
  waveHdr: PWAVEHDR;
begin
  data := nil;
  mmioHandle := mmioOpen(PChar(szFileName), nil, MMIO_READ or MMIO_ALLOCBUF);
  if mmioHandle = 0 then
    raise Exception.Create('Unable to open file ' + szFileName);
  try
    mmckInfoParent.fccType := mmioStringToFOURCC('WAVE', 0);
    if mmioDescend(mmioHandle, @mmckinfoParent, nil,
      MMIO_FINDRIFF) <> MMSYSERR_NOERROR then
      raise Exception.Create(szFileName + ' is not a valid wave file');
    mmckinfoSubchunk.ckid := mmioStringToFourCC('fmt ', 0);
    if mmioDescend(mmioHandle, @mmckinfoSubchunk, @mmckinfoParent,
      MMIO_FINDCHUNK) <> MMSYSERR_NOERROR then
      raise Exception.Create(szFileName + ' is not a valid wave file');
    dwFmtSize := mmckinfoSubchunk.cksize;
    GetMem(pFormat, dwFmtSize);
    try
      if DWORD(mmioRead(mmioHandle, PChar(pFormat), dwFmtSize)) <> dwFmtSize then
        raise Exception.Create('Error reading wave data');
      if pFormat^.wFormatTag <> WAVE_FORMAT_PCM then
        raise Exception.Create('Invalid wave file format');
      if waveOutOpen(@waveOutHandle, WAVE_MAPPER, pFormat, 0, 0,
        WAVE_FORMAT_QUERY) <> MMSYSERR_NOERROR then
        raise Exception.Create('Can''t play format');
      mmioAscend(mmioHandle, @mmckinfoSubchunk, 0);
      mmckinfoSubchunk.ckid := mmioStringToFourCC('data', 0);
      if mmioDescend(mmioHandle, @mmckinfoSubchunk, @mmckinfoParent,
        MMIO_FINDCHUNK) <> MMSYSERR_NOERROR then
        raise Exception.Create('No data chunk');
      dwDataSize := mmckinfoSubchunk.cksize;
      if dwDataSize = 0 then
        raise Exception.Create('Chunk has no data');
      if waveOutOpen(@waveOutHandle, WAVE_MAPPER, pFormat, 0, 0,
        CALLBACK_NULL) <> MMSYSERR_NOERROR then
      begin
        waveOutHandle := 0;
        raise Exception.Create('Failed to open output device');
      end;
      wBlockSize := pFormat^.nBlockAlign;
      ReallocMem(pFormat, 0);
      ReallocMem(data, dwDataSize);
      if DWORD(mmioRead(mmioHandle, data, dwDataSize)) <> dwDataSize then
        raise Exception.Create('Unable to read data chunk');
      hpch1 := data;
      hpch2 := data + dwDataSize - 1;
      while hpch1 < hpch2 do
      begin
        Interchange(hpch1, hpch2, wBlockSize);
        Inc(hpch1, wBlockSize);
        Dec(hpch2, wBlockSize)
      end;
      GetMem(waveHdr, sizeof(WAVEHDR));
      waveHdr^.lpData := data;
      waveHdr^.dwBufferLength := dwDataSize;
      waveHdr^.dwFlags := 0;
      waveHdr^.dwLoops := 0;
      waveHdr^.dwUser := 0;
      if waveOutPrepareHeader(WaveOutHandle, WaveHdr,
        sizeof(WAVEHDR)) <> MMSYSERR_NOERROR then
        raise Exception.Create('Unable to prepare header');
      if waveOutWrite(WaveOutHandle, WaveHdr, sizeof(WAVEHDR)) <> MMSYSERR_NOERROR then
        raise Exception.Create('Failed to write to device');
    finally
      ReallocMem(pFormat, 0)
    end;
  finally
    mmioClose(mmioHandle, 0)
  end;
end;

How to invert the Y-axis on a TCanvas

Problem/Question/Abstract:

I know I can change the origin within a canvas by SetWindowOrgEx. But then the y-axis is still negative in the upper direction and positive in the lower. Can I change it so it works the other way round (upper direction is positive). I need to do a lot of canvas drawing, and it would help me a lot, because I feel more comfortable with the usual geometric coordinate system.

Answer:

You can create a (matrix) mapping that you apply to all your lowlevel coordinates. Something like:


{Map will flip the Y-axis on the form so that origin is in lower left corner}

function TForm1.Map(P: TPoint; Canvas: TCanvas): TPoint;
begin
  Result.X := P.X;
  Result.Y := ClientHeight - P.Y;
end;

function TForm1.MapX(X: integer): integer;
begin
  Result := X;
end;

function TForm1.MapY(Y: integer): integer;
begin
  Result := ClientHeight - Y;
end;


Just whenever you need coordinates, make sure to map them as the last step.

e.g. drawing a line from lower left to (100, 100):


Canvas.MoveTo(MapX(0), MapY(0));
Canvas.LineTo(MapX(100), MapY(100));


Of course, mapping in X doesn't make sense here, but you can make it more fancy if you want to add custom origins etc. Or even rotation, but then you can't use the individual MapX and MapY.

Sort a TListView on a column header click

Problem/Question/Abstract:

How to sort a TListView on a column header click

Answer:

In the object inspector, I have set the ListView's SortType = stText.

{Private Declarations}
SortColumn: Integer;
SortDescending: Boolean;

procedure Sort(Column: Integer);

procedure TfrmMain.ListViewColumnClick(Sender: TObject; Column: TListColumn);
begin
  Sort(Column.Index);
end;

procedure TfrmMain.Sort(Column: Integer);
begin
  if SortColumn = Column then
    SortDescending := not SortDescending
  else
  begin
    SortDescending := False;
    SortColumn := Column;
  end;
  lsvPlayerPages.AlphaSort;
end;

procedure TfrmMain.ListViewCompare(Sender: TObject; Item1, Item2: TListItem;
  Data: Integer; var Compare: Integer);
begin
  if SortColumn = 0 then
    Compare := CompareStr(Item1.Caption, Item2.Caption)
  else
    Compare := CompareStr(Item1.SubItems[Pred(SortColumn)],
      Item2.SubItems[Pred(SortColumn)]);
  if SortDescending then
    Compare := -Compare;
end;

I have made a separate sort procedure to be able to sort from different commands (e.g. from a menu). The code also sorts descending if a column header is clicked a second time (as Windows Explorer does).

Show system icons in Windows XP

Problem/Question/Abstract:

I can't get the system icons to show in XP. All works well in Win 98 but in XP no icons are loaded. Why?

Answer:

Because in NT each process gets its own imagelist and to minimize resources the imagelist is populated on demand. So if the process does not request an image it is not loaded. To force it you need to use an undocumeted function:

{ ... }
uses
  ShellAPI;

function FileIconInit(FullInit: BOOL): BOOL; stdcall;
type
  TFileIconInit = function(FullInit: BOOL): BOOL; stdcall;
var
  ShellDLL: HMODULE;
  PFileIconInit: TFileIconInit;
begin
  Result := False;
  if (Win32Platform = VER_PLATFORM_WIN32_NT) then
  begin
    ShellDLL := LoadLibrary(PChar(Shell32));
    PFileIconInit := GetProcAddress(ShellDLL, PChar(660));
    if (Assigned(PFileIconInit)) then
      Result := PFileIconInit(FullInit);
  end;
end;

initialization
  FileIconInit(True);

  { ... }

LotusNotes and Delphi: Scaning Personal Address Book

Problem/Question/Abstract:

How work with LotusNotes via OleAuto

Answer:

unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Domino_TLB, Menus, ComCtrls;
const
  PASSWD = 'ur70';
type
  TForm2 = class(TForm)
    TV_INFO: TTreeView;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Create1: TMenuItem;
    Init1: TMenuItem;
    AddressBook1: TMenuItem;
    Scan1: TMenuItem;
    procedure Create1Click(Sender: TObject);
    procedure Init1Click(Sender: TObject);
    procedure Scan1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;
  Session: TNotesSession;
implementation

{$R *.dfm}

procedure TForm2.Create1Click(Sender: TObject);
begin
  Session := TNotesSession.Create(nil);
end;

procedure TForm2.Init1Click(Sender: TObject);
begin
  Session.Initialize(PASSWD);
end;

procedure TForm2.Scan1Click(Sender: TObject);
var
  NotesDb: NotesDatabase;
  addrBook: NotesDatabase;
  People, People2: NotesView;
  Person, Person2: NotesDocument;
  View: NotesView;
  Item: NotesItem;
  AddrBooks: OleVariant;
  Views: OleVariant;
  Items: OleVariant;
  x, y, z: integer;
  view_name: string;
  tn, tc: TTreeNode;
begin
  NotesDb := Session.GetDatabase('', 'names.nsf', False);
  AddrBooks := Session.AddressBooks;
  for x := 0 to VarArrayHighBound(AddrBooks, 1) -
    VarArrayLowBound(AddrBooks, 1) do
  begin
    addrBook := NotesDatabase(IUnknown(AddrBooks[x]));
    if (addrBook.IsPrivateAddressBook) then
    begin
      addrBook.Open;
    end
    else
      addrBook := nil;
    if (addrBook <> nil) then
    begin
      Views := addrBook.Views;
      for y := 0 to VarArrayHighBound(Views, 1) -
        VarArrayLowBound(Views, 1) do
      begin
        View := NotesView(IUnknown(Views[y]));
        view_name := View.Name;
        tn := tv_info.Items.AddNode(nil, nil, view_name, nil, naAdd);

        if copy(view_name, 1, 1) = '$' then
          view_name := copy(view_name, 2, length(view_name) - 1);
        people := addrBook.GetView(view_name);
        person := people.GetFirstDocument;
        if Person <> nil then
        begin
          Items := Person.Items;
          for z := 0 to VarArrayHighBound(Items, 1) -
            VarArrayLowBound(Items, 1) do
          begin
            Item := NotesItem(IUnknown(Items[z]));
            tc := tv_info.Items.AddChild(tn, Item.Name);

            people := addrBook.GetView(view_name);
            person := people.GetFirstDocument;

            while (Person <> nil) do
            begin
              try
                try
                  tv_info.Items.AddChild(tc, Person.GetFirstItem(Item.Name).Text
                    {Item.Text});
                except
                end;
              finally
                Person := People.GetNextDocument(Person);
              end;
            end;
          end;
        end;
      end;

    end;
  end;
end;

end.

you can get type library info on

ftp://ftp.lotus.com/pub/lotusweb/devtools/comdoc.chm

it work IMHO only for LotusNotes Domino ver 5 or highe

How to get data from a file without reading it into memory

Problem/Question/Abstract:

Is there a way to point a pointer to a text data file on a hard drive with out reading into memory. Here is the problem. I have a third-party DLL that requires a pointer to a large char string 10000 + chars. If I were to read into memory and then call the DLL it could cause problems.

Answer:

You can use Mapped Files. A mapped file is a region in memory that is mapped to a file on disk. After you map a file to memory you get a pointer to the memory region and use it like any other pointer - Window will load and unload pages from the file to memory as needed. Here is a very simple implementation of a mapped file. It is used only to read data from the file so you might want to change it to also allow writing. After you create an instance, the Content property is a pointer to the file content.

{ ... }
type
  TMappedFile = class
  private
    FMapping: THandle;
    FContent: PChar;
    FSize: Integer;
    procedure MapFile(const FileName: string);
  public
    constructor Create(const FileName: string);
    destructor Destroy; override;
    property Content: PChar read FContent;
    property Size: Integer read FSize;
  end;

implementation

uses
  sysutils;

{ TMappedFile }

constructor TMappedFile.Create(const FileName: string);
begin
  inherited Create;
  MapFile(FileName);
end;

destructor TMappedFile.Destroy;
begin
  UnmapViewOfFile(FContent);
  CloseHandle(FMapping);
  inherited;
end;

procedure TMappedFile.MapFile(const FileName: string);
var
  FileHandle: THandle;
begin
  FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyWrite);
  Win32Check(FileHandle <> 0);
  try
    FSize := GetFileSize(FileHandle, nil);
    FMapping := CreateFileMapping(FileHandle, nil, PAGE_READONLY, 0, 0, nil);
    Win32Check(FMapping <> 0);
  finally
    FileClose(FileHandle);
  end;
  FContent := MapViewOfFile(FMapping, FILE_MAP_READ, 0, 0, 0);
  Win32Check(FContent <> nil);
end;

DDE link to Netscape

Problem/Question/Abstract:

DDE link to Netscape

Answer:

Create a new application with a form Form1, put the components on it as in the following class defined (buttons, edit controls, labels and one TDDEClientConv) and link the events to the given procedures.

Button3 will have Netscape open the entered url.

unit Netscp1;

interface

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

type
  TForm1 = class(TForm)
    DdeClientConv1: TDdeClientConv;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    LinkStatus: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    URLName: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }

  end;

var
  Form1: TForm1;
  LinkOpened: integer;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if LinkOpened = 0 then
  begin
    DdeClientConv1.SetLink('Netscape', 'WWW_OpenURL');
    if DdeClientConv1.OpenLink then
    begin
      LinkStatus.Text := 'Netscape Link has been opened';
      LinkOpened := 1
    end
    else
      LinkStatus.Text := 'Unable to make Netscape Link'
  end
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  LinkOpened := 0
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  DdeClientConv1.CloseLink;
  LinkOpened := 0;
  LinkStatus.Text := 'Netscape Link has been closed'
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  ItemList: string;
begin
  if LinkOpened <> 0 then
  begin
    ItemList := URLName.Text + ',,0xFFFFFFFF,0x3,,,';
    DdeClientConv1.RequestData(ItemList)
  end
end;

end.

How to create transparent menus

Problem/Question/Abstract:

How to create transparent menus

Answer:

This works only for Win 2000 and XP:

{ ... }
var
  hHookID: HHOOK;

  {Function to make the menu transparent }

function MakeWndTrans(Wnd: HWND; nAlpha: Integer = 10): Boolean;
type
  TSetLayeredWindowAttributes = function(hwnd: HWND; crKey: COLORREF; bAlpha: Byte;
    dwFlags: Longint): Longint; stdcall;
const
  {Use crKey as the transparency color}
  LWA_COLORKEY = 1;
  {Use bAlpha to determine the opacity of the layered window}
  LWA_ALPHA = 2;
  WS_EX_LAYERED = $80000;
var
  hUser32: HMODULE;
  SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
  i: Integer;
begin
  Result := False;
  {Here we import the function from USER32.DLL}
  hUser32 := GetModuleHandle('USER32.DLL');
  if hUser32 <> 0 then
  begin
    @SetLayeredWindowAttributes := GetProcAddress(hUser32,
      'SetLayeredWindowAttributes');
    {If the import did not succeed, make sure your app can handle it!}
    if @SetLayeredWindowAttributes <> nil then
    begin
      {Check the current state of the dialog, and then add the
                        WS_EX_LAYERED attribute}
      SetWindowLong(Wnd, GWL_EXSTYLE, GetWindowLong(Wnd, GWL_EXSTYLE)
        or WS_EX_LAYERED);
      {The SetLayeredWindowAttributes function sets the opacity and transparency color
      key of a layered window}
      SetLayeredWindowAttributes(Wnd, 0, Trunc((255 / 100) * (100 - nAlpha)),
        LWA_ALPHA);
      Result := True;
    end;
  end;
end;

{Hook procedure}

function HookCallWndProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall;
const
  MENU_CLASS = '#32768';
  N_ALPHA = 60;
var
  cwps: TCWPStruct;
  lRet: THandle;
  szClass: array[0..8] of char;
begin
  if (nCode = HC_ACTION) then
  begin
    CopyMemory(@cwps, Pointer(lParam), SizeOf(CWPSTRUCT));
    case cwps.message of
      WM_CREATE:
        begin
          GetClassName(cwps.hwnd, szClass, Length(szClass) - 1);
          {Window name for menu is #32768}
          if (lstrcmpi(szClass, MENU_CLASS) = 0) then
          begin
            MakeWndTrans(cwps.hwnd, N_ALPHA {Alphablending});
          end;
        end;
    end;
  end;
  {Call the next hook in the chain}
  Result := CallNextHookEx(WH_CALLWNDPROC, nCode, wParam, lParam);
end;

{Install the hook in the OnCreate Handler}

procedure TForm1.FormCreate(Sender: TObject);
var
  tpid: DWORD;
begin
  {Retrieve the identifier of the thread that created the specified window}
  tpid := GetWindowThreadProcessId(Handle, nil);
  {The SetWindowsHookEx function installs an application-defined
  hook procedure into a hook chain}
  hHookID := SetWindowsHookEx(WH_CALLWNDPROC, HookCallWndProc, 0, tpid);
end;

{Stop the hook in the OnDestroy Handler}

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if (hHookID <> 0) then
    {Removes the hook procedure}
    UnhookWindowsHookEx(hHookID);
end;

XML File Viewer

Problem/Question/Abstract:

How to create a simple XML File viewer, without worrying about the XML itself. The easiest solution is using the Microsoft XML Document Object Model, installed on every machine that run MS Internet Explorer 4 or higher.

Answer:

In this article I am showing you a simple XML file viewer, that may be extended to an XML editor with some work. You may enhance the editor by importing icons for the different node types, etc. That's up to you.

My main idea is to show you how to import type libraries from readily available components installed on nearly every machine in the modern windows world.

Note: The MS XML DOM is available for free download and redistribution at msdn.microsoft.com

IMPORTING THE MS XML TYPE LIBRARY

Start Delphi and create a new application, I you haven't done so already. In the Delphi menu go to Project|Import Type Library... A dialog will appear on your screen, with a list of all installed and registered COM libraries available for import. Take a moment and scroll through it, you might be surprised.

Somewhere down the list you find Microsoft XML, version 2.0 (Version 2.0). This is the type library we are going to import. Additionally, you may see Microsoft XML, v3.0 (Version 3.0). This is a newer and faster version from MS, we are going to use the older version however, since it is more common.

After selecting the MS XML, version 2.0 component object, select a Unit Directory, and press the Create Unit button. The Install button will install the component in your Component Pallete, additionally.

PREPARING YOUR APPLICATION FORM

Drop a MainMenu (Standard) component on your form, and insert a Open Menu item (name: Open1).
Drop a TreeView (Win32) component on your form, set Align=alLeft and ReadOnly=True (name: trvStructure).
Drop an OpenDialog (Dialogs) component on your form (name: OpenDialog1).
Drop a Panel (Standard) component on your form, set Align=alClient and clear the Caption (name: Panel1).
Drop a StringGrid (Additional) component on the Panel1 set Align=alTop, RowCount=2, ColCount=2, FixedCols=0, FixedRows=1 (name: grdAttributes).
Drop a Memo (Standard) on the Panel1 set Align=alClient, ReadOnly=True (name mmoNodeContent).

Note: The names I have used will appear in the source code again!

A PSEUDO CLASS FOR THE XML INTERFACES

Because mapping of interface via pointers introduces some problems I chose to create a simple class that contains only on variable holding the reference to the XML Node interface.

type
  TXMLNodeWrapper = class
  private
    FNode: IXMLDOMNode;
  protected
  public
    constructor Create(aNode: IXMLDOMNode);
    property Node: IXMLDOMNode read FNode;
  end;

The constructor will save the reference in the FNode variable.

CREATING THE XML DOM OBJECT

Creating an instance of the object is rather simple. Having a variable FDocument of the type IXMLDOMDocument, defined in the imported MSXML_TLB.

FDocument := CoDOMDocument.Create;

Next you need to set up the component to your needs.

FDocument.async := False;
FDocument.validateOnParse := True;
FDocument.preserveWhiteSpace := True;

The first I want to do is inserting an base element into the document. Every XML document needs at least this base element. I have named it xmlstart.

Note: Be careful, XML is case-sensitive.

FDocument.appendChild(FDocument.createNode(NODE_ELEMENT, 'xmlstart', ''));

PARSING THE XML DOCUMENT

There are quite many ways of parsing XML. I want to show you two recursive ways, that are very similar, but have quite different results.

(1) NodeList := Node.childNodes;

Returns all children, inlcude some special node types, such as #text or #comment. These node types require special care.

(2) NodeList := Node.selectNodes('*');

Returns all standard node types, that can be accessed via XSL (XML Structured Language). These node types are easy in use.

ACCESSING THE NODE LIST

Accessing any item in a Node List is very easy. The length returns the count of items in the list (equal to Delphis Count property). The Item array gives access to every Item of the node list.

for I := 0 to Pred(XMLNodeList.length) do
  ShowMessage(XMLNodeList.item[I].nodeName);

MORE INFORMATION ABOUT THE MS XML DOM

The most important web addresses for the MS XML DOM are:

http://msdn.microsoft.com/xml  (all about XML)
http://msdn.microsoft.com/downloads/default.asp?URL=/code/topic.asp?URL=/msdn-files/028/000/072/topic.xml (Downloads)

THE SOURCE CODE FOR THE XML VIEWER

unit uMainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  MSXML_TLB, ComCtrls, Menus, Grids, ExtCtrls, StdCtrls;

type
  TXMLNodeWrapper = class
  private
    FNode: IXMLDOMNode;
  protected
  public
    constructor Create(aNode: IXMLDOMNode);
    property Node: IXMLDOMNode read FNode;
  end;

  TfrmMain = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Open1: TMenuItem;
    trvStructure: TTreeView;
    OpenDialog1: TOpenDialog;
    Panel1: TPanel;
    grdAttributes: TStringGrid;
    mmoNodeContent: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure Open1Click(Sender: TObject);
    procedure trvStructureChange(Sender: TObject; Node: TTreeNode);
  private
    FDocument: IXMLDOMDocument;
    FFileName: string;
    procedure LoadXML;
  public
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}

{ TXMLNodeWrapper }

constructor TXMLNodeWrapper.Create(aNode: IXMLDOMNode);
begin
  inherited Create;
  FNode := aNode;
end;

{ TFrmMain }

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  FDocument := CoDOMDocument.Create;
  FDocument.async := False;
  FDocument.validateOnParse := True;
  FDocument.preserveWhiteSpace := True;
  FDocument.appendChild(FDocument.createNode(NODE_ELEMENT, 'xmlstart', ''));

  grdAttributes.Cells[0, 0] := 'Attribute name';
  grdAttributes.Cells[1, 0] := 'Attribute value';
end;

procedure TfrmMain.LoadXML;
  procedure EnterNode(const XMLNode: IXMLDOMNode; TreeNode: TTreeNode);
  var
    I: Integer;
    XMLNodeList: IXMLDOMNodeList;
    NewTreeNode: TTreeNode;
  begin
    NewTreeNode := trvStructure.Items.AddChild(TreeNode, XMLNode.nodeName);
    NewTreeNode.Data := TXMLNodeWrapper.Create(XMLNode);
    // use XMLNode.childNodes to get all nodes (incl. special types)
    XMLNodeList := XMLNode.selectNodes('*');
    for I := 0 to Pred(XMLNodeList.length) do
      EnterNode(XMLNodeList.item[I], NewTreeNode);
  end;
begin
  for I := 0 to trvStructure.Items.Count - 1 do
    TXMLNodeWrapper(trvStructure.Items.Item[I].Data).Destroy;
  trvStructure.Items.BeginUpdate;
  try
    trvStructure.Items.Clear;
    EnterNode(FDocument.documentElement, nil);
  finally
    trvStructure.Items.EndUpdate;
  end;
end;

procedure TfrmMain.Open1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    FDocument.load(OpenDialog1.FileName);
    FFileName := OpenDialog1.FileName;
    LoadXML;
  end;
end;

procedure TfrmMain.trvStructureChange(Sender: TObject; Node: TTreeNode);
var
  I: Integer;
  CurrentNode: IXMLDOMNode;
begin
  CurrentNode := TXMLNodeWrapper(Node.Data).Node;
  Caption := CurrentNode.nodeName;
  if CurrentNode.selectNodes('*').length = 0 then
    mmoNodeContent.Text := CurrentNode.text
  else
    mmoNodeContent.Text := '';
  if CurrentNode.attributes.length > 0 then
  begin
    grdAttributes.RowCount := Succ(CurrentNode.attributes.length);
    grdAttributes.FixedRows := 1;
    for I := 0 to Pred(CurrentNode.attributes.length) do
    begin
      grdAttributes.Cells[0, Succ(I)] := CurrentNode.attributes.item[I].nodeName;
      grdAttributes.Cells[1, Succ(I)] := CurrentNode.attributes.item[I].text;
    end;
  end
  else
  begin
    grdAttributes.RowCount := 2;
    grdAttributes.Cells[0, 1] := '';
    grdAttributes.Cells[1, 1] := '';
  end;
end;

end.

Extended E-mail Address Verification and Correction

Problem/Question/Abstract:

Have you ever needed to verify that an e-mail address is correct, or have you had to work with a list of e-mail addresses and realized that some had simple problems that you could easily correct by hand?

Answer:

Have you ever needed to verify that an e-mail address is correct, or have you had to work with a list of e-mail addresses and realized that some had simple problems that you could easily correct by hand? Well the functions I present here are designed to do just that. In this article I present two functions, one to check that an e-mail address is valid, and another to try to correct an incorrect e-mail address.

Just what is a correct e-mail address?
The majority of articles I&#8217;ve seen on e-mail address verification use an over-simplified approach. For example, the most common approach I&#8217;ve seen is to ensure that an &#8216;@&#8217; symbol is present, or that it&#8217;s a minimum size (ex. 7 characters), or a combination of both.  And a better, but less used method is to verify that only allowed characters (based on the SMTP standard) are in the address.

The problem with these approaches is that they only can tell you at the highest level that an address is POSSIBLY correct, for example:

The address: ------@--------
Can be considered a valid e-mail address, as it does contain an @, is at least 7 characters long and contains valid characters.

To ensure an address is truly correct, you must verify that all portions of the e-mail address are valid. The function I present performs the following checks:
a) Ensure an address is not blank
b) Ensure an @ is present
c) Ensure that only valid characters are used
Then splits the validation to the two individual sections:  username (or mailbox) and domain
Validation for the username:
a) Ensure it is not blank
b) Ensure the username is not longer than the current standard (RFC 821)
c) Ensures that periods (.) are used properly, specifically there can not be sequential periods (ex. David..Lederman is not valid) nor can there be a period in the first or last character of an e-mail address
Validation for the domain name:
a) Ensure it is not blank
b) Ensure the domain name is not longer than the current standard
d) Ensure that periods (.) are used properly, specifically there can not be sequential periods (ex. World..net is not valid) nor can there a period in the first or last character of the domain segment
e) Domain segments need to be checked  (ex. in someplace.somewhere.com, someplace, somewhere, and com are considered segments) to ensure that they do not start or end with a hyphen (-) (ex. somewhere.-someplace.com, is not valid)
f) Ensure that at least two domain segments exists (ex. someplace.com is valid, .com is not valid)
g) Ensure that there are no additional @ symbols in the domain portion

With the steps above most syntactically valid e-mail address that are not correct can be detected and invalidated.

The VerifyEmailAddress function:
This function takes 3 parameters:
Email &#8211; The e-mail address to check
FailCode &#8211; The error code reported by the function if it can&#8217;t validate an address
FailPosition &#8211; The position of the character (if available) where the validation failure occurred

The function returns a Boolean value that returns True if the address is valid, and False if it is invalid. If a failure does occur the FailCode can be used to determine the exact error that caused the problem:

  flUnknown &#8211; An unknown error occurred, and was trapped by the exception handler.
  flNoSeperator &#8211; No @ symbol was found.
  flToSmall &#8211; The email address was blank.
  flUserNameToLong &#8211; The user name was longer than the SMTP standard allows.
  flDomainNameToLong &#8211; The domain name was longer than the SMTP standard allows.
  flInvalidChar &#8211; An invalid character was found. (FailPosition returns the location of the character)
  flMissingUser &#8211; The username section is not present.
  flMissingDomain &#8211; The domain name section is not present
  flMissingDomainSeperator &#8211; No domain segments where found
  flMissingGeneralDomain &#8211; No top-level domain was found
  flToManyAtSymbols &#8211; More than one @ symbol was found

For simple validation there is no use for FailCode and FailPosition, but can be used to display an error using the ValidationErrorString which takes the FailCode as a parameter and returns a text version of the error which can then be displayed.

E-mail Address Correction
Since the e-mail validation routine returns detailed error information an automated system to correct common e-mail address mistakes can be easily created.  The following common mistakes can all be corrected automatically:

example2.aol.com &#8211; The most common error (at least in my experience) is when entering an e-mail address a user doesn&#8217;t hold shift properly and instead enters a 2.
example@.aol.com - This error is just an extra character entered by the user, of course example@aol.com was the intended e-mail address.
example8080 @ aol .com &#8211; In this case another common error, spaces.
A Cool Screen name@AOL.com &#8211; In this case the user entered what they thought was their e-mail address, except while AOL allows screen names to contain spaces, the Internet does not.
myaddress@ispcom - In this case the period was not entered between ISP and Com.

The CorrectEmailAddress function:
The function takes three parameters:
Email &#8211; The e-mail address to check and correct
Suggestion &#8211; This string passed by reference contains the functions result
MaxCorrections &#8211; The maximum amount of corrections to attempt before stopping (defaults to 5)

This function simply loops up to MaxCorrection times, validating the e-mail address then using the FailCode to decide what kind of correction to make, and repeating this until it find a match, determines the address can&#8217;t be fixed, or has looped more than MaxCorrection times.

The following corrections are performed, based on the FailCode (see description above):
flUnknown &#8211; Simply stops corrections, as there is no generic way to correct this problem.
flNoSeperator &#8211; When this error is encountered the system performs a simple but powerful function, it will navigate the e-mail address until it finds the last 2, and then convert it to an @ symbol. This will correct most genuine transposition errors. If it converts a 2 that was not really an @ chances are it has completely invalidated the e-mail address.
flToSmall - Simply stops corrections, as there is no generic way to correct this problem.
flUserNameToLong &#8211; Simply stops corrections, as there is no generic way to correct this problem.
flDomainNameToLong &#8211; Simply stops corrections, as there is no generic way to correct this problem.
flInvalidChar &#8211; In this case the offending character is simply deleted.
flMissingUser &#8211; Simply  stops corrections, as there is no generic way to correct this problem.
flMissingDomain &#8211; Simply stops corrections, as there is no generic way to correct this problem.
flMissingDomainSeperator &#8211; Simply stops corrections, as there is no generic way to correct this problem.
flMissingGeneralDomain &#8211; Simply stops corrections, as there is no generic way to correct this problem.
flToManyAtSymbols &#8211; Simply stops corrections, as there is no generic way to correct this problem.

While only a small portion of errors can be corrected the function can correct the most common errors encountered when working with list of e-mail addresses, specifically when the data is entered by the actual e-mail address account holder.

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

// ---------------------------ooo------------------------------ \\
// &copy;2000 David Lederman
// dlederman@internettoolscorp.com
// ---------------------------ooo------------------------------ \\
unit abSMTPRoutines;

interface

uses
  SysUtils, Classes;

// ---------------------------ooo------------------------------ \\
// These constants represent the various errors validation
// errors (known) that can occur.
// ---------------------------ooo------------------------------ \\
const
  flUnknown = 0;
  flNoSeperator = 1;
  flToSmall = 2;
  flUserNameToLong = 3;
  flDomainNameToLong = 4;
  flInvalidChar = 5;
  flMissingUser = 6;
  flMissingDomain = 7;
  flMissingDomainSeperator = 8;
  flMissingGeneralDomain = 9;
  flToManyAtSymbols = 10;

function ValidateEmailAddress(Email: string; var FailCode, FailPosition: Integer):
  Boolean;
function CorrectEmailAddress(Email: string; var Suggestion: string; MaxCorrections:
  Integer = 5): Boolean;
function ValidationErrorString(Code: Integer): string;

implementation
// ---------------------------ooo------------------------------ \\
// This is a list of error descriptions, it's kept in the
// implementation section as it's not needed directlly
// from outside this unit, and can be accessed using the
// ValidationErrorString which does range checking.
// ---------------------------ooo------------------------------ \\
const
  ErrorDescriptions: array[0..10] of string = ('Unknown error occured!',
    'Missing @ symbol!', 'Data to small!', 'User name to long!',
    'Domain name to long!', 'Invalid character!', 'Missing user name!',
      'Missing domain name!',
    'Missing domain portion (.com,.net,etc)', 'Invalid general domain!',
      'To many @ symbols!');
  AllowedEmailChars: set of Char = ['A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',
    'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
  'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k',
    'l', 'm', 'n',
    'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '0', '1', '2', '3',
      '4', '5', '6', '7',
    '8', '9', '@', '-', '.', '_', '''', '+', '$', '/', '%'];
  MaxUsernamePortion = 64; // Per RFC 821
  MaxDomainPortion = 256; // Per RFC 821

function CorrectEmailAddress;
var
  CurITT, RevITT, ITT, FailCode, FailPosition, LastAt: Integer;
begin
  try
    // Reset the suggestion
    Suggestion := Email;
    CurITT := 1;
    // Now loop through to the max depth
    for ITT := CurITT to MaxCorrections do // Iterate
    begin
      // Now try to validate the address
      if ValidateEmailAddress(Suggestion, FailCode, FailPosition) then
      begin
        // The email worked so exit
        result := True;
        exit;
      end;
      // Otherwise, try to correct it
      case FailCode of //
        flUnknown:
          begin
            // This error can't be fixed
            Result := False;
            exit;
          end;
        flNoSeperator:
          begin
            // This error can possibly be fixed by finding
            // the last 2 (which was most likely transposed for an @)
            LastAt := 0;
            for RevITT := 1 to Length(Suggestion) do // Iterate
            begin
              // Look for the 2
              if Suggestion[RevITT] = '2' then
                LastAt := RevITT;
            end; // for
            // Now see if we found an 2
            if LastAt = 0 then
            begin
              // The situation can't get better so exit
              Result := False;
              exit;
            end;
            // Now convert the 2 to an @ and continue
            Suggestion[LastAt] := '@';
          end;
        flToSmall:
          begin
            // The situation can't get better so exit
            Result := False;
            exit;
          end;
        flUserNameToLong:
          begin
            // The situation can't get better so exit
            Result := False;
            exit;
          end;
        flDomainNameToLong:
          begin
            // The situation can't get better so exit
            Result := False;
            exit;
          end;
        flInvalidChar:
          begin
            // Simply delete the offending char
            Delete(Suggestion, FailPosition, 1);
          end;
        flMissingUser:
          begin
            // The situation can't get better so exit
            Result := False;
            exit;
          end;
        flMissingDomain:
          begin
            // The situation can't get better so exit
            Result := False;
            exit;
          end;
        flMissingDomainSeperator:
          begin
            // The best correction we can make here is to go back three spaces
            // and insert a .
            // Instead of checking the length of the string, we'll let an
            // exception shoot since at this point we can't make things any better
            // (suggestion wise)
            Insert('.', Suggestion, Length(Suggestion) - 2);
          end;
        flMissingGeneralDomain:
          begin
            // The situation can't get better so exit
            Result := False;
            exit;
          end;
        flToManyAtSymbols:
          begin
            // The situation can't get better so exit
            Result := False;
            exit;
          end;
      end; // case
    end; // for
    // If we got here fail
    Result := False;
  except
    // Just return false
    Result := false;
  end;
end;

// ---------------------------ooo------------------------------ \\
// This function will validate an address, much further than
// simply verifying the syntax as the RFC (821) requires
// ---------------------------ooo------------------------------ \\

function ValidateEmailAddress;
var
  DataLen, SepPos, Itt, DomainStrLen, UserStrLen, LastSep, SepCount, PrevSep: Integer;
  UserStr, DomainStr, SubDomain: string;
begin
  try
    // Get the data length
    DataLen := Length(Email);
    // Make sure that the string is not blank
    if DataLen = 0 then
    begin
      // Set the result and exit
      FailCode := flToSmall;
      Result := False;
      Exit;
    end;
    // First real validation, ensure the @ seperator
    SepPos := Pos('@', Email);
    if SepPos = 0 then
    begin
      // Set the result and exit
      FailCode := flNoSeperator;
      Result := False;
      Exit;
    end;
    // Now verify that only the allowed characters are in the system
    for Itt := 1 to DataLen do // Iterate
    begin
      // Make sure the character is allowed
      if not (Email[Itt] in AllowedEmailChars) then
      begin
        // Report an invalid char error and the location
        FailCode := flInvalidChar;
        FailPosition := Itt;
        result := False;
        exit;
      end;
    end; // for
    // Now split the string into the two elements: user and domain
    UserStr := Copy(Email, 1, SepPos - 1);
    DomainStr := Copy(Email, SepPos + 1, DataLen);
    // If either the user or domain is missing then there's an error
    if (UserStr = '') then
    begin
      // Report a missing section and exit
      FailCode := flMissingUser;
      Result := False;
      exit;
    end;
    if (DomainStr = '') then
    begin
      // Report a missing section and exit
      FailCode := flMissingDomain;
      Result := False;
      exit;
    end;
    // Now get the lengths of the two portions
    DomainStrLen := Length(DomainStr);
    UserStrLen := Length(UserStr);
    // Ensure that either one of the sides is not to large (per the standard)
    if DomainStrLen > MaxDomainPortion then
    begin
      FailCode := flDomainNameToLong;
      Result := False;
      exit;
    end;
    if UserStrLen > MaxUserNamePortion then
    begin
      FailCode := flUserNameToLong;
      Result := False;
      exit;
    end;
    // Now verify the user portion of the email address
    // Ensure that the period is neither the first or last char (or the only char)
    // Check first char
    if (UserStr[1] = '.') then
    begin
      // Report a missing section and exit
      FailCode := flInvalidChar;
      Result := False;
      FailPosition := 1;
      exit;
    end;
    // Check end char
    if (UserStr[UserStrLen] = '.') then
    begin
      // Report a missing section and exit
      FailCode := flInvalidChar;
      Result := False;
      FailPosition := UserStrLen;
      exit;
    end;
    // No direct checking for a single char is needed since the previous two
    // checks would have detected it.
    // Ensure no subsequent periods
    for Itt := 1 to UserStrLen do // Iterate
    begin
      if UserStr[Itt] = '.' then
      begin
        // Check the next char, to make sure it's not a .
        if UserStr[Itt + 1] = '.' then
        begin
          // Report the error
          FailCode := flInvalidChar;
          Result := False;
          FailPosition := Itt;
          exit;
        end;
      end;
    end; // for
    { At this point, we've validated the user name, and will now move into the domain.}
    // Ensure that the period is neither the first or last char (or the only char)
    // Check first char
    if (DomainStr[1] = '.') then
    begin
      // Report a missing section and exit
      FailCode := flInvalidChar;
      Result := False;
      // The position here needs to have the user name portion added to it
      // to get the right number, + 1 for the now missing @
      FailPosition := UserStrLen + 2;
      exit;
    end;
    // Check end char
    if (DomainStr[DomainStrLen] = '.') then
    begin
      // Report a missing section and exit
      FailCode := flInvalidChar;
      Result := False;
      // The position here needs to have the user name portion added to it
      // to get the right number, + 1 for the now missing @
      FailPosition := UserStrLen + 1 + DomainStrLen;
      exit;
    end;
    // No direct checking for a single char is needed since the previous two
    // checks would have detected it.
    // Ensure no subsequent periods, and while in the loop count the periods, and
    // record the last one, and while checking items, verify that the domain and
    // subdomains to dont start or end with a -
    SepCount := 0;
    LastSep := 0;
    PrevSep := 1; // Start of string
    for Itt := 1 to DomainStrLen do // Iterate
    begin
      if DomainStr[Itt] = '.' then
      begin
        // Check the next char, to make sure it's not a .
        if DomainStr[Itt + 1] = '.' then
        begin
          // Report the error
          FailCode := flInvalidChar;
          Result := False;
          FailPosition := UserStrLen + 1 + Itt;
          exit;
        end;
        // Up the count, record the last sep
        Inc(SepCount);
        LastSep := Itt;
        // Now verify this domain
        SubDomain := Copy(DomainStr, PrevSep, (LastSep) - PrevSep);
        // Make sure it doens't start with a -
        if SubDomain[1] = '-' then
        begin
          FailCode := flInvalidChar;
          Result := False;
          FailPosition := UserStrLen + 1 + (PrevSep);
          exit;
        end;
        // Make sure it doens't end with a -
        if SubDomain[Length(SubDomain)] = '-' then
        begin
          FailCode := flInvalidChar;
          Result := False;
          FailPosition := (UserStrLen + 1) + LastSep - 1;
          exit;
        end;
        // Update the pointer
        PrevSep := LastSep + 1;
      end
      else
      begin
        if DomainStr[Itt] = '@' then
        begin
          // Report an error
          FailPosition := UserStrLen + 1 + Itt;
          FailCode := flToManyAtSymbols;
          result := False;
          exit;
        end;
      end;
    end; // for
    // Verify that there is at least one .
    if SepCount < 1 then
    begin
      FailCode := flMissingDomainSeperator;
      Result := False;
      exit;
    end;
    // Now do some extended work on the final domain the most general (.com)
    // Verify that the lowest level is at least 2 chars
    SubDomain := Copy(DomainStr, LastSep, DomainStrLen);
    if Length(SubDomain) < 2 then
    begin
      FailCode := flMissingGeneralDomain;
      Result := False;
      exit;
    end;
    // Well after all that checking, we should now have a valid address
    Result := True;
  except
    Result := False;
    FailCode := -1;
  end; // try/except
end;

// ---------------------------ooo------------------------------ \\
// This function returns the error string from the constant
// array, and makes sure that the error code is valid, if
// not it returns an invalid error code string.
// ---------------------------ooo------------------------------ \\

function ValidationErrorString(Code: Integer): string;
begin
  // Make sure a valid error code is passed
  if (Code < Low(ErrorDescriptions)) or (Code > High(ErrorDescriptions)) then
  begin
    Result := 'Invalid error code!';
    exit;
  end;
  // Get the error description from the constant array
  Result := ErrorDescriptions[Code];
end;
end.

Show the system menu of a window at the current mouse cursor position

Problem/Question/Abstract:

How can I show the system menu of a window at the position of the mouse cursor and not at the window's title bar?

Answer:

Solve 1:

The problem is that the system menu sends WM_SYSCOMMAND messages to the window identified by Handle, and you are probably looking for WM_COMMAND messages.

r := integer(TrackPopupMenuEx(GetSystemMenu(handle, false), TPM_LEFTALIGN or
  TPM_RETURNCMD or TPM_RIGHTBUTTON or TPM_HORIZONTAL or
  TPM_VERTICAL, x, y, handle, nil));
SendMessage(handle, WM_SYSCOMMAND, r, 0);


Solve 2:

Well, you can pop the system menu up where you want using code like the one below:

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  h: HMENU;
begin
  h := GetSystemMenu(handle, false);
  TrackPopupMenu(h, TPM_LEFTALIGN or TPM_LEFTBUTTON, speedbutton1.Left +
    clientorigin.X, speedbutton1.Top + speedbutton1.Height + clientorigin.y, 0,
      handle, nil);
end;

The problem is that the menu will not work this way. If you use TrackPopupMenu to show the menu its items will send WM_COMMAND messages to the form when clicked by the user. But the form expects WM_SYSCOMMAND messages from the system menu. So you have to trap the WM_COMMAND messages, figure out which of them come from the menu (there will be lots of others, from buttons and the like) and translate them into WM_SYSCOMMAND.

{ ... }
private
{ Private declarations }

procedure WMCommand(var msg: TWMCommand); message WM_COMMAND;
{ ... }

procedure TForm1.WMCommand(var msg: TWMCommand);
begin
  if msg.NotifyCode = 0 then {message comes from a menu}
    if msg.ItemID >= SC_SIZE then
    begin {looks like system menu item}
      PostMessage(handle, WM_SYSCOMMAND, TMessage(msg).WParam,
        TMessage(msg).LParam);
      Exit;
    end;
  inherited;
end;


Solve 3:

There is an undocumented Windows message (Message ID:$313) that can do it:

procedure TForm1.Button1Click(Sender: TObject);
const
  WM_POPUPSYSTEMMENU = $313;
begin
  SendMessage(Handle, WM_POPUPSYSTEMMENU, 0,
    MakeLong(Mouse.CursorPos.X, Mouse.CursorPos.Y));
end;

Interrupt a thread's execution

Problem/Question/Abstract:

Let's say that once I start a thread up, I pop up a progress window that has a cancel button on it to cancel execution of the thread. How do I implement this?

Answer:

To exit a thread created with TThread mid-process (as in a loop), break out of the loop and immediately call Terminate. This sets the Terminated flag to true. Following the loop you should check the Terminated status in the body of the Execute method; something like this:

procedure Execute;
begin
  //...some stuff
  while SomeCondition do
  begin
    // ...do some stuff
    if CancelFlagOfSomeSort then
    begin
      Terminate;
      Break;
    end;
  end;
  if MyTThread.Terminated then
    Exit;
end;

It's important to call Terminate because it will trigger the OnTerminate event, that'll allow your thread to clean up after itself. If you just break out of the thread and don't release resources, you'll create orphan resources in memory, and that is not a good thing to do.

For plain-vanilla threads, all you have to do is exit out of the thread function. That will "kill" the thread. But remember that in either case, the most important thing you have to remember is to free resources that you use during the course of the run. If you don't they'll stay there and occupy memory.

Achieve Record locking with Access 2000

Problem/Question/Abstract:

Have you seen this on Borland Support?

Area: database\ado
Reference Number: 74076
Status: Open
Date Reported: 11/3/99
Severity: Commonly Encountered
Type: Basic Functionality Failure
Problem: Currently, pessimistic record locking does not work with the ADO components because ADO doesn't provide a way to lock a record other than the current record.

Answer:

Well there is a way to lock records on MSAccess 2000 tables. First it requires that you have the developers edition of Microsoft Ado Data Control 6.0 (comes with Visual Studio programs). If you have that then Import it to delphi using the Import ActiveX menu item from the Component menu. You will see that the ActiveX has been added as Adodc on the ActiveX palette.

Create a Form and put as many Adodc components on it as you will need simultaneous locks. Remember this: One Adodc can lock One record in One table at a time. So if you need to lock multiple records on multiple tables, you will need multiple Adodc components (you have the choice of dynamic creation too). Then create a new table in the Access MDB and name it lets say "Lock". Put two fields in it ("lockid" type String and "fldEdt" type integer).

Below are two Functions. One called Lock, that you can use to lock the record, or check if it is locked. The other is called Unlock and you can use it to unlock the record.

function lock(ds: TAdoConnection; LckTable: TAdodc; const s: string;
  rec, CurrentUserId: longint): boolean;
var
  fnd: boolean;
  s1: string;
begin
  s1 := format(s, [trim(inttostr(rec))]);
  LckTable.ConnectionString := ds.ConnectionString;
  LckTable.CursorLocation := 2;
  LckTable.LockType := 2;
  LckTable.CommandType := 2;
  LckTable.RecordSource = 'Lock';
  fnd := false;
  try
    LckTable.refresh;
    if LckTable.Recordset.RecordCount > 0 then
    begin
      LckTable.Recordset.MoveFirst;
      LckTable.Recordset.Find('lockid=''' + s1 + '''', 0, 1, 1);
    end;
    if LckTable.Recordset.RecordCount > 0 then
      if not (LckTable.Recordset.EOF) then
        if LckTable.Recordset.Fields['lockid'].value = s1 then
          fnd := true;
    if not fnd then
      LckTable.Recordset.AddNew('lockid', s1);
    LckTable.Recordset.Fields['fldEdt'].Value := CurrentUserId;
    result := true;
  except
    result := false;
  end;
end;

function Unlock(const s: string; rec: longint; LckTable: TAdodc): boolean;
var
  s1: string;
begin
  s1 := format(s, [trim(inttostr(rec))]);
  try
    LckTable.Recordset.Cancel;
    LckTable.Recordset.Find('lockid=''' + s1 + '''', 0, 1, 0);
    LckTable.Recordset.Delete(1);
    result := true;
  except
    result := false;
  end;
end;

Now you have to do some coding inside your project. When lets say a user requests to open a record (lets say with the unique id 12) from your Customer table. You have an Tadodc that is called lckCustomers and is located on the form called lckForm. Use this code:

if Lock(TCustomer.Connection, lckForm.lckCustomers, 'Customers', 12, 1) then
begin
  // the record has been succesfully locked and you can go on with your
  // editing code
  // ...
end
else
begin
  // Ther record was allready locked by another user.
  // give a message and abort the editing, or continue read only.
  // ...
end;

Now if you want to unlock the record, after the editing just call:

Unlock('Customers', 12, lckForm.lckCustomers);

Warning: The Lock table gets to be very large so when the first user logs in the program, empty the lock table by using a query like 'delete from lock'. You can check if you are the first user by checking for the existence of an ldb
file next to your mdb file. If it doesn't exist, you are the first.

That's about it. Good luck.

How to get the X- and Y-coordinates of Desktop icons

Problem/Question/Abstract:

Does anyone know where the X- and Y-coordinates of the icons on the Windows Desktop are stored/ saved and how I can read and write those values?

Answer:

Since the desktop is a simple ListView (embedded in a few other windows), you'll be able to find it with this (from a little utility of mine). It uses IPCThrd.pas from the IPCXXX demos in the demos directory, for the SharedMem class. You'll have to use that, since otherwise you won't be able to read the information from desktop's memory into your memory.


type
  PInfo = ^TInfo;
  TInfo = packed record
    infoPoint: TPoint;
    infoText: array[0..255] of Char;
    infoItem: TLVItem;
    infoFindInfo: TLVFindInfo;
  end;

  {...}

var
  Info: PInfo;
  IniFile: TRegIniFile;
  Wnd: HWnd;
  Count, I: Integer;
  SharedMem: TSharedMem;
begin
  {Find list view window}
  Wnd := FindWindowEx(GetDesktopWindow, 0, 'Progman', 'Program Manager');
  Wnd := FindWindowEx(Wnd, 0, 'SHELLDLL_DefView', nil);
  Wnd := FindWindowEx(Wnd, 0, 'SysListView32', nil);
  Count := ListView_GetItemCount(Wnd);
  SharedMem := TSharedMem.Create('', SizeOf(TInfo));
  Info := SharedMem.Buffer;
  with Info^ do
  try
    infoItem.pszText := infoText;
    infoItem.cchTextMax := 255;
    infoItem.mask := LVIF_TEXT;
    IniFile := TRegIniFile.Create('Software\YaddaYadda');
    try
      with IniFile do
      begin
        EraseSection('Desktop\' + CurRes);
        for I := 0 to Count - 1 do
        begin
          infoItem.iItem := I;
          try
            ListView_GetItem(Wnd, infoItem);
            ListView_GetItemPosition(Wnd, I, infoPoint);
            WriteString('Desktop\' + CurRes, infoText, Format('%.4d, %.4d', [Point.X,
              Point.Y]));
          except
          end;
        end;
      end;
    finally
      IniFile.Free;
    end;
  finally
    SharedMem.Free;
  end;
end;

Suppress form repaints during calculations

Problem/Question/Abstract:

Is there a way to stop an application from painting during heavy calculations?

Answer:

Call LockWindowUpdate() on your MainForm. Your form will not be redrawn and cannot be moved until you unlock it by passing 0 as the window handle.

Note that LockWindowUpdate() does not hide the form nor does it reset the WS_VISIBLE style bit.

  
LockWindowUpdate(MainForm.Handle); // pass the handle of window to lock

// heavy calculation here

LockWindowUpdate(0); // unlock it

How to disable/ enable a menu item depending on the user and his password

Problem/Question/Abstract:

I want to enable/ disable the menu items of a TMainMenu according to the user and his password. With the property Items I can only reach the subitems of each one of the main items. Is it possible to process all the items (independently of its parent) by its Name or Tag property?

Answer:

Well, this is basically a lookup task. If all the menu items are created at design-time the form will have fields for them and you can find them by name using the forms FindComponent method, using the menu items Name property. If you want to find items by Tag value you have to iterate either over the menu items (recursively) , starting at the forms Menu property, or over the forms Components array, looking for components of class TMenuitem.

function Tform1.FindMenuItemByTag(atag: Integer): TMenuItem;

  function FindItems(anItem: TMenuItem; aTag: Integer): TMenuItem;
  var
    i: Integer;
  begin
    Result := nil;
    if Assigned(anItem) then
    begin
      if anItem.Tag = aTag then
        Result := anItem
      else
      begin
        for i := 0 to anItem.Count - 1 do
        begin
          Result := FindItems(anItem[i], aTag);
          if Assigned(result) then
            Break;
        end;
      end;
    end;
  end;

begin
  if Assigned(Menu) then
    Result := FindItems(Menu.Items, atag)
  else
    Result := nil;
end;

How to delete lines from a text file

Problem/Question/Abstract:

How can I open a file and add lines which start with PIL to a listbox. When I delete the appropriate line in the listbox, the line in the file should also be deleted.

Answer:

Load the complete file into a TStringList instance. Then iterate over the Items in the list and use the Pos function to check if the line starts with PIL, if it does you add it to the listbox. When time comes to save the possibly changed file back you again walk over the items in the listbox, but this times you do it from last to first. For each line that starts with PIL you use the listbox.items.indexof method to see if it is in the listbox, if not you delete it from the stringlist. Then you write the stringlist back to file. Example:

In the forms private section you declare a field

FFilelines: TStringList;

In the forms OnCreate event you create this list:

FFilelines := TStringList.Create;

In the forms OnDestroy event you destroy the list:

FFilelines.Free;

On file load you do this:

FFilelines.Loadfromfile(filename);
listbox1.items.beginupdate;
try
  listbox1.clear;
  for i := 0 to FFilelines.count - 1 do
    if Pos('PIL', FFilelines[i]) = 1 then
      listbox1.items.add(FFilelines[i]);
finally
  listbox1.items.endupdate;
end;

To save the file you do this:

for i := FFilelines.count - 1 downto 0 do
  if Pos('PIL', FFilelines[i]) = 1 then
    if listbox1.items.indexof(FFilelines[i]) < 0 then
      FFilelines.Delete(i);
FFilelines.SaveToFile(filename);

How to adjust RGB values using TTrackBar

Problem/Question/Abstract:

I would like to program an application in which you can control values of red, green and blue with trackbar. How can I do that?

Answer:

Solve 1:

Drop three TrackBars on a form. Set Min to 0, Max to 255. Drop a TImage on the form. Then try this code:

{ ... }
var
  Form1: TForm1;
  MyColor: LongWord;
  RedColor: LongWord = $00000000;
  GreenColor: LongWord = $00000000;
  BlueColor: LongWord = $00000000;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  DoImageFill;
end;

procedure TForm1.DoImageFill;
begin
  MyColor := RedColor or GreenColor or BlueColor;
  Image1.Canvas.Brush.Color := TColor(MyColor);
  Image1.Canvas.FillRect(Rect(0, 0, Image1.Width, Image1.Height));
end;

procedure TForm1.RedBarChange(Sender: TObject);
begin
  RedColor := RedBar.Position;
  DoImageFill;
end;

procedure TForm1.GreenBarChange(Sender: TObject);
begin
  GreenColor := GreenBar.Position shl 8;
  DoImageFill;
end;

procedure TForm1.BlueBarChange(Sender: TObject);
begin
  BlueColor := BlueBar.Position shl 16;
  DoImageFill;
end;

end.


Solve 2:

Each color value ranges from 0 to 255. Set the three trackbars with this range. You can use the RGB function to create a color from these values.

{ ... }
type
  TForm1 = class(TForm)
    redTrackBar: TTrackBar;
    greenTrackBar: TTrackBar;
    blueTrackBar: TTrackBar;
    Panel1: TPanel;
    procedure blueTrackBarChange(Sender: TObject);
    procedure greenTrackBarChange(Sender: TObject);
    procedure redTrackBarChange(Sender: TObject);
  public
    { Public declarations }
    procedure ChangeColor;
  end;

procedure TForm1.ChangeColor;
begin
  Panel1.Color := RGB(redTrackBar.Position, greenTrackBar.Position, blueTrackBar.Position);
end;

procedure TForm1.blueTrackBarChange(Sender: TObject);
begin
  ChangeColor;
end;

procedure TForm1.greenTrackBarChange(Sender: TObject);
begin
  ChangeColor;
end;

procedure TForm1.redTrackBarChange(Sender: TObject);
begin
  ChangeColor;
end;

How to use an item ID in a TTreeView as a unique number

Problem/Question/Abstract:

Is the ItemID a unique number for a node on the tree at hand only? Apparently this ID is not a true handle like for Windows that changes from time to time. I can run two instances of the same treeview object and the root node always has a number 5704360 and the second node always has the 5704400. These item IDs are cast to integers. I am trying to create an Outline editor, using a memo and a treeview and save the data in the memo to a stream along with some sort of unique identifier in order to be able to move nodes around without loosing a nodes assignment to a block of memo data. I thought about adding the itemid to the front of the block of data and remove it from the data while streaming the data back into the memo. Am I going in the wrong direction or what?

Answer:

I tend towards maintaining my own Ids and TreeNodes in a list:

TMemoSource = class(TPersisent)
private
  FId: Integer;
  FNode: TTreeNode;
  FStrings: TStringList;
  function GetStrings: TStrings;
  procedure SetStrings(Value: TStrings);
public
  property Id: Integer read FId write FId;
  property Node: TTreeNode read FNode write FNode;
  property Strings: TStrings read GetStrings write SetStrings;
end;

TMemoSources = class(TList)
private
  FNextId: Integer; {FNextId needs to be saved/initialised on application close/ run}
  function Get(Index: Integer): TMemoSource;
  procedure Put(Index: Integer; Item: TMemoSource);
public
  function AddItem: TMemoSource;
  property NextId: Integer read FNextId write FNextId;
  property Items[Index: Integer]: TMemoSource read Get write Put;
end;

function TMemoSources.AddItem: TAMemoSource;
var
  Item: TMemoSource;
begin
  Item := TMemoSource.Create;
  Inc(FNextId);
  Item.Id := FNextId;
  inherited Add(Item);
  Result := Item;
end;

I'll let you fill in the other class methods ...

Example of using:

procedure TForm1.AddMemoToTree(ANode: TTreeNode; AMemo: TMemo);
var
  Ms: TMemoSource;
begin
  Ms := MemoSources1.AddItem;
  Ms.Strings.Assign(AMemo.Lines);
  Ms.Node := TreeView1.Items.AddChildObject(ANode, 'Memo' + IntToStr(Ms.Id), Ms);
end;

I find the biggest advantage of maintaining a list is you can hunt the list by Id or Node rather than the treeview. The list approach also lends itself to dynamically adding and deleting nodes to the treeview in the OnExpanding and OnCollapsing events remembering to set Ms.Node := nil if you delete a treenode and don't delete the corresponding memosource.

How to check if all characters in a string are valid

Problem/Question/Abstract:

Is there a simple way of checking if all characters in a string are valid? For example valid chars are: "ABCabcd123". If the string I want to check contains "AA23c" it is valid, if it contains "AAY" it is invalid.

Answer:

This is one way to do it:

{ ... }
const
  ValidChars = 'ABCabcd123';
type
  EInvalidText = class(Exception);
var
  iCount: Integer;
begin
  for iCount := 1 to Length(Edit1.Text) do
    if Pos(Edit1.Text[iCount], ValidChars) = 0 then
      raise EInvalidText.Create('Invalid text entered.');
end;