Putting a ProgressBar on a StatusBar

Problem/Question/Abstract:

Putting a ProgressBar on a StatusBar

Answer:

Many programs out there display a progress bar on the status bar. Internet Explorer is one of those. However, Delphi doesn't have component with that feature built-in. But that doesn't prevent us from having a progress bar inside a status bar panel. This is what this trick will tech you.

To make this tip work, create a form with a StatusBar (let's accept the default name: StatusBar1). Add a few panels to it.

To the public section of the form class declaration, add:

ProgressBar1: TProgressBar;

To the OnCreate event handler of the form, add:

var
  ProgressBarStyle: LongInt;
begin
  {create a run progress bar in the status bar}
  ProgressBar1 := TProgressBar.Create(StatusBar1);
  ProgressBar1.Parent := StatusBar1;
  {remove progress bar border}
  ProgressBarStyle := GetWindowLong(ProgressBar1.Handle, GWL_EXSTYLE);
  ProgressBarStyle := ProgressBarStyle - WS_EX_STATICEDGE;
  SetWindowLong(ProgressBar1.Handle, GWL_EXSTYLE, ProgressBarStyle);
  {set progress bar position and size - put in Panel[2]}
  ProgressBar1.Left := StatusBar1.Panels.Items[0].Width +
    StatusBar1.Panels.Items[1].Width + 4;
  ProgressBar1.Top := 4;
  ProgressBar1.Height := StatusBar1.Height - 6;
  ProgressBar1.Width := StatusBar1.Panels.Items[2].Width - 6;
  {set range and initial state}
  ProgressBar1.Min := 0;
  ProgressBar1.Max := 100;
  ProgressBar1.Step := 1;
  ProgressBar1.Position := 0;
end;
  
In the OnDestroy event handler of the form, add:

ProgressBar1.free;

If the position of the ProgressBar within the StatusBar doesn't please you, you can change the top, left, height and width properties of the ProgressBar. You can also change the Step, Max and Min properties of the ProgressBar. Within your program, work with the progress bar as you normally would, by accessing it's Position property.

Set the wallpaper with your application in Win32

Problem/Question/Abstract:

Set the wallpaper with your application in Win32

Answer:

To the wallpaper in Windows 95/ Windows NT you must use the Win32 API function SystemParametersInfo.
SystemParametersInfo retrieves and sets system wide parameters including the wallpaper.


SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, 'c:\Windows\Seaside.bmp', 0)

How to fill the undo buffer with the content of a TMemo

Problem/Question/Abstract:

When I type into a TMemo and then press ctrl+Z as usual, the last change is removed. But if I programmatically add text through memo1.seltext := 'newtext'; the ctrl+Z does not work. Why is this and is there a workaround?

Answer:

That's the way MS designed the multiline edit control to work. There is no way to tell it programmatically to save the current content to the undo buffer, you can only tell it to clear the undo buffer or to undo the last operation.

A hack that may work to trick it into filling the undo buffer is this.

{ ... }
with memo1 do
begin
  perform(WM_CHAR, 32, 0);
  sellength := -1;
  seltext := someText;
end;

Get the path of a BDE alias at runtime

Problem/Question/Abstract:

I need to find out the path of a BDE alias from within an application. I would like to auto detect a backup path to the data.

Answer:

function GetAliasDir(alias: PChar): PChar;
var
  s: TStringList;
  i: integer;
  t: string;
  res: array[0..255] of char;
begin
  res := '';
  if Session.IsAlias(alias) then
  begin {Check if alias exists}
    s := TStringList.Create;
    try
      Session.GetAliasParams(Alias, s);
      t := '';
      if s.count > 0 then
      begin
        i := 0;
        while (i < s.count) and (Copy(s.Strings[i], 1, 5) <> 'PATH=') do
          inc(i);
        if (i < s.count) and (Copy(s.Strings[i], 1, 5) = 'PATH =') then
        begin
          t := Copy(s.Strings[i], 6, Length(s.Strings[i]) - 4);
          if t[length(t)] <> '\' then
            t := t + '\';
        end;
      end;
      StrPCopy(res, t);
    except
      StrPCopy(res, '');
    end;
    s.Free;
  end;
  result := res;
end;

How to fill a TDBListBox from a dataset

Problem/Question/Abstract:

How to fill a TDBListBox from a dataset

Answer:

procedure TForm1.FormCreate(Sender: TObject);
begin
  with table1 do
  begin
    open;
    while not EOF do
    begin
      DBlistbox1.items.add(FieldByName('name').AsString);
      next;
    end;
  end;
end;

Setting Properties

Problem/Question/Abstract:

Setting Properties

Answer:

If you have many components of same type on a form and want to set properties to all of them. You don't need to select one by one. Just select them all and set properties you want and they'll be set to all of them.

BDE limits

Problem/Question/Abstract:

BDE limits

Answer:

Table and Index Files
48
Clients in system
32
Sessions per client (3.5 and earlier, 16 Bit, 32 Bit)
256
Session per client (4.0, 32 Bit)
32
Open databases per session (3.5 and earlier, 16 Bit, 32 Bit)
2048
Open databases per session (4.0, 32 Bit)
32
Loaded drivers
64
Sessions in system (3.5 and earlier, 16 Bit, 32 Bit)
12288
Sessions in system (4.0, 32 Bit)
4000
Cursors per session
16
Entries in error stack
8
Table types per driver
16
Field types per driver
8
Index types per driver
48K
Size of configuration (IDAPI.CFG) file
64K
Size of SQL statement (RequestLive=False)
4K
Size of SQL statement (RequestLive=True)
16K
Record buffer size (SQL or ODBC)

How to validate ISBN's?

Problem/Question/Abstract:

ISBNs (or International Standard Book Numbers) are mystical code numbers that uniquely identify books. The purpose of this article is to remove the mystery surrounding the structure of the ISBN, allowing applications to perform data validation on entered candidate ISBNs.

Answer:

ISBNs are composed of thirteen characters, limited to the number characters "0" through "9", the hyphen, and the letter "X". This thirteen-character code is divided into four parts, each separated by hyphens: group identifier, publisher identifier, book identification for the publisher, and the check digit. The first part (group identifier) is used to identify countries, geographical regions, languages, etc. The second part (publisher identifier) uniquely identifies the publisher. The third part (book identifier) uniquely identifies a given book within a publisher's collection. The fourth and final part (check digit) is used with the other digits in the code in an algorithm to derive a verifiable ISBN. The number of digits in the first three parts of an ISBN may contain a variable number of digits, but the check digit will always consist of a single character (between "0" and "9", or "X" for a value of 10) and the
ISBN as a whole will always consists of thirteen characters (ten numbers plus the three hyphens dividing the four parts of the ISBN).

The ISBN 3-88053-002-5 breaks down into the parts:

  Group:       3
  Publisher:   88053
  Book:        002
  Check Digit: 5

An ISBN can be verified to be a valid code using a simple mathematical algorithm. This algorithm takes each of the nine single digits from the first three parts if the ISBN (sans the non-numeric hyphens), multiplies each single digit by a number that is less than eleven the number of positions from the left each digit that is in the ISBN, adds together the result of each multiplication plus the check digit, and then divides that number by eleven. If that division by eleven results in no remainder (i.e., the number is modulo 11), the candidate ISBN is a valid ISBN. For example, using the previous sample ISBN 3-88053-002-5:

  ISBN:              3  8  8  0  5  3  0  0  2  5
  Digit Multiplier: 10  9  8  7  6  5  4  3  2  1
  Product:          30+72+64+00+30+15+00+00+04+05 = 220

Since 220 is evenly divisible by eleven, this candidate IDBN is a valid ISBN code.

This verification algorithm is easily translated into Pascal/Delphi code.
String manipulation functions and procedures are used to extract the check digit and the remainder of the ISBN from the String type value passed to a validation function. The check digit is converted to Integer type, which forms the start value of the aggregate variable onto which the multiplication of each digit in the remainder of the ISBN (the single digits that comprise the first three parts of the ISBN) will be added. A For loop is used to sequentially process each digit in the remainder, ignoring the hyphens, multiplying each digit times its position in the ISBN remainder relative to the other digits in the remainder. The final value of this aggregate variable is then checked to see whether it is evenly divisible by eleven (indicating a valid ISBN) or not (indicating an invalid candidate ISBN).

Here is an example of this methodology applied in a Delphi function:

function IsISBN(ISBN: string): Boolean;
var
  Number, CheckDigit: string;
  CheckValue, CheckSum, Err: Integer;
  i, Cnt: Word;

begin
  // Get check digit
  CheckDigit := Copy(ISBN, Length(ISBN), 1);
  // Get rest of ISBN, minus check digit and its hyphen
  Number := Copy(ISBN, 1, Length(ISBN) - 2);
  // Length of ISBN remainder must be 11 and check digit between 9 and 9 or X
  if (Length(Number) = 11) and (Pos(CheckDigit, '0123456789X') > 0) then
  begin
    // Get numeric value for check digit
    if (CheckDigit = 'X') then
      CheckSum := 10
    else
      Val(CheckDigit, CheckSum, Err);
    // Iterate through ISBN remainder, applying decode algorithm
    Cnt := 1;
    for i := 1 to 12 do
    begin
      // Act only if current character is between "0" and "9" to exclude hyphens
      if (Pos(Number[i], '0123456789') > 0) then
      begin
        Val(Number[i], CheckValue, Err);
        // Algorithm for each character in ISBN remainder, Cnt is the nth character
        //    so processed
        CheckSum := CheckSum + CheckValue * (11 - Cnt);
        Inc(Cnt);
      end;
    end;
    // Verify final value is evenly divisible by 11
    if (CheckSum mod 11 = 0) then
      IsISBN := True
    else
      IsISBN := False;
  end
  else
    IsISBN := False;
end;

This is a simplified example, kept simple to best demonstrate the algorithm to decode ISBNs. There are a number of additional features that would be desirable to add for use in a real-world application. For instance, this example function requires the candidate ISBN be passed as a Pascal String type value, with the hyphens dividing the four parts of the ISBN. Added functionality might accommodate evaluating candidate ISBNs entered without the hyphens. Another feature that might be added is checking that ensures three hyphens are properly included, as opposed to just thirteen number characters.

Converting a integer containing millisecs to a nice formated string

Problem/Question/Abstract:

Converting a integer containing millisecs to a nice formated string.

Answer:

This routine formats an integer representing milliseconds into a nice formated string:  HH:MM:SS:Ms.
I use it in an audio application.

function MSecToStr(MSec: Integer): string;
begin
  Result := FormatFloat('00', MSec mod 1000 div 10); // msec
  MSec := MSec div 1000;
  Result := FormatFloat('00', MSec mod 60) + ':' + Result; // sec
  MSec := MSec div 60;
  Result := FormatFloat('00', MSec mod 60) + ':' + Result; // min
  MSec := MSec div 60;
  Result := IntToStr(MSec mod 60) + ':' + Result; // hour
end;

Map Generator

Problem/Question/Abstract:

How to implement a map generator in Delphi whioch produces rectangular maps with land or sea.

Answer:

The algorithm is very simple- I throw a few land points onto an empty map constraining the initial points so they don't drop near the edge. I then throw a few sea points down as well. Next I draw circles around each point (one circle round all the land points then repeat for the sea points), and repeat up to 12 layers (the constant Max-Layers defines this).

Circle data is defined in the data file Data.pas. This contains data for 35 concentric circular layers about the point at coordinates 0,0. The array layerpoints holds the number of points in each layer, offset indicates where a layer starts in the array C (Yeah stupid name- ah well) which holds all the points as offsets - ie the first layer has 8 points and the first 8 points at offset 0 in C are -1,-1,0,-1,1,-1,-1,0,1,0,-1,1,0,1,1,1, ie (-1,-1), (0,-1) (1,-1) etc up to (1,1) . Just add these to the point to give the coordinates of all points round it- these are set to land or sea as long as they are empty- so when land hits sea it defines the coast. An optimisation here is that each original point is switched off when the object attempts to grow a layer of points around it. If it succeeds in placing one new point then the original point is switched back on.

Once the initial map has been produced it is tidied by removing small continents (any below a threshold size defined in mincontsize). Island and sea sizes are counted by using a recursive fill algorithm. Each terrain square has a continent number which is set during the count- basically the refill routine sets the continent number if it is land then calls itself for all 8 squares around it.

The final step is to output the count of those continents that haven't been removed due to being too small and then plonk the continent number on the map in the approx centre of the continent (I calculate the average centre coordinate).


Component Download: MapGen.zip

BDE Safe Configuration check

Problem/Question/Abstract:

Running the BDE in a safe mode requires some settings in the BDE Administrator tool. This unit checks if the BDE has been configured correctly (LocalShare=True, NetDir=\\...). Also the PrivDir will be managed by this unit, a unique PrivDir will be created and cleaned up every time the (your) program is run.

Answer:

unit modBDETools;

{ module Borland Database Engine Tools
  Author: E.J.Molendijk
  Mail: erwin@delphi-factory.com

  When this unit is linked into the project the PrivDir of
  the global Session variable will be set to a
  unique directory within the (local) system temp dir.
  When the application ends, this private dir
  will be cleaned up.

  Also a routine CheckBDEConfig() can be called to check if the
  BDE is configured for safe opperation.

Hint, for best performance set the BDE to:

  Setting                             Value
  -------------------------------------------------------------
  \System\INIT\LANGDRIVER             'ascii' ANSI (DBWINUS0)
  \System\INIT\MAXBUFSIZE             16384 KB
  \System\INIT\MINBUFSIZE             128 KB
  \System\INIT\MAXFILEHANDLES         100
}

interface

uses
  DB, DBTables, BDE, SysUtils, Windows, FileCtrl, ComObj;

{ This function returns True if the BDE is configured
  with a NetWork directory with an UNC path (\\server\share)
  and has LocalShare set to True.
  The Msg param will be filled with a msg describing the problem. }
function CheckBDEConfig(var Msg: string): Boolean;

implementation

const
  { Here are the parameters used to pass into the cfg functions.  These are only
    a small portion of what types can be passed in.  You need to call
    DbiOpenCfgInfoList with '\' into pszCfgPath to get all possible options if
    it is not found below. }

  { Paradox Driver Settings...  }
  PARADOXNETDIR = '\DRIVERS\PARADOX\INIT\;NET DIR';
  PARADOXVERSION = '\DRIVERS\PARADOX\INIT\;VERSION';
  PARADOXTYPE = '\DRIVERS\PARADOX\INIT\;TYPE';
  PARADOXLANGDRIVER = '\DRIVERS\PARADOX\INIT\;LANGDRIVER';
  PARADOXLEVEL = '\DRIVERS\PARADOX\TABLE CREATE\;LEVEL';
  PARADOXBLOCKSIZE = '\DRIVERS\PARADOX\TABLE CREATE\;BLOCK SIZE';
  PARADOXFILLFACTOR = '\DRIVERS\PARADOX\TABLE CREATE\;FILL FACTOR';
  PARADOXSTRICTINTEGRITY = '\DRIVERS\PARADOX\TABLE CREATE\;STRICTINTEGRITY';

  { System Initialization Settings...  }
  AUTOODBC = '\SYSTEM\INIT\;AUTO ODBC';
  DATAREPOSITORY = '\SYSTEM\INIT\;DATA REPOSITORY';
  DEFAULTDRIVER = '\SYSTEM\INIT\;DEFAULT DRIVER';
  LANGDRIVER = '\SYSTEM\INIT\;LANGDRIVER';
  LOCALSHARE = '\SYSTEM\INIT\;LOCAL SHARE';
  LOWMEMORYUSAGELIMIT = '\SYSTEM\INIT\;LOW MEMORY USAGE LIMIT';
  MAXBUFSIZE = '\SYSTEM\INIT\;MAXBUFSIZE';
  MAXFILEHANDLES = '\SYSTEM\INIT\;MAXFILEHANDLES';
  MEMSIZE = '\SYSTEM\INIT\;MEMSIZE';
  MINBUFSIZE = '\SYSTEM\INIT\;MINBUFSIZE';
  SHAREDMEMLOCATION = '\SYSTEM\INIT\;SHAREDMEMLOCATION';
  SHAREDMEMSIZE = '\SYSTEM\INIT\;SHAREDMEMSIZE';
  SQLQRYMODE = '\SYSTEM\INIT\;SQLQRYMODE';
  SYSFLAGS = '\SYSTEM\INIT\;SYSFLAGS';
  VERSION = '\SYSTEM\INIT\;VERSION';

type
  pword = ^word;

function GetBDEConfigParameter(Param: string; Count: pword): string;
var
  hCur: hDBICur;
  rslt: DBIResult;
  Config: CFGDesc;
  Path, Option: string[254];
  Temp: array[0..255] of char;

begin
  Result := '';
  hCur := nil;

  if Count <> nil then
    Count^ := 0;

  try

    if Pos(';', Param) = 0 then
      raise EDatabaseError.Create('Invalid parameter passed to function.  There must '
        +
        'be a semi-colon delimited sting passed');

    Path := Copy(Param, 0, Pos(';', Param) - 1);
    Option := Copy(Param, Pos(';', Param) + 1, Length(Param) - Pos(';', Param));

    Check(DbiOpenCfgInfoList(nil, dbiREADONLY, cfgPERSISTENT, StrPCopy(Temp, Path),
      hCur));
    Check(DbiSetToBegin(hCur));

    repeat
      rslt := DbiGetNextRecord(hCur, dbiNOLOCK, @Config, nil);
      if rslt = DBIERR_NONE then
      begin
        if StrPas(Config.szNodeName) = Option then
          Result := Config.szValue;
        if Count <> nil then
          Inc(Count^);
      end
      else if rslt <> DBIERR_EOF then
        Check(rslt);
    until rslt <> DBIERR_NONE;

  finally
    if hCur <> nil then
      Check(DbiCloseCursor(hCur));
  end;
end;

procedure PrepareBDEPrivDir;
{
  The PrivDirID constant is used to create the Session.PrivDir
  Complete private path:  TempPath\PrivDirID\RandomStr

  The RandomStr (GUI) will ensure a unique path every time the
  program is started.
  The PrivDirID can be used (by batchfile) to delete all junk RandomStr's
  left over from abnormal program terminations.

  Note: CleanupBDEPrivDir cleans up the dir created by this routine.
}
const
  PrivDirID = 'CharonPrivDir';
var
  Temp: string;
  I: Integer;
begin
  // Get a temp directory name for private dir
  I := GetTempPath(0, pchar(Temp)); // get length
  SetLength(Temp, I); // prepare for this length
  GetTempPath(I, pchar(Temp)); // retreive temp path
  SetLength(Temp, I - 1); // remove #0
  Temp := IncludeTrailingBackSlash(Temp); // inlcude a trailing slash

  // construct a unique temppath
  Temp := Temp + PrivDirID + '\' + CreateClassID;

  // create the directory
  ForceDirectories(Temp);

  // Set the PrivDir
  Session.PrivateDir := Temp;

  //  ShowMessage('Private directory: '+Temp);
end;

procedure CleanupBDEPrivDir;
{ Cleansup the Private dir.
  (all database connections will be closed!)
}
var
  CleanUpOK: Boolean;
begin
  // Close the session -- this will empty the PrivDir
  Session.Close;

  // Remove the PrivDir
  CleanUpOK := RemoveDir(Session.PrivateDir);

  Assert(CleanUpOK);
end;

function CheckBDEConfig(var Msg: string): Boolean;
const
  strTrue = 'TRUE'; { do not localize }

var
  NetDir, LocalShare: string;

begin
  // Get BDE settings
  NetDir := GetBDEConfigParameter(PARADOXNETDIR, nil);
  LocalShare := Uppercase(Trim(GetBDEConfigParameter(modBDETools.LOCALSHARE, nil)));

  Msg := '';

  if Pos('\\', NetDir) <> 1 then
    Msg := 'Set the NetDir option in the BDE Administrator to an UNC path.';

  if LocalShare <> strTrue then
    Msg := 'Set the LocalShare option in the BDE Administrator to TRUE.';

  // Check them
  Result := Msg = '';
end;

initialization
  PrepareBDEPrivDir;

finalization
  CleanupBDEPrivDir;

end.

Executing TIBStoredProc with one line of code

Problem/Question/Abstract:

Running a TIBStoredProc as if it where a delphi procedure.

Answer:

{
Copyright (c) 2001 by E.J.Molendijk

TIBStoredProc is handy, but multiple lines of code are required to execute it. The routine in this article handles preparing, assigning params, execution and transactions for you.
}

{
  ExecSP
  Execute a InterBase Stored Procedure.
  Transaction gets Committed after excution.

  input:
    SP = InterBase Stored Procedure
    P  = Array with parameters for the SP. No param checking!

  output:
    Check the SP.Params for output (if any).
}

procedure TSPMod.ExecSP(SP: TIBStoredProc; P: array of Variant);
var
  A, B: Integer;
begin
  // make sure there's a transaction context
  if not SP.Transaction.Active then
    SP.Transaction.StartTransaction;

  try
    // make sure stored procedure is closed
    SP.Close;

    // prepare (attach params)
    if not SP.Prepared then
      SP.Prepare;

    // Set all Input params
    B := 0;
    for A := 0 to SP.ParamCount - 1 do
      if (SP.Params[A].ParamType in [ptInput, ptInputOutput]) then
      begin
        SP.Params[A].Value := P[B];
        Inc(B);
      end;

    // run the procedure on the server
    SP.ExecProc;
  finally
    // commit
    SP.Transaction.Commit;
  end;
end;

Examples:

Assume you have a datamodule called SPMod. And assume it contains some stored procedures:

SPMod.spOpenenSession
SPMod.spGetTicketNr

The following routines can be added to encapsulate the StoredProcs.

// Example without returning data:

procedure TSPMod.OpenSession(SessionID: Integer);
begin
  ExecSP(spOpenSession, [SessionID]);
end;

// Example with a integer as result

function TSPMod.GetTicketNr: Integer;
begin
  ExecSP(spGetTicketNr, [CurrentSessionID]);
  Result := spGetTicketNr.ParamByName('TicketNr').AsInteger;
end;

Calculate the difference between two time values

Problem/Question/Abstract:

How to get the hours and minutes between two DateTime values?

Answer:

Solve 1:

In order to avoid future questions about rounding, I would consider the solution below (untested!):

{ ... }
var
  InTime, OutTime: TDateTime;
  InMinutes, OutMinutes, MinutesDiff: Int64;
  DiffHours, DiffMinutes: Integer;
begin
  { First, make sure that InTime and OutTime are relative to the same offset from GMT. Then:}
  InMinutes := round(InTime * 24 * 60);
  OutMinutes := round(OutTime * 24 * 60);
  MinutesDiff := OutMinutes - InMinutes;
  Assert(MinutesDiff >= 0);
  DiffHours := MinutesDiff div 60;
  DiffMinutes := MinutesDiff mod 60;
end;


Solve 2:

{ ... }
var
  InTime, OutTime, TimeDifference: TDateTime;
  DiffHours, DiffMinutes: Integer;
begin
  TimeDifference := OutTime - InTime;
  {ShowMessage(DateTimeToStr(TimeDifference);}
  DiffHours := trunc(TimeDifference * 24);
  { DiffMinutes := trunc((TimeDifference * 24 * 60) - (Trunc(TimeDifference * 24) * 60))}
  DiffMinutes := trunc((TimeDifference * 24 * 60) - (DiffHours * 60))
end;

Strip illegal characters from a file name

Problem/Question/Abstract:

I am attempting to create a file from a title of a webpage. The title can contain illegal filename characters such as \ / : ? etc. What is the best way to filter out these characters? I want to remove them entirely, and not replace them with a space. Thus, I would like to keep alphanumeric, dashes, underscores, space, and a few other special characters only.

Answer:

Solve 1:

Something like the function below would do. In my code, the function replaces dodgy chars with a replacement, but I guess it would still work if you specificed the 'CunfriendlyReplacement' as an empty string.

{ ... }
const
{$IFDEF WIN32}
  CpathDelimiter = '\';
{$ELSE}
  CpathDelimiter = '/';
{$ENDIF}
  CdelimiterChar = '_';
  CunfriendlyChars = [CpathDelimiter, '.', ':', CdelimiterChar, '/', '<', '>', '|'];
  CunfriendlyReplacement = '-';
  { ... }

function makeNameFileFriendly(const inName: string): string;
var
  charIndex: Integer;
  thisChar: Char;
begin
  result := '';
  for charIndex := 1 to length(inName) do
  begin
    thisChar := inName[charIndex];
    if (thisChar in CunfriendlyChars) then
      result := result + CunfriendlyReplacement
    else
      result := result + thisChar;
  end;
end;


Solve 2:

function ValidateFilename(Filename: WideString): WideString;
var
  i: Integer;
begin
  Result := '';
  for i := 1 to Length(Filename) do
  begin
    if Pos(Filename[i], WideString('\/:*?<>|,' + #34)) = 0 then
      Result := Result + Filename[i];
  end;
  Result := Trim(Result);
end;

Find a word in an Array of String

Problem/Question/Abstract:

How to find a word in an Array of String

Answer:

{ ... }
const
  StringsToSearch: array[0..7] of string = ('hello', 'earth', 'why', 'this', '12',
    'people', 'how', 'what');
var
  Found: Boolean;
  i: Integer;
begin
  Found := False;
  for i := 0 to 7 do
    if Pos(StringsToSearch[i], ALongLongLongString) > 0 then
    begin
      Found := True;
      break;
    end;
  if Found then
    ShowMessage('At least one word was found')
  else
    ShowMessage('No words found');
end;

Increment a file name when the file already exists in a folder

Problem/Question/Abstract:

I am trying to write a simple backup utility for my projects. The utility recursivley searches folders looking for *.dpr files when it finds one it looks to see if a *.dof file is available and then extracts the FileVersion number from this, using this information it then creates a zip file with all the project files in it. It works so far and creates files like Project1-v1.0.0.0.zip. The problem is if the file already exists in the selected backup folder I wish to increment the file name so all versions are kept, e.g. if Project1-v1.0.0.0.zip already exists then generate a filename of Project1-v1.0.0.0-1.zip. If Project1-v1.0.0.0-1.zip exists then generate a file name Project1-v1.0.0.0-2.zip etc. to make sure no files are overwritten.

Answer:

Variants are the easiest way of dealing with these properties.

function GetNextBackupFileName(AFolder, AFile: string): string;
var
  v, v1: Integer;
  Body, Ext: string;
  sr: TSearchRec;

  function FileExt(FileName: string): string;
  begin
    Result := ExtractFileExt(FileName);
  end;

  function FileBody(FileName: string): string;
  begin
    Result := ChangeFileExt(FileName, '');
  end;

  function GetPostFix(FileName: string): Integer;
  begin
    Result := StrToIntDef(Copy(FileBody(FileName), Length(Body) + 1, 255), 0);
  end;

begin
  Result := AFile;
  v := 0;
  Body := FileBody(AFile);
  Ext := FileExt(AFile);
  if FindFirst(AFolder + Body + '*' + Ext, faAnyFile xor faDirectory, sr) = 0 then
  begin
    repeat
      v1 := GetPostFix(sr.Name);
      if v1 < v then
        v := v1;
    until
      FindNext(sr) <> 0;
    FindClose(sr);
    Result := Body + IntToStr(v - 1) + Ext;
  end;
end;

Used like this:

procedure TForm1.Button1Click(Sender: TObject);
var
  BackupFolder, BaseFileName: string;
begin
  BackupFolder := 'C:\BackupFolder\';
  BaseFileName := 'Project1-v1.0.0.0.zip';
  Label1.Caption := GetNextBackupFileName(BackupFolder, BaseFileName);
  FileClose(FileCreate(BackupFolder + Label1.Caption));
end;

Easy way of creating a database application

Problem/Question/Abstract:

How can you create a database application without manually putting the visual components like DBEdit, DBImage etc., and attach that with a field in the table and setting other properties?

Answer:

You don&#8217;t need to write a single line of code for this. All starts with the TTable component.

Let me tell you the steps needed to do this:

Create a new application.
Put a TTable component on the form
Set the database and table name properties
Right click on the TTable component, you will be getting a menu
Select Fields editor
You will be getting a grid
Then right click on the fields Editor.
You will be getting another menu
Then you can either select the Add Fields or Add all fields option.
If you select Add all fields option, all the fields in the table will be added to the fields editor.
Then you just select the fields you want to show up on the form.
Then just drag all the fields on to the form; you are done.
Yes you will be getting the respective DBEdit,DBImage etc., on the form.
Also the datasource component will be added.
For navigation, you can put a Navigator control from the DataControls palette and assign the datasource property for it.
Now the simple database application is ready to use.
You can run the application and work with all the database operations like navigation, edit etc., thro&#8217; the navigator.

For Delphi beginners, this could be enough to start with database application.

The same thing you can do with putting separate control like DBEdit etc., and setting the properties;but here you dont need to set any properties for those controls; all will be set automatically once you drag the fields from the fields editor onto the form.

Get a list of current print jobs

Problem/Question/Abstract:

Is there any way in Delphi to check for the printer queue or if a printer has received and printed a document correctly?

Answer:

No there is not any bullet-proof way of determining that a document has been printed correctly. Nevertheless here is a routine to collect all the running jobs of a printer. Keep in mind that the only way to retrieve this information is by pooling it from the spooler in standard intervals.

{ ... }
type
  PJobInfoArray = ^TJobInfoArray;
  TJobInfoArray = array[0..0] of winspool.JOB_INFO_2;

procedure GetJobs(APrinter: string);
var
  Size, Needed, Returned, CNT: Cardinal;
  Res: LongBool;
  Prn: Cardinal;
  PrnName: Pchar;
  vJobs: PJobInfoArray;
begin
  ReAllocMem(PrnName, Length(aPrinter) + 2);
  CopyMemory(PrnName, @aPrinter[1], Length(aPrinter));
  Res := OpenPrinter(PrnName, Prn, nil);
  ReAllocMem(PrnName, 0);
  if LongInt(Res) = 0 then
    RaiseLastOSError;
  Size := 0;
  Res := WinSpool.EnumJobs(Prn, 0, 999, 2, VJobs, 0, Needed, Returned);
  Size := Needed;
  reAllocMem(VJobs, Size);
  Res := EnumJobs(Prn, 0, 999, 2, vJobs, Size, Needed, Returned);
  if LongInt(Res) > 0 then
  begin
    reAllocMem(vJobs, 0);
    ClosePrinter(Prn);
    RaiseLastOSError;
  end;
  ReAllocMem(VJobs, 0);
  ClosePRinter(Prn);
end;

Changing standard Windows dialogs

Problem/Question/Abstract:

How to change text like "File name:", "File Type" and buttons' text in standard Windows dialogs?

Answer:

Some times we need to replace some text or something other in standard Windows Open/Save dialogs. Unfortunately, Delphi's dialogs components don't provide the access to all controls placed on Windows common dialogs. But we can perform this using Windows API.

Example below demonstrates the changing all embedded text controls in Open dialog.

First, we need to determine identifiers of dialog's controls, they are following:

const
  // LB_FOLDERS_ID = 65535;
  LB_FILETYPES_ID = 1089; // "File types:" label
  LB_FILENAME_ID = 1090; // "File name:" label
  LB_DRIVES_ID = 1091; // "Look in:" label

Second, we need to send message to dialog window for changing necessary controls, something like following:

procedure TForm1.OpenDialog1Show(Sender: TObject);
const
  // LB_FOLDERS_ID = 65535;
  LB_FILETYPES_ID = 1089;
  LB_FILENAME_ID = 1090;
  LB_DRIVES_ID = 1091;
  Str1 = 'Four';
  Str2 = 'Five';
  Str3 = 'One';
  Str4 = 'Two';
  Str5 = 'Three';
begin
  SendMessage(GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, IDOK,
    LongInt(Pchar(Str1)));
  SendMessage(GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, IDCANCEL,
    LongInt(Pchar(Str2)));
  SendMessage(GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, LB_FILETYPES_ID,
    LongInt(Pchar(Str3)));
  SendMessage(GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, LB_FILENAME_ID,
    LongInt(Pchar(Str4)));
  SendMessage(GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, LB_DRIVES_ID,
    LongInt(Pchar(Str5)));
end;

Implement autoscroll for a TScrollbox when dragging

Problem/Question/Abstract:

I have a form with a TScrollBox on it. At runtime I dynamically add any number of a custom control I created. These controls need to interact via Drag and Drop, however, when I drag from one control and move to the edge of the TScrollBox it doesn't automatically scroll to reveal the additional controls.

Answer:

Add a handler to the forms OnDragOver event so you get aware when the user drags the mouse outside the scrollbox. You can the start a timer that fires scroll messages at the scrollbox to get it to move. In the example below all edits are on the scrollbox and share the edit drag handlers. The timer is set to 100 msecs and initially disabled.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ScrollBox1: TScrollBox;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    Edit5: TEdit;
    Edit6: TEdit;
    Edit7: TEdit;
    Edit8: TEdit;
    Edit9: TEdit;
    Edit10: TEdit;
    Edit11: TEdit;
    Edit12: TEdit;
    Edit13: TEdit;
    Label1: TLabel;
    Timer1: TTimer;
    procedure Edit1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState;
      var Accept: Boolean);
    procedure Edit1DragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure Timer1Timer(Sender: TObject);
    procedure FormDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState;
      var Accept: Boolean);
  private
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Edit1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := Source is TEdit and (Sender <> Source);
end;

procedure TForm1.Edit1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
  (Sender as TEdit).SelText := (Source as TEdit).Text;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  pt: TPoint;
begin
  {figure out where the mouse is}
  GetCursorPos(pt);
  pt := ScreenToClient(pt);
  with scrollbox1.boundsrect, pt do
    if (x > left) and (x < right) then
    begin
      if y < top then
        scrollbox1.perform(WM_VSCROLL, SB_LINEUP, 0)
      else if y > bottom then
        scrollbox1.perform(WM_VSCROLL, SB_LINEDOWN, 0)
      else
        timer1.enabled := false;
    end
    else
      timer1.enabled := false;
end;

procedure TForm1.FormDragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  accept := false;
  if State = dsDragLeave then
    timer1.enabled := false
  else if (source is TEdit) then
  begin
    {Figure if mouse is above or below the scrollbox, that determines
    whether we enable the scroll timer.}
    with scrollbox1.boundsrect do
      timer1.enabled := (x > left) and (x < right) and ((y < top) or (y > bottom));
  end;
end;

end.

Delete a line in a TMemo in its OnChange event

Problem/Question/Abstract:

I want to use a TMemo as a FIFO, and every time a new string is written to the memo, the OnChange event will be triggered. In the OnChange event I will do my work on the string and as the last thing make a memo.delete(0) so that the next string in the memo will move to line 0. My question is now, is this a right thing to do? I suppose that it will make a recursive call to the OnChange event and that I in this way have a "system" that will empty my memo as fast as possible.

Answer:

The trick is to save, wipe, and restore the event value:

procedure TForm1.Memo1Change(Sender: TObject);
var
Save: TNotifyEvent;
begin
Save := Memo1.OnChange; {Save}
Memo1.OnChange := nil; {Erase}
Memo1.Lines.Delete(0);
Memo1.OnChange := Save; {Restore}
end;

Synchronize TThreads

Problem/Question/Abstract:

I am using a thread that does some system checks and outputs the results to a TRichEdit, so I need to use a Syncronize(AMethod) to update the interface and the TRichEdit mentioned before. But I cannot do this if AMethod accepts parameters. I would like to pass some parameters to AMethod, but have not been able to do this. Is this possible?

Answer:

Below is the complete code to do this, using the function:

function ExecuteInMainThread(Proc: MainThreadProcType; var Parameter): boolean;

It will call Proc in the main Windows thread and wait for the procedure to finish before returning. Proc takes one untyped variable. If you want to pass more than one variable, put the data into a record and pass the record. You don't really have to code anything. Just copy this code to a unit, use the unit in your code, and call the function. There is no TThread method that does this.

unit ThreadLib;

interface

uses
Windows, Messages, ExtCtrls, Classes, Forms, SyncObjs;

type
MainThreadProcType = procedure(var Parameter) of object;

function ExecuteInMainThread(Proc: MainThreadProcType; var Parameter): boolean;

implementation

uses
SysUtils;

const
UM_EXECMAIN = WM_USER + 590;

type
WindowProcType = function(hWnd: HWND; Msg: UINT; wParam: WPARAM;
lParam: LPARAM): LRESULT; stdcall;

ProcInfoType = record
Method: MainThreadProcType;
Param: pointer;
end;

ProcInfoPtrType = ^ProcInfoType;

var
OrigThreadWndProc: WindowProcType;

function ExecuteInMainThread(Proc: MainThreadProcType; var Parameter): boolean;
var
ProcInfo: ProcInfoType;
begin
if GetCurrentThreadID = MainThreadID then
try
Proc(Parameter);
Result := true;
except
Result := false;
end
else
begin
ProcInfo.Method := Proc;
ProcInfo.Param := @Parameter;
Result := SendMessage(Application.Handle, UM_EXECMAIN, 0, longint(@ProcInfo)) =
ord(true);
{To send a message without waiting for it to return (PostMessage),
make sure that the message parameters do not include pointers. Otherwise,
the functions will return before the receiving thread has had a chance to
process the message and the sender will free the memory before it is used.}
end;
end;

function ParamThreadWndProc(Window: HWND; Message, wParam, lParam: longint):
longint; stdcall;
begin
if Message = UM_EXECMAIN then
try
with ProcInfoPtrType(pointer(lParam))^ do
Method(Param^);
Result := ord(true);
except
Result := ord(false);
end
else
Result := OrigThreadWndProc(Window, Message, wParam, lParam);
end;

begin
OrigThreadWndProc := WindowProcType(SetWindowLong(Application.Handle,
GWL_WNDPROC, longint(@ParamThreadWndProc)));
end.

Create an mht (web page single file) file

Problem/Question/Abstract:

This article tells you how to create a web page archive single file that can be viewed in IE, all images are included in this file. This is the Web Archive, single file (*.mht) option in the IE save as.

Answer:

Solve 1:

Below are 2 versions of the source code to do this.  Also a test application from the component link.

procedure SaveToMHT(const URL, DestFileName: string);

This procedure can be used as long as the threading model has not been set to Multithreaded.  If you try, you will get an "Interface not supported" error.

But if you have already set COM to multithreaded through the CoInitializeEx function then use the other function:

This one:

procedure SaveToMHT_InCOThread(const URL, DestFileName: string);

The difference in this last function is that it runs the 1st function in a separate thread with CoInitialize(nil) called.  This allows you to still call the SaveToMHT when you have previously set COM to multithreaded.  (Its still blocking, so the function will only return when it is finished)

Beware, it is possible to get a "security" error when downloading from a secure https website.  The only workaround I am aware of is to remove the "s" and just use http.

In adition to the unit containing the 2 procedures, I have also included the import type libraries required (click the component link above).  This should save you about 30 minutes of hunting the internet trying to find which dll you have to import.

In the event you have to re-import it, the dll is cdosys.dll in the system32 directory.

unit SaveMHT;

interface
uses
CDO_TLB, ADODB_TLB, Classes, SysUtils, ActiveX;

procedure SaveToMHT(const URL, DestFileName: string);

// This should be used when you have already set the threading model to multithreaded
procedure SaveToMHT_InCOThread(const URL, DestFileName: string);

implementation

procedure SaveToMHT(const URL, DestFileName: string);
var
Msg: IMessage;
Conf: IConfiguration;
Stream: _Stream;
begin
Msg := CoMessage.Create;
Conf := CoConfiguration.Create;
Msg.Configuration := Conf;
Msg.CreateMHTMLBody(URL, cdoSuppressNone, '', '');
Stream := Msg.GetStream;
Stream.SaveToFile(DestFileName, adSaveCreateOverWrite);
end;

type
TCOMInitNullThread = class(TThread)
protected
FPage, FFile: string;
Ex: Exception;
procedure Execute; override;
end;

procedure SaveToMHT_InCOThread(const URL, DestFileName: string);
begin
with TCOMInitNullThread.Create(True) do
try
FPage := URL;
FFile := DestFileName;
Resume;
WaitFor;
if Ex <> nil then
raise Ex;
finally
Free;
end;
end;

{ TCOMInitNullThread }

procedure TCOMInitNullThread.Execute;
begin
CoInitialize(nil);
try
SaveToMHT(FPage, FFile);
except
on E: Exception do
begin
Ex := E.ClassType.Create as Exception;
Ex.Message := E.Message;
end;
end;
CoUninitialize;
end;

end.

Component Download: http://www.baltsoft.com/files/dkb/attachment/mht.ziphttp://www.baltsoft.com/files/dkb/attachment/mht.zip


Solve 2:

function SaveToMHT(const AUrl, AFileName: string;
AShowErrorMessage: boolean = false): boolean;
var
oMSG, oConfig: OleVariant;
sFileName: string;
Retvar: boolean;
begin
sFileName := ChangeFileExt(AFileName, '.mht');
DeleteFile(sFileName);

try
oConfig := CreateOleObject('CDO.Configuration');
oMSG := CreateOleObject('CDO.Message');
oMSG.Configuration := oConfig;
oMSG.CreateMHTMLBody(AUrl);
oMSG.GetStream.SaveToFile(sFileName);
Retvar := true;
except
on E: Exception do
begin
if AShowErrorMessage then
MessageDlg(E.Message, mtError, [mbOk], 0);
Retvar := false;
end;
end;

oMSG := VarNull;
oConfig := VarNull;

Result := Retvar;
end;

Resize a TPanel at runtime

Problem/Question/Abstract:

How to resize a TPanel at runtime

Answer:

Solve 1:

You should add a SIZEBOX constant to the your panel window style:

TMyNewPanel = class(TPanel)
{ ... }
procedure CreateParams(var Params: TCreateParams); override;
{ ... }

procedure TMyNewPanel.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or WS_SIZEBOX;
end;


Solve 2:

The best way to deal with this is to make a descendent of TPanel that incorporates the required behaviour. Copy the following to a file SizeablePanel.pas, and install that via Component -> Install component.

unit SizeablePanel;

interface

uses
Messages, Windows, SysUtils, Classes, Controls, ExtCtrls;

type
TSizeablePanel = class(TPanel)
private
FMoveable: Boolean;
procedure wmNCHittest(var msg: TWMNCHittest); message WM_NCHITTEST;
published
property Moveable: Boolean read FMoveable write FMoveable default false;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('PBGoodies', [TSizeablePanel]);
end;

procedure TSizeablePanel.wmNCHittest(var msg: TWMNCHittest);
var
bottom, right: Integer;
pt: TPoint;
begin
if moveable then
msg.result := HTCAPTION
else
inherited;
pt := parent.ScreenToClient(SmallpointToPoint(msg.Pos));
bottom := Top + Height;
right := Left + Width;
if (pt.x - Left) < 10 then
if (pt.y - Top) < 10 then
msg.Result := HTTOPLEFT
else if (Bottom - pt.y) < 10 then
msg.result := HTBOTTOMLEFT
else
msg.result := HTLEFT
else if (right - pt.x) < 10 then
if (pt.y - Top) < 10 then
msg.Result := HTTOPRIGHT
else if (Bottom - pt.y) < 10 then
msg.result := HTBOTTOMRIGHT
else
msg.result := HTRIGHT
else if (pt.y - Top) < 10 then
msg.Result := HTTOP
else if (Bottom - pt.y) < 10 then
msg.result := HTBOTTOM;
end;

end.

Write a correct date in SQL

Problem/Question/Abstract:

How to write a correct date in SQL

Answer:

The SQL date format does not change with the system settings. The date is saved in "MM/DD/YY(YY)" format. You can use this code to save the current date in SQL:

var
  sSQLDate: string;
{..}
sSQLDate := '''' + FormatDateTime('mm"/"dd"/"yyyy', Now) + '''';

Load and read a shortcut to see where it points to

Problem/Question/Abstract:

How to load and read a shortcut to see where it points to

Answer:

procedure GetShellLinkInfo(const LinkFile: WideString; var SLI: TShellLinkInfo);
{Retrieves information on an existing shell link}
var
  SL: IShellLink;
  PF: IPersistFile;
  FindData: TWin32FindData;
  AStr: array[0..MAX_PATH] of char;
begin
  OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IShellLink,
    SL));
  {The IShellLink implementer must also support the IPersistFile interface. Get an interface pointer to it}
  PF := SL as IPersistFile;
  { Load file into IPersistFile object }
  OleCheck(PF.Load(PWideChar(LinkFile), STGM_READ));
  {Resolve the link by calling the Resolve interface function}
  OleCheck(SL.Resolve(0, SLR_ANY_MATCH or SLR_NO_UI));
  {Get all the info}
  with SLI do
  begin
    OleCheck(SL.GetPath(AStr, MAX_PATH, FindData, SLGP_SHORTPATH));
    PathName := AStr;
    OleCheck(SL.GetArguments(AStr, MAX_PATH));
    Arguments := AStr;
    OleCheck(SL.GetDescription(AStr, MAX_PATH));
    Description := AStr;
    OleCheck(SL.GetWorkingDirectory(AStr, MAX_PATH));
    WorkingDirectory := AStr;
    OleCheck(SL.GetIconLocation(AStr, MAX_PATH, IconIndex));
    IconLocation := AStr;
    OleCheck(SL.GetShowCmd(ShowCmd));
    OleCheck(SL.GetHotKey(HotKey));
  end;
end;

Converting roman notation to a numeric value

Problem/Question/Abstract:

How to convert roman notation to a numeric value

Answer:

function RomanToDec(const Value: string): integer;
var
  i, lastValue, curValue: integer;
begin
  Result := 0;
  lastValue := 0;
  for i := Length(Value) downto 1 do
  begin
    case UpCase(Value[i]) of
      'C':
        curValue := 100;
      'D':
        curValue := 500;
      'I':
        curValue := 1;
      'L':
        curValue := 50;
      'M':
        curValue := 1000;
      'V':
        curValue := 5;
      'X':
        curValue := 10;
    else
      raise Exception.CreateFmt('Invalid character: %s', [Value[i]]);
    end;
    if curValue < lastValue then
      Dec(Result, curValue)
    else
      Inc(Result, curValue);
    lastValue := curValue;
  end;
end;

Download Url

Problem/Question/Abstract:

Download Url

Answer:

uses WinInet;

function DownloadFile(const Url: string): string;
var
  NetHandle: HINTERNET;
  UrlHandle: HINTERNET;
  Buffer: array[0..1024] of Char;
  BytesRead: dWord;
begin
  Result := '';
  NetHandle := InternetOpen('Delphi 5.x', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if Assigned(NetHandle) then
  begin
    UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);

    if Assigned(UrlHandle) then
      { UrlHandle valid? Proceed with download }
    begin
      FillChar(Buffer, SizeOf(Buffer), 0);
      repeat
        Result := Result + Buffer;
        FillChar(Buffer, SizeOf(Buffer), 0);
        InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead);
      until BytesRead = 0;
      InternetCloseHandle(UrlHandle);
    end
    else
      { UrlHandle is not valid. Raise an exception. }
      raise Exception.CreateFmt('Cannot open URL %s', [Url]);

    InternetCloseHandle(NetHandle);
  end
  else
    { NetHandle is not valid. Raise an exception }
    raise Exception.Create('Unable to initialize Wininet');
end;

//example

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(DownloadFile('http://www.yahoo.com/index.html'));
end;

Count words in a memo

Problem/Question/Abstract:

Count words in a memo

Answer:

Insert 1 label, 1 button and 1 memo.

procedure TForm1.Button1Click(Sender: TObject);

  function Palabras(Link: string): integer;
  var
    n: integer;
    befspace: boolean;
  begin
    befspace := FALSE;
    if Link = '' then
      Result := 0
    else
      Result := 1;
    for n := 1 to Length(Link) do
    begin
      if befspace and
        (Link[n] <> ' ') and
        (Link[n] <> #13) and
        (Link[n] <> #10) then
        Inc(Result);

      befspace := (Link[n] = ' ') or
        (Link[n] = #13) or
        (Link[n] = #10);
    end;
  end;

begin
  Label1.caption := IntToStr(Palabras(Memo1.Text));
end;
end;

Create your first console application to interact with forms

Problem/Question/Abstract:

Interaction between your Console applications and your forms

Answer:

This code demonstrates how to combine console API with usual forms

Create a new -> console application and save it as listing2
Copy the given code in to the console application
Create a form in the same project with name frmDialog1.dfm and dialog1.pas
In the form put three RadioButtons
Now build and run the application
Shift the focus to the console application and type 1 or 2 or 3

Based on the number typed the Radiobutton in the form will be clicked automatically When u press ctrl + c the application exits

program listing2;
{$APPTYPE CONSOLE}
uses
  SysUtils, Windows, Messages, Forms,
  Dialog1 in 'Dialog1.pas' {frmDialog1};

var
  hInput: THandle;
  inRec: TInputRecord;
  dwCount: DWORD;

begin
  {Create a Form in the usual way. The Forms unit ensures that
  the Application object is around to "own" the form.}

  Write('Creating the first Dialog Box...');
  frmDialog1 := TfrmDialog1.Create(Application);
  frmDialog1.Show;
  Writeln('done.');

  Writeln('Press 1, 2 or 3 to change the dialog box. Press Ctrl+ C to exit');

  {Handle the Console input till the user cancels}
  hInput := GetStdHandle(STD_INPUT_HANDLE);
  {GetStdHandle - Returns handle for Standard input/output device}

  while True do
  begin
    {Avoid blocking on user input, so the forms have a chance
    to operate as normal. If we had a message queue present, this
    would be a normal message dispatch loop.}
    Application.ProcessMessages;
    if WaitForSingleObject(hInput, 0) = WAIT_OBJECT_0 then
    begin
      ReadConsoleInput(hInput, inRec, 1, dwCount);
      if (inRec.EventType = KEY_EVENT) and inRec.Event.KeyEvent.bKeyDown then
      begin
        case inRec.Event.KeyEvent.AsciiChar of
          '1':
            begin
              Writeln('->1');
              frmDialog1.RadioButton1.Checked := True;
            end;

          '2':
            begin
              Writeln('->2');
              frmDialog1.RadioButton2.Checked := True;
            end;
          '3':
            begin
              Writeln('->3');
              frmDialog1.RadioButton3.Checked := True;
            end;
        end;
      end;
    end;
  end;
end.