How to copy records to the same table

Problem/Question/Abstract:

I need to copy a record in a dBase table to the same table and just change a value or two. I know that I can copy the hard way read all the fields into a record then write it back out.

Answer:

Solve 1:

var
  SourceQueryFieldName: string;
begin
  QueryDestination.Open;
  QuerySource.Open;
  QueryDestination.Insert;
  for FieldLoop := 0 to QuerySource.FieldCount - 1 do
  begin
    SourceQueryFieldName := DataBaseQuerySource.Fields[FieldLoop].FieldName;
    try
      QueryDestination[SourceQueryFieldName] := QuerySource[SourceQueryFieldName];
    except
      {Field not Found}
    end;
  end;
  QueryDestination.Post;
  QueryDestination.Close;
  QuerySource.Close;
end;

Solve 2:

I actually prefer code that reads each field and writes it to the new record like this:

procedure CopyRecord(tbl: TTable);
var
  I: Integer;
  tblTmp: TTable;
begin
  blTmp := TTable.Create(nil);
  try
    tblTmp.DatabaseName := tbl.DatabaseName;
    tblTmp.TableName := tbl.TableName;
    tblTmp.Open;
    ttblTmp.GotoCursor(Src);
    tbl.Insert;
    try
      for I := 0 to T.FieldCount - 1 do
        tbl.Fields[I].Assign(tblTmp.Fields[I]);
    except
      tbl.Cancel;
      raise;
    end;
  finally
    tblTmp.Free;
  end;
end;

But you can also do it like this:

procedure CopyRecord(const FromTable: TTable);
begin
  dbiInsertRecord(FromTable.Handle, dbiNoLock, FromTable.ActiveBuffer);
end;

Kill a task

Problem/Question/Abstract:

Kill a task using only the .exe name

Answer:

This little function closes all applications with the same  .exe-name.

  Example:

                        KillTask('notepad.exe');
                        KillTask('iexplore.exe');

Working on Win9x/2k, but apparently not on WinNT systems (never tried on my own)

uses
  Tlhelp32, Windows, SysUtils;

function KillTask(ExeFileName: string): integer;
const
  PROCESS_TERMINATE = $0001;
var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  result := 0;

  FSnapshotHandle := CreateToolhelp32Snapshot
    (TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle,
    FProcessEntry32);

  while integer(ContinueLoop) <> 0 do
  begin
    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
      UpperCase(ExeFileName))
      or (UpperCase(FProcessEntry32.szExeFile) =
      UpperCase(ExeFileName))) then
      Result := Integer(TerminateProcess(OpenProcess(
        PROCESS_TERMINATE, BOOL(0),
        FProcessEntry32.th32ProcessID), 0));
    ContinueLoop := Process32Next(FSnapshotHandle,
      FProcessEntry32);
  end;

  CloseHandle(FSnapshotHandle);
end;

Application.Terminate or Halt() ?

Problem/Question/Abstract:

Should I use Application.Terminate or Halt() ? And what are the differences?

Answer:

Application.Terminate closes the main window and that way the application in a clean fashion. Halt() shuts down right away, e.g. memory may not be freed, tables are not closed and so on.

For D4: Halt can cause AV's on an NT system, usually with Runtime error 216, if DLL's are involved also 217 - Application.Terminate on the other hand cleans without AV.

But: Halt worked with D2, even the cleaning of the memory did work....

Then again, if you write a console application, you have to use halt(), since there probably is no Application object.

Preventing the Debugger from stepping into VCL source

Problem/Question/Abstract:

Preventing the Debugger from stepping into VCL source

Answer:

Does your debugger step into the VCL source code and you want to disable this?
Or are you in the opposite situation, you need to step into through the VCL source code?
Here are some pointers (for Delphi 5) what you should look at.

The following steps will stop the debugger from stepping into the VCL:

Go to menu 'Project | Options' and there click on tab 'Compiler'. Then uncheck the 'Use Debug DCUs' option under 'Debugging'. This is a project-specific setting.

Also check to be sure your Library path just points to LIB, not LIB\DEBUG. This is an environment option and will affect all projects.

Remove the VCL source directories from the Search Path. This is also a project specific setting. Choose under 'Project | Options' the tab 'Directories/Conditionals'. Delphi 5 allows to remove directories comfortably from the search path. The VCL source directories will look like

$(DELPHI)\Source\Vcl

There are probably be other directories below $(DELPHI)\Source, which you may want to remove as well. E.g. \RTL\

Happy Debugging!

Disable the main form while a dialog box is shown

Problem/Question/Abstract:

I'm trying to set up a "Please Wait" box. I want it to be modal in the sense that my main form is deactivated while I have this box showing. But, in the function that displays the "Please Wait" box, I want the code to continue rather than stall, waiting for the box to close.

Answer:

{ ... }
WaitBox.Show; {shows your WaitBox}
Enabled := false; {disables the whole main form (Self.Enabled)}
Application.ProcessMessages; {let the two forms update themselves}
try
  { ... Do next steps }
finally
  Enabled := true;
  WaitBox.Hide;
end;

Note that the WaitBox must be visible before you can disable the main form. You needn't disable each single component. With this construction you can easily add a Cancel-Button to your WaitBox. Set a public property (CancelPressed) to TRUE if the Cancel Button is pressed and you can do something like this:

{ ... }
repeat
  { next steps }
  Application.ProcessMessages;
until
WaitBox.CancelPressed
{ ... }

Close all the open IE windows

Problem/Question/Abstract:

How can I close all the open internet explorer windows currently open?

Answer:

Use this to close all open IE windows.

var
  IExplorer: Thandle;
begin
  IExplorer := FindWindow('' IEFrame '', nil);
  if IExplorer <> 0 then
    SendMessage(IExplorer, WM_SYSCOMMAND, SC_CLOSE, 0);

note instead of SC_CLOSE

SC_MINIMIZE can be used to minimize all ie windows
SC_MAXIMIZE can be used to maximize all ie windows

This could be used on a button click or in a timer for example.

How to tab between fields displayed in a TDBGrid

Problem/Question/Abstract:

Inside a DBGrid I would like to tab to the next field on each line (record) in the DBGrid, but when I tab the focus jumps to the last record. How do I get this to work right? Visible fields: LineNo, Code, Qty, Description, Price, Taxable, Extended (price). I want to tab to each or at least from Code to Qty to Price.

Answer:

procedure TYourForm.FormKeyPress(Sender: TObject; var Key: Char);
begin
  if Key = #13 then { if it's an enter key }
    if not (ActiveControl is TDBGrid) then { if not on a TDBGrid }
    begin
      Key := #0; { eat enter key }
      Perform(WM_NEXTDLGCTL, 0, 0); { move to next control }
    end
    else if (ActiveControl is TDBGrid) then { if it is a TDBGrid }
      with TDBGrid(ActiveControl) do
        if selectedindex < (fieldcount - 1) then { increment the field }
          selectedindex := selectedindex + 1
        else
          selectedindex := 0;
end;

Using custom cursors

Problem/Question/Abstract:

How can I use custom cursors in my application?

Answer:

To use custom cursors in your application you have to follow these steps:

1. Create the cursors and save them in a resource file. You can use the Image Editor that comes with Delphi for this purpose.

2. In the interface section of any unit of your project declare the constants to refer to your cursors in code. This is not required,    but it will improve the readability of your code, so it is higly recommended.

These constans must be possitive integers (0 and negative values are reserved for the standard cursors). For example:

const
  crFinger = 1;
  crPower = 2;

3. In the initialization section of this unit, or anywhere in your    project before you attempt to use your cursors, you have to load    the cursors from the resource file. For example:

{$R Cursors.res}
Screen.Cursors[crFinger] := LoadCursor(hInstance, 'FINGER');
Screen.Cursors[crPower] := LoadCursor(hInstance, 'POWER');

Here we assumed "Cursors.res" is the resource file where you saved    your cursors, and that FINGER and POWER are the names you saved    them under.

This is it. You can use these cursors in the same you would use the predefined cursors. For example:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Self.Cursor := crPower;
  Label1.Cursor := crFinger;
end;

You can also set the Cursor and DragCursor properties of a component at design-time using the Object Inspector. The only drawback is that you can't use the constants names (for example crFinger and crPower) but their values (for example 1 and 2).


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

Compare two records in the same table

Problem/Question/Abstract:

Is there any way to compare two records from the same table to know which fields are different on each record? Both my field are the same except that some field may differ, and I want to know which one is different.

Answer:

I would create a second TTable and then compare using the Fields array. Give the following function a TTable and a field position to start the compare. If it returns false bgnFld will reflect the first field where values are not the same. (This code has not been tested):

function compairFields( t: TTable; var bgnFld: Integer ): Boolean;
var
  t2: TTable;
  cntr: Integer;
begin
  try
    t2 := ttable.create(nil)
    with T do
    begin
      t2.gotoCurrent(t);  {synchronize tables}
      for cntr := bgnfld to FieldCount - 1 do
      begin
        result := (fieldscntr] = T2.fields[cntr]);
        if not result then
          Break;
      end;
    end;
  finally
    t2.free;
  end;
end;

or use two TTables one pointing to each of the two records. Then:

for I := 0 to Table1.FieldCount - 1 do
  if Table1.Fields[I].Value <> Table2.Fields[I].Value then
    ...

How to assign a new path to a TTable at runtime

Problem/Question/Abstract:

How to assign a new path to a TTable at runtime

Answer:

Use a TDataBase with a custom, application-specific alias. Set the Alias property to an empty string, select a DriverName, and insert the string 'PATH=C:\MYPATH' into the Params property.

Now any TTable etc. of your project can see an alias of the name you choose for the DataBaseName property of TDataBase. At runtime you can assign a new path at a single place. You have to re-open the tables, however. Like this:

procedure AssignDBDir(ADataBase: TDataBase; const ADir: string);
begin
  with ADataBase do
    if (Params.Count = 0) or (Params[0] <> 'PATH=' + ExtractFilePath(AFileName)) then
    begin
      if Connected then
        Close; {closes all tables as well}
      DriverName := 'STANDARD'; {clears any alias as well}
      Params.Clear;
      Params.Add('PATH=' + ADir);
      Open; {reopen tables here}
    end;
end;

Differentiate between a Windows shutdown and a user's close request

Problem/Question/Abstract:

How can I differentiate between a Windows shutdown and a user's close request (Alt + F4 / titlebar close icon / file menu + close item / etc.) so that I can bypass the OnCloseQuery logic during a shutdown?

Answer:

Windows sends a WM_QUERYENDSESSION message to the main window of your application. The default processing for that invokes your CloseQuery method, which (in your logged out case) replies "No". So you need to watch for the WM_QUERYENDSESSION message and set a flag for your CloseQuery method. Give the form a flag and method like so:

FShuttingDown: Boolean;

procedure WMQueryEndSession(var Msg: TMessage); message WM_QUERYENDSESSION;

procedure TForm1.WMQueryEndSession(var Msg: TMessage);
begin
  {Tell CloseQuery it's a shutdown operation}
  FShuttingDown := True;
  {Let the default stuff happen to see if we can otherwise close}
  inherited;
end;

Then in your CloseQuery event handler do:

if FShuttingDown then
  CanClose := True
else
  CanCLose := {User if "logged in"};

It is possible for the shutdown to be aborted by another application, however. So you need to watch for the WM_ENDSESSION message that gets sent telling you if you really are going to shut down:

procedure WMEndSession(var Msg: TMessage); message WM_ENDSESSION;

procedure TForm1.WMEndSession(var Msg: TMessage);
begin
  {Clear the flag if the shutdown was aborted}
  FShuttingDown := Msg.WParam <> 0;
end;

Parsing the Words in a Sentencee

Problem/Question/Abstract:

How can I parse the words in a sentence?

Answer:

This week's tip is some code that actually accomplishes something very simple: parsing the words of a sentence. I've been hanging out in the newsgroups and in CompuServe forum and ran across several question regarding what's the best way to do this, so I came up with a simple procedure to do it. I've seen a lot of people use arrays and such, but the problem with using arrays is that they're of fixed size (though in a previous tip, I showed how to make runtime resizeable arrays). A better way to store the words of a string is to use a TStringList object.

A TStringList is essentially an array of strings (or objects) that can be resized dynamically at runtime. Since memory is allocated and deallocated in the background, you don't have to worry about those operations when using one. All you have to worry about is adding or deleting elements. Each item in a TStringList is referenced by its Strings property, much in the way you reference an array element. Let's say you want to know what the value of the fifth element in a string list. You'd write something like the following:

x := MyStringList.Strings[4];

I forgot to mention that TStringLists are zero-based, so the first element in the TStringList is always numbered '0.' So how can you use it to parse a sentence? Well, let's look at the code below:

function FillList(sentnc: string; {Input string}
                                                                  var sList: TStringList; {String List to add values to}
                                                                   clearList: Boolean) {Clear list before adding?}
                                                                 : Boolean; {Return value}
var
  str, wrd: string;
  I: Word;
begin

  {Initialize vars}
  Result := True;
  str := sentnc;
  wrd := '';

  {Check to see if the string passed is blank}
  if (Length(sentnc) = 0) then
  begin
    MessageDlg('Passed an empty string', mtError, [mbOk], 0);
    Result := False;
    Exit;
  end;

  {Clear the list if wanted and the count of values is > 0}
  if clearList and (sList.Count > 0) then
    repeat
      sList.Delete(0);
    until
      sList.Count = 0;

  while (Pos(' ', str) > 0) do {Do this while you find}
  begin {spaces in the sentence}
    wrd := Copy(str, 1, Pos(' ', str) - 1); {Get the word from the string}
    sList.Add(wrd); {Add the word to the TStringList}
    str := Copy(str, Pos(' ', str) + 1, {Redefine the sentence by cutting}
      Length(str) - Length(wrd) + 1); {off the first word}
  end;

  if (Length(str) > 0) then {This is important, because you never}
    sList.Add(str); {know if there's anything left in the sentence.}
end;

The function above takes a string input called sentnc and uses the Pos and Copy functions to successively cut off the first word of the phrase and load it into a string list. You'll notice that I've added a couple of tests: 1) to test whether the input is blank; 2) to see if the program should empty the list before adding items to the list. You'll also notice that I have the TStringList object passed by reference as a formal parameter of the function. This is so that any string list can be passed into the function to accept a phrase. However, besides the extra checking stuff, the real workhorse of the function is the while loop. Follow the commenting to the right of the code to see what's going on.

To employ this function, you'd have to create a TStringList object then call the function. Look at the code below:

procedure TForm1.FormCreate(Sender: TObject);
begin
  strList := TStringList.Create;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  I: Integer;
begin
  {Fill the list}
  if FillList(Edit1.Text, strList, True) then
  begin
    repeat
      ListBox1.Items.Delete(0);
    until
      ListBox1.Items.Count = 0;

    for I := 0 to strList.Count - 1 do
      ListBox1.Items.Add(strList.Strings[I]);
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  strList.Free;
end;

The code above was taken from a form I built to test the FillList function. In the FormCreate, I create and initialize the TStringList object. In a pushbutton click event, I read the contents of a TEdit then call the function. The resultant load is then read into a list box that I dropped on the form. FormClose destroys the TStringList. Granted, this is a rather simple way of employing the string list, but there are numerous ways in which to use this neat little object.

Find whole words within a string

Problem/Question/Abstract:

Does anyone know of a function that finds a whole word within a string as in the search and replace options?

Answer:

{Function FindWord

Parameters:
pattern: word to search for
text: text to search
caseSensitive: determines whether search is case sensitive or not. Default is not case-sensitive.
startAt: first character to search, default is 1.

Returns:
The start of the first instance of the word, or 0, if the word was not found or only as part of larger words. A word in this context is any sequence of alphanumeric characters delimited by non-alphanumeric characters.

Error Conditions: none

Created: 18.05.99 by P. Below}

function FindWord(pattern, text: string; caseSensitive: Boolean = false; startAt:
  Integer = 1): Integer;
var
  offset, endOfPattern: Integer;
begin
  Result := 0;
  if Length(text) = 0 then
    exit;
  if Length(pattern) = 0 then
  begin
    {By definition a pattern of length 0 is always found}
    result := 1;
    Exit;
  end;
  if not caseSensitive then
  begin
    pattern := AnsiLowerCase(pattern);
    text := AnsiLowerCase(text);
  end;
  endOfPattern := startAt + Length(pattern);
  for offset := startAt to Length(text) - Length(pattern) + 1 do
  begin
    if pattern[1] = text[offset] then
    begin
      if ((offset = 1) or not IsCharAlphaNumeric(text[offset - 1])) and ((endOfPattern
        > Length(text)) or  not IsCharAlphaNumeric(text[endOfPattern]))
                                and (StrLComp(@text[offset], @pattern[1], Length(pattern)) = 0) then
      begin
        Result := offset;
        exit;
      end;
    end;
    Inc(endOfPattern);
  end;
end;

How to get the scan code of keyboards

Problem/Question/Abstract:

How to get the scan code of keyboards

Answer:

unit Unit1;

interface

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

type
  TKeyInfo = packed record
    KeyDown: Boolean;
    VirtualKeyCode: WORD;
    RepeatCount: Word;
    VirtualScanCode: Byte;
    ExtendedKey: Boolean;
    ContextCode: Boolean;
    PreviousState: Boolean;
    AsciiChar: Char;
    ControlKeyState: DWORD;
  end;

  TForm1 = class(TForm)
  private
    procedure WMKeyDown(var Message: TMessage); message WM_KEYDOWN;
    function GetKeyInfo(var Message: TMessage): TKeyInfo;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.WMKeyDown(var Message: TMessage);
var
  KeyInfo: TKeyInfo;
begin
  KeyInfo := GetKeyInfo(Message);
  KeyInfo.KeyDown := True;
  ShowMessage('ScanCode: ' + IntToStr(KeyInfo.VirtualScanCode));
end;

function TForm1.GetKeyInfo(var Message: TMessage): TKeyInfo;

  function IsWinNT: Boolean;
  begin
    Result := (GetVersion < $80000000);
  end;

const
  AltMask = $20000000;
var
  KeyBoardState: TKeyBoardState;
  LowerKeyData: WORD;
  UpperKeyData: WORD;
begin
  ZeroMemory(@Result, SizeOf(TKeyInfo));
  GetKeyBoardState(KeyBoardState);
  LowerKeyData := LOWORD(Message.LParam);
  UpperKeyData := HIWORD(Message.LParam);
  Result.VirtualKeyCode := WORD(Message.WParam);
  Result.RepeatCount := LowerKeyData;
  Result.VirtualScanCode := UpperKeyData and $FF;
  Result.ExtendedKey := Boolean((UpperKeyData and KF_EXTENDED) shr 8);
  Result.ContextCode := Boolean((UpperKeyData and KF_ALTDOWN) shr 13);
  Result.PreviousState := Boolean((UpperKeyData and KF_REPEAT) shr 14);
  Result.KeyDown := not Boolean((UpperKeyData and KF_UP) shr 15);
  ToAscii(Result.VirtualKeyCode, Result.VirtualScanCode, KeyBoardState,
    @Result.AsciiChar, 0);
  Result.ControlKeyState := (((KeyBoardState[VK_LCONTROL] and 128) shr 7) *
    LEFT_CTRL_PRESSED) or (((KeyBoardState[VK_RCONTROL] and 128)
    shr 7) * RIGHT_CTRL_PRESSED) or (((KeyBoardState[VK_LMENU] and
    128) shr 7) * LEFT_ALT_PRESSED) or (((KeyBoardState[VK_RMENU]
    and 128) shr 7) * RIGHT_ALT_PRESSED) or ((KeyBoardState
    [VK_CAPITAL] and 1) * CAPSLOCK_ON) or ((KeyBoardState
    [VK_NUMLOCK] and 1) * NUMLOCK_ON) or ((KeyBoardState
    [VK_SCROLL] and 1) * SCROLLLOCK_ON) or ((((KeyBoardState
    [VK_LSHIFT] or KeyBoardState[VK_RSHIFT]) and 128) shr 7) *
    SHIFT_PRESSED) or (Integer(Result.ExtendedKey) * ENHANCED_KEY);

  if (not IsWinNT) then
  begin
    if (((Result.ControlKeyState and LEFT_CTRL_PRESSED) or (Result.ControlKeyState and
      RIGHT_CTRL_PRESSED)) = 0) and ((KeyBoardState[VK_CONTROL] and 128) <> 0) then
      Result.ControlKeyState := Result.ControlKeyState or RIGHT_CTRL_PRESSED;
    if (((Result.ControlKeyState and LEFT_ALT_PRESSED) or (Result.ControlKeyState and
      RIGHT_ALT_PRESSED)) = 0) and ((KeyBoardState[VK_MENU] and 128) <> 0) then
      Result.ControlKeyState := Result.ControlKeyState or RIGHT_ALT_PRESSED;
  end;
end;

end.

Interesting API calls part I : detecting simultaneous keystrokes

Problem/Question/Abstract:

How can I detect if more than one key is pressed at the same time?

Answer:

You can use Windows API to detect multiple keystrokes. The name of the function that give us this facility is GetKeyState. The higher order bit show us the state of the key we pass as parameter to the function. On this sample I detect the states of the arrow keys, spacebar, shift keys and ESC. This sample can detect up to four keystrokes at the same time, but have some limitations, due to hardware limitations (i think). This will detect UP + RIGHT + SPACE but won�t detect UP + LEFT + SPACE. I may be wrong, but this happens because of keyboards pins design. That�s why I included the SHIFT state, because SHIFT keys will be detected with any combination of arrow keys. To run this sample place on a blank form a Label and a Button. Click the button to start, press ESC to stop.

{****************************************************************
*     Multiple keystrokes detection using Windows API          *
*     Source written by Rafael Cotta (rcotta.geo@yahoo.com)    *
*     July 26th, 2001                                          *
****************************************************************}

// To run this sample, create a blank form, and place a label
// and a timer on it.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

function GetKeysPressed(): Cardinal;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{
   Each bit on the function result represents
   the state of a key, so

      0000 0001 = UP
      0000 0010 = DOWN
      0000 0100 = LEFT
      0000 1000 = RIGHT
      0001 0000 = SPACE BAR
      0010 0000 = ESC
      0100 0000 = SHIFT
}

function GetKeysPressed(): Cardinal;
var
  dwRet: Cardinal;
begin

  dwRet := 0;

  if ((GetKeyState(VK_UP) and $10000000) > 0) then
    dwRet := dwRet + 1;
  if ((GetKeyState(VK_DOWN) and $10000000) > 0) then
    dwRet := dwRet + 2;
  if ((GetKeyState(VK_LEFT) and $10000000) > 0) then
    dwRet := dwRet + 4;
  if ((GetKeyState(VK_RIGHT) and $10000000) > 0) then
    dwRet := dwRet + 8;
  if ((GetKeyState(32) and $10000000) > 0) then
    dwRet := dwRet + 16; // SpaceBar
  if ((GetKeyState(27) and $10000000) > 0) then
    dwRet := dwRet + 32; // ESC
  if ((GetKeyState(VK_SHIFT) and $10000000) > 0) then
    dwRet := dwRet + 64; // ESC

  GetKeysPressed := dwRet;

end;

procedure TForm1.Button1Click(Sender: TObject);
var
  dwKeys: Cardinal;
begin
  dwKeys := 0;

  // While ESC is not pressed

  while ((dwKeys and 32) = 0) do
  begin
    Application.ProcessMessages;
    dwKeys := GetKeysPressed;

    Label1.Caption := 'Keys pressed : ';

    if ((dwKeys and 1) > 0) then
      Label1.Caption := Label1.Caption + ' UP';

    if ((dwKeys and 2) > 0) then
      Label1.Caption := Label1.Caption + ' DOWN';

    if ((dwKeys and 4) > 0) then
      Label1.Caption := Label1.Caption + ' LEFT';

    if ((dwKeys and 8) > 0) then
      Label1.Caption := Label1.Caption + ' RIGHT';

    if ((dwKeys and 16) > 0) then
      Label1.Caption := Label1.Caption + ' SPACE';

    if ((dwKeys and 32) > 0) then
      Label1.Caption := Label1.Caption + ' ESC';

    if ((dwKeys and 64) > 0) then
      Label1.Caption := Label1.Caption + ' SHIFT';

  end;

end;

end.

How to change the ReadyMessage of HP-LaserJet printers

Problem/Question/Abstract:

How to change the ReadyMessage of HP-LaserJet printers with a LCD display?

Answer:

This works only on HP-LaserJet printers, which have a two line 16 character LCD display. F.i. on a HP LaserJet 4000, HP LaserJet 5000 (N). In this LCD-display you normally find messages like: READY, or PAPER OUT IN BIN 3 or something like that. With this small routine you can alter the ready message into your own. It will stay there until you switch the printer off (or change the ready message with this program). The message should be no longer than two lines of 16 characters each. Remember that it will be truncated after 16 characters, the rest of the line will be on the next line of 16 characters on the LCD display.

//----------------------------------------------------------------------
// This routine is published by me before...

procedure PrintRawStr(const S: ANSIString);

Uses
  Printers, WinSpool, Dialogs;

var
  Handle: THandle;
  dwN: DWORD;
  diDocInfo1: TDocInfo1;
  bP: BYTE;
  sDefaultPrinter: string;

begin
  sDefaultPrinter := '';
  if Printer.Printers.Count > 0 then
  begin
    sDefaultPrinter := Printer.Printers[Printer.PrinterIndex];
    //uses Printers, get default printer
    bP := Pos(' on ', sDefaultPrinter);
    if bP > 0 then
      sDefaultPrinter := Copy(sDefaultPrinter, 1, bP - 1);
  end;

  if Length(S) = 0 then
    Exit;

  if not OpenPrinter(PChar(sDefaultPrinter), Handle, nil) then
  begin
    case GetLastError of
      87: ShowMessage('Printer name does not exists.');
    else
      ShowMessage('Error ' + IntToStr(GetLastError)); // Uses Dialogs
    end;
    Exit;
  end;

  with diDocInfo1 do
  begin
    pDocName := PChar('My Print Job'); // Visible in the spooler window
    pOutputFile := nil;
    pDataType := 'RAW';
  end;

  StartDocPrinter(Handle, 1, @diDocInfo1);
  StartPagePrinter(Handle);
  WritePrinter(Handle, PChar(S), Length(S), dwN);
  EndPagePrinter(Handle);
  EndDocPrinter(Handle);
  ClosePrinter(Handle);
end;
//----------------------------------------------------------------------

procedure ChangeLaserReadyMessage(S: string);

const
  InitStr: string = #27 + '%-12345X@PJL RDYMSG DISPLAY="';
  ExitStr: string = '"' + #13 + #10 + #27 + '%-12345X' + #13 + #10;

begin
  PrintRawStr(InitStr + S + ExitStr);
end;
//----------------------------------------------------------------------

How to call the help file for the application's help file

Problem/Question/Abstract:

How to call the help file for the application's help file

Answer:

Application.HelpCommand(HELP_HELPONHELP, 0);

How to change the default highlight color of a TListBox

Problem/Question/Abstract:

Can anyone tell me how to change the default highlight color used in a TListBox? I need it to be clAqua instead of the standard Navy as the text in the listbox is made other colors in the OwnerDraw and you can't read some of them with the Navy selection color.

Answer:

Solve 1:

Check the 'State' parameter in the DrawItem event. It lets you know if the item is selected. If it is then use a different brush color.

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
begin
  if odSelected in State then
    ListBox1.Canvas.Brush.Color := clAqua;
  ListBox1.Canvas.FillRect(Rect);
  ListBox1.Canvas.TextOut(Rect.Left, Rect.Top, ListBox1.Items[Index]);
end;

Solve 2:

Set Style := lbOwnerDrawFixed and OnDrawItem := ListBoxDrawItem; . Remove the last line from the example if you want to have the focus rectangle.

procedure TListBox.ListBoxDrawItem(Control: TWinControl; Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
begin
  if (odSelected in State) then
    Canvas.Brush.Color := clBlue
  else
    Canvas.Brush.Color := Color;
  Canvas.FillRect(Rect);
  Canvas.Font := Font;
  SetTextAlign(Canvas.Handle, TA_LEFT or TA_TOP or TA_NOUPDATECP);
  ExtTextOut(Canvas.Handle, Rect.Left + 2, Rect.Top + 1, ETO_CLIPPED or ETO_OPAQUE, @Rect,PChar(Items[Index]), Length(Items[Index]), nil);
  if (odSelected in State) then
    DrawFocusRect(Canvas.Handle, Rect);
end;

Retrieve if a given folder is empty

Problem/Question/Abstract:

Ever needed to check if a folder is empty or not? That's my way of doing. I think it's really fast, but not bench marked yet.

Answer:


uses
  FileCtrl, SysUtils;

function IsEmptyFolder(fld: string): boolean;
var
  sr: tsearchrec;
  r: integer;
begin
  fld := IncludeTrailingBackSlash(fld);
  result := false;
  if (DirectoryExists(fld)) then
  begin
    result := true;
    r := findfirst((fld + '*.*'), faAnyFile, sr);
    while ((r = 0) and (result)) do
    begin
      // Revision 2:
      // checks for system folders "." and ".." that always exists
      // inside an empty folder.
      if ((SR.Attr and faDirectory) <> 0) then
      begin
        if ((sr.name <> '.') and (sr.name <> '..')) then
          result := false;
      end
      else
        result := false;
      r := findnext(sr);
    end;
    // Revision 1:
    // this prevents compiler by using the API defined in windows unit,
    // that will raise a compiler error like this:
    // [Error]:Incompatible types: 'Cardinal' and 'TSearchRec'
    sysutils.findclose(sr);
  end;
end;

Code completion reports a non-existing error

Problem/Question/Abstract:

So I have a component which simply refuses to use code completion, always reporting that there are errors in the source code, however the component compiles absolutely fine. What is the reason?

Answer:

Do you have any conditional defines? If you do, code completion wont work.
(At least not on Delphi 4 Update Pack 3.)

How to get the font of the active title bar

Problem/Question/Abstract:

How do you get hold of the font for the active title bar (after it's been set in the Appearence tab in the display properties)? What API call is needed?

Answer:

function GetCaptionFont(afont: TFont);
var
  ncMetrics: TNonClientMetrics;
begin
  assert(assigned(afont));
  ncMetrics.cbSize := sizeof(TNonClientMetrics);
  SystemParametersInfo(SPI_GETNONCLIENTMETRICS, sizeof(TNonClientMetrics), @ncMetrics,
    0);
  afont.Handle := CreateFontIndirect(ncMetrics.lfCaptionFont);
end;

The TNonClientMetrics structure also contains information on other fonts used in the non-client area information:

lfCaptionFont: Font used in regular captions
lfSmCaptionFont: Font used in small captions
lfMenuFont: Font used in menus
lfStatusFont: Font used in status bars
lfMessageFont: Font used in message boxes

How to make the [Enter] key behave like the [Tab] key

Problem/Question/Abstract:

How to make the [Enter] key behave like the [Tab] key

Answer:

Solve 1:

You need to trap the keystroke and set up your own response to it. Try this: (Note: This will not work within a DBGrid, since the next field is not a separate object.)

procedure TMainForm.FormCreate(Sender: TObject);
begin
  keyPreview := true; {To turn the event "ON"}
end;

procedure TMainForm.FormKeyPress(Sender: TObject; var Key: Char);
begin
  if Key = #13 then
  begin
    Key := #0;
    PostMessage(Handle, WM_NEXTDLGCTL, 0, 0);
  end;
end;


Solve 2:

Use this code for example for an TEdit's OnKeyPress event:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
  if Key = #13 then
  begin
    SelectNext(Sender as TWinControl, True, True);
    Key := #0;
  end;
end;

This causes Enter to behave like tab. Now, select all controls on the form you'd like to exhibit this behavior (not Buttons) and go to the Object Inspector and set their OnKeyPress handler to EditKeyPress. Now, each control you selected will process Enter as Tab. If you'd like to handle this at the form (as opposed to control) level, reset all the controls OnKeyPress properties to blank, and set the form's OnKeyPress property to EditKeyPress. Then, change Sender to ActiveControl and set the form's KeyPreview property to true:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
  if Key = #13 then
  begin
    SelectNext(ActiveControl as tWinControl, True, True);
    Key := #0;
  end;
end;

This will cause each control on the form (that can) to process Enter as Tab.


Solve 3:

Handle this in the OnKeyPress event. The form's KeyPreview property must be set to true.

procedure TFrmEnterTab.FormKeyPress(Sender: TObject; var Key: Char);
begin
  if Key = Chr(VK_RETURN) then
  begin
    if GetKeyState(VK_SHIFT) < 0 then
      SelectNext(ActiveControl, false, true)
    else
      SelectNext(ActiveControl, true, true);
    Key := #0;
  end;
end;

How to create a TCollection

Problem/Question/Abstract:

How do I create a Collection myself? I need a Collection of Items with ArticelNr, Name, Price, etc.. Each item should be in the collection of ResellItems.

Answer:

First, you need to create your ResellItem class based upon TCollectionItem:


TResellItem = class(TCollectionItem)
private
  fArticleNr: integer;
  fName: string;
  fPrice: double;
public
  property ArticleNr: integer read fArticleNr write fArticleNr;
  property Name: string read fName write fName;
  property Price: double read fPrice write fPrice;
end;


The next step is optional although I generally find it useful (self-documents for a start): create a descendent of TCollection:


TResellCollection = class(TCollection)
end;


Now you need to declare an instance somewhere:


var
  ResellCollection: TResellCollection;


The constructor for TCollection takes a TCollectionItem class parameter:


ResellCollection: TResellCollection.Create(TResellItem);


Having created our collection (don't forget to free it afterwards) then adding items becomes:


var
  item: TResellItem;

  item := ResellCollection.Add as TResellItem;
  item.ArticleNr := aNumber;
  item.Name := aName;
  item.Price := aPrice;


I generally wrap the above code into a TResellCollection method, say AddResellItem, thus allowing:


ResellCollection.AddResellItem(aNumber, aName, aPrice);


Accessing items afterwards is done like this:


item := ResellCollection.Items[index] as TResellItem;


The syntax above can be simplified by adding a new default array property to TResellCollection, thus encapsulating the messy casting:


property ResellItem[index: integer]: TResellItem read GetResellItem; default;


The GetResellItem method required looks like this:


function TResellCollection.GetResellItem(index: integer): TResellItem;
begin
  Result := Items[index] as TResellItem;
end;


Now you can say things like:


item := ResellCollection[0];
ResellCollection[1].Name := newname;


Just in case you have got a bit lost with the changes, the interface and implementation of TResellCollection now look like this:


TResellCollection = class(TCollection)
private
  function GetResellItem(index: integer): TResellItem;
public
  procedure AddResellItem(aNumber: integer; const aName: string; aPrice: Double);
  property ResellItem[index: integer]: TResellItem read GetResellItem;
  default;
end;

procedure TResellCollection.AddResellItem(aNumber: integer; const aName: string;
  aPrice: Double);
var
  item: TResellItem;
begin
  item := Add as TResellItem;
  item.ArticleNr := aNumber;
  item.Name := aName;
  item.Price := aPrice;
end;

function TResellCollection.GetResellItem(index: integer): TResellItem;
begin
  Result := Items[index] as TResellItem;
end;

How to put forms into a DLL

Problem/Question/Abstract:

How to put forms into a DLL

Answer:

Create a new Project. In between the word "type" and the "TForm1 = class..." put:

TMyProc = procedure(App: TApplication; Scr: TScreen); stdcall;

In the "private" area of "TForm1" add:

MyDLLHandle: THandle;
ShowMyModuleForm: TMyProc;

Add a "Form1.OnCreate" event and add this code to it:

MyDLLHandle := LoadLibrary('Project2.DLL');
if MyDLLHandle <> 0 then
  @ShowMyModuleForm := GetProcAddress(MyDLLHandle, 'ShowMyForm')
else
  ShowMyModuleForm := nil;

Add a "Form1.OnDestroy" event and add this code to it:

if Assigned(ShowMyModuleForm) then
  ShowMyModuleForm := nil;
if MyDLLHandle <> 0 then
  FreeLibrary(MyDLLHandle);
MyDLLHandle := 0;

Now drop a "TButton" onto the form and add an "OnClick" event with this code:

if (MyDLLHandle <> 0) and (Assigned(ShowMyModuleForm)) then
  ShowMyModuleForm(Application, Screen);

That's all for the EXE side. Now in the "Project Manager" right click the "ProjectGroup1" (Top Node) and select "Add new project" from the popup menu. The add "New Items" dialog comes up and under the "New" tab double click "DLL". In the Project2.DLL source under the "uses" clause insert:

{$R *.res}

procedure ShowMyForm(App: TApplication; Scr: TScreen); stdcall;
var
  a: TForm2;
begin
  Application := App;
  Screen := Scr;
  a := TForm2.Create(Application.MainForm);
  {"Application.MainForm" could also be "nil" or any valid value}
  a.ShowModal;
  a.Free;
end;

exports
  ShowMyForm;

end.

Add to the "uses" clause "Forms". Now in the "Project Manager" right click on the "Project2.dll" and add a form and the class name should be named "TForm2". In the "Implementation" area of the form put:

var
  OldApp: TApplication;
  OldScr: TScreen;

initialization
  OldApp := Application;
  OldScr := Screen;
finalization
  Screen := OldScr;
  Application := OldApp;
end.

Put a "TButton" on the new form and set the "ModalResult" to "mrOk". Compile the "dll" and the "exe". There's a sample form in DLL.

If you already have a form made that you want in the DLL just use it instead of "TForm2". Make sure the "initialization" and "finalization" code is in one, and only one, of the forms you put into the DLL. Without that code you may get unexpected results.

Accessing the Windows Registry

Problem/Question/Abstract:

How can I simply save and get data from the Windows Registry? The purpose of this article is to introduce GetRegistryData and SetRegistryData as an alternative to TRegistry, making it easy to read and write values from and to the Windows Registry, allowing developers to access the registry in a practical way.

Answer:

What is the Registry?

It is where Windows stores many of its configuration options and also allows applications to access this data as well as save their own data. If you want to take a look at the registry, just execute the REGEDIT.EXE application located in the Windows directory. Be careful not to change anything or you could end up ruining your installation! Now, the data in the registry is stored in a tree structure. There are many roots (many trees):

  HKEY_CLASSES_ROOT
  HKEY_CURRENT_USER
  HKEY_LOCAL_MACHINE
  HKEY_USERS
  HKEY_PERFORMANCE_DATA
  HKEY_CURRENT_CONFIG
  HKEY_DYN_DATA

Each root can have values and keys. The values are data stored under item names (right panel of RegEdit). Keys can have values and other keys, forming a tree structure (left panel of RegEdit).

For example, the tree HKEY_CURRENT_USER has many keys, like AppEvents, Control Panel, Identities, Network, Software, etc. Each key may have sub-keys. For example, Control Panel has some sub-keys, like Accessibility, Appearance, Colors, Cursors, Desktop, International, etc. All keys have at least one value (the first value in the right panel of RegEdit), which is the default value (the name of the value is the empty string), not necessarily set. A key may have more values. For example, let's see the key Control Panel\Colors under HKEY_CURRENT_USER. Appart from the default value, it has values like ActiveBorder, ActiveTitle, AppWorkspace, Background, etc. In turn, each "value" has a "data" (the actual value, sort to speak). For example, the data of the value ActiveTitle would be "0 0 128" (may be different if you are not using the standard Windows colors).

TRegistry

Before getting into GetRegistryData and SetRegistryData, let's see how we would accomplish the same tasks the hard way, using TRegistry.

The TRegistry class is declared in the Registry unit, so you will have to add this unit to the Uses clause of the unit or program where you want to use it. To access a value in the registry, first you should create an object of this class, assign the root to its RootKey property (the values are defined in the Windows unit) and then try to open a key with the OpenKey function method, which will return True if successful. Then you can read (with the ReadXxxx functions) or write (with the WriteXxxx procedures) the values of the open key and, after that, you should close the key with CloseKey. When you are done with the registry, you should free the registry object you created. Let's see an example of how to obtain the name of the processor in our computer:

procedure TForm1.Button1Click(Sender: TObject);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  Reg.RootKey := HKEY_LOCAL_MACHINE;
  if Reg.OpenKey('\Hardware\Description\System'
    + '\CentralProcessor\0', False) then
  begin
    ShowMessage(Reg.ReadString('Identifier'));
    Reg.CloseKey;
  end; // if
  Reg.Free;
end;

You can see another example in the article Determining the associated application. Of course, there are many more things you can do with the registry, like creating and deleting keys and values...

The TRegistryIniFile class makes it simpler for applications to write and read their configuration information to and from the registry, while TRegistry operates at a lower level.

GetRegistryData

To simplify reading a data value from the registry you can use the following function that can read any data type from the registry and returns it as a variant (string or integer). The function performs exception handling.

uses Registry;

function GetRegistryData(RootKey: HKEY; Key,
  Value: string): variant;
var
  Reg: TRegistry;
  RegDataType: TRegDataType;
  DataSize, Len: integer;
  s: string;
label
  cantread;
begin
  Reg := nil;
  try
    Reg := TRegistry.Create(KEY_QUERY_VALUE);
    Reg.RootKey := RootKey;
    if Reg.OpenKeyReadOnly(Key) then
    begin
      try
        RegDataType := Reg.GetDataType(Value);
        if (RegDataType = rdString) or
          (RegDataType = rdExpandString) then
          Result := Reg.ReadString(Value)
        else if RegDataType = rdInteger then
          Result := Reg.ReadInteger(Value)
        else if RegDataType = rdBinary then
        begin
          DataSize := Reg.GetDataSize(Value);
          if DataSize = -1 then
            raise Exception.Create(SysErrorMessage(ERROR_CANTREAD));
          SetLength(s, DataSize);
          Len := Reg.ReadBinaryData(Value, PChar(s)^, DataSize);
          if Len <> DataSize then
            raise Exception.Create(SysErrorMessage(ERROR_CANTREAD));
          Result := s;
        end
        else
          raise Exception.Create(SysErrorMessage(ERROR_CANTREAD));
      except
        s := ''; // Deallocates memory if allocated
        Reg.CloseKey;
        raise;
      end;
      Reg.CloseKey;
    end
    else
      raise Exception.Create(SysErrorMessage(GetLastError));
  except
    Reg.Free;
    raise;
  end;
  Reg.Free;
end;

Sample Call

ShowMessage(GetRegistryData(HKEY_LOCAL_MACHINE,
  '\Hardware\Description\System\CentralProcessor\0', 'Identifier'));

SetRegistryData

To simplify writing a data value to the registry you can use the following procedure that can write any data type to the registry. The procedure performs exception handling.

uses Registry;

procedure SetRegistryData(RootKey: HKEY; Key, Value: string;
  RegDataType: TRegDataType; Data: variant);
var
  Reg: TRegistry;
  s: string;
begin
  Reg := nil;
  try
    Reg := TRegistry.Create(KEY_WRITE);
    Reg.RootKey := RootKey;
    if Reg.OpenKey(Key, True) then
    begin
      try
        if RegDataType = rdUnknown then
          RegDataType := Reg.GetDataType(Value);
        if RegDataType = rdString then
          Reg.WriteString(Value, Data)
        else if RegDataType = rdExpandString then
          Reg.WriteExpandString(Value, Data)
        else if RegDataType = rdInteger then
          Reg.WriteInteger(Value, Data)
        else if RegDataType = rdBinary then
        begin
          s := Data;
          Reg.WriteBinaryData(Value, PChar(s)^, Length(s));
        end
        else
          raise Exception.Create(SysErrorMessage(ERROR_CANTWRITE));
      except
        Reg.CloseKey;
        raise;
      end;
      Reg.CloseKey;
    end
    else
      raise Exception.Create(SysErrorMessage(GetLastError));
  except
    Reg.Free;
    raise;
  end;
  Reg.Free;
end;

Sample Call

SetRegistryData(HKEY_LOCAL_MACHINE,
  '\Software\Microsoft\Windows\CurrentVersion',
  'RegisteredOrganization', rdString, 'Latium Software');

You can find another example of SetRegistryData in my article Making an application run automatically when Windows starts.

Component Download: http://www.latiumsoftware.com/download/delphi-2.zip

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

DataSet -> Strings -> DataSet

Problem/Question/Abstract:

DataSet -> Strings -> DataSet

Answer:

///////Begin Source

function StrLeft(const mStr: string; mDelimiter: string): string;
begin
  Result := Copy(mStr, 1, Pos(mDelimiter, mStr) - 1);
end; { StrLeft }

function ListCount(mList: string; mDelimiter: string = ','): Integer;
var
  I, L: Integer;
begin
  Result := 0;
  if mList = '' then
    Exit;
  L := Length(mList);
  I := Pos(mDelimiter, mList);
  while I > 0 do
  begin
    mList := Copy(mList, I + Length(mDelimiter), L);
    I := Pos(mDelimiter, mList);
    Inc(Result);
  end;
  Inc(Result);
end; { ListCount }

function ListValue(mList: string; mIndex: Integer; mDelimiter: string = ','): string;
var
  I, L, K: Integer;
begin
  L := Length(mList);
  I := Pos(mDelimiter, mList);
  K := 0;
  Result := '';
  while (I > 0) and (K <> mIndex) do
  begin
    mList := Copy(mList, I + Length(mDelimiter), L);
    I := Pos(mDelimiter, mList);
    Inc(K);
  end;
  if K = mIndex then
    Result := StrLeft(mList + mDelimiter, mDelimiter);
end; { ListValue }

function DataSetToText(mDataSet: TDataSet; mStrings: TStrings;
  mDelimiter: string = #9): Boolean;
var
  vBookmark: string;
  I: Integer;
  S: string;
begin
  Result := False;
  if (not Assigned(mDataSet)) or (not mDataSet.Active) or
    (not Assigned(mStrings)) then
    Exit;
  mStrings.Text :=
    StringReplace(Trim(mDataSet.FieldList.Text), #13#10, mDelimiter, [rfReplaceAll]);
  vBookmark := mDataSet.Bookmark;
  mDataSet.DisableControls;
  try
    mDataSet.First;
    while not mDataSet.Eof do
    begin
      S := '';
      for I := 0 to mDataSet.FieldList.Count - 1 do
        S := S + mDelimiter + mDataSet.FieldList[I].AsString;
      Delete(S, 1, Length(mDelimiter));
      mStrings.Add(S);
      mDataSet.Next;
    end;
  finally
    mDataSet.Bookmark := vBookmark;
    mDataSet.EnableControls;
  end;
  Result := True;
end; { DataSetToText }

function TextToDataSet(mStrings: TStrings; mDataSet: TDataSet;
  mDelimiter: string = #9): Boolean;
var
  I, J, C: Integer;
  vFieldNames: string;
begin
  Result := False;
  if (not Assigned(mDataSet)) or (not mDataSet.Active) or
    (mStrings.Count <= 0) then
    Exit;
  vFieldNames := mStrings[0];
  C := ListCount(vFieldNames, mDelimiter);
  for I := 1 to mStrings.Count - 1 do
  try
    mDataSet.Append;
    for J := 0 to C - 1 do
      if mDataSet.FieldList.IndexOf(ListValue(vFieldNames, J, mDelimiter)) >= 0 then
        mDataSet[ListValue(vFieldNames, J, mDelimiter)] :=
          ListValue(mStrings[I], J, mDelimiter);
    mDataSet.Post;
  except
    Exit;
  end;
  Result := True;
end; { TextToDataSet }
///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);
begin
  DataSetToText(Table1, Memo1.Lines);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  TextToDataSet(Memo1.Lines, Table1);
end;
///////End Demo

On which storage is you application?

Problem/Question/Abstract:

Sometimes, when you develop a software you need to disable the execution of the code from certain types of media, for example, if your application uses a database file, you can't write on it if it's located on a CR-ROM.
How to manage this in a easy way? There's the solution.

Answer:

Just write down these short routines:

function IsOnHDD: boolean;
begin
  result := GetDriveType(pChar(uppercase(copy(ParamStr(0), 1, 3)))) = DRIVE_FIXED;
end;

function IsOnCD: boolean;
begin
  result := GetDriveType(pChar(uppercase(copy(ParamStr(0), 1, 3)))) = DRIVE_CDROM;
end;

function IsOnRemoveable: boolean;
begin
  result := GetDriveType(pChar(uppercase(copy(ParamStr(0), 1, 3)))) = DRIVE_REMOVABLE;
end;

The use them in your project file (.DPR) like this:

program Project1;

uses
  Windows, // Added manually
  SysUtils, // Added manually
  Dialogs, // Added manually
  Forms,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

function IsOnCD: boolean;
begin
  result := GetDriveType(pChar(uppercase(copy(ParamStr(0), 1, 3)))) = DRIVE_CDROM;
end;

begin
  Application.Initialize;
  if IsOnCD then
  begin
    ShowMessage('This program cannot be executed from a CD-ROM drive.');
    Application.Terminate;
  end
  else
  begin
    Application.CreateForm(TForm1, Form1);
    Application.Run;
  end;
end.

This program will not start if located on a CD-ROM. And no other code than the necessary one will be executed.

Christian Cristofori

How to turn the CapsLock on and off

Problem/Question/Abstract:

How to turn the CapsLock on and off

Answer:

procedure SetLockKey(vcode: Integer; down: Boolean);
begin
  if Odd(GetAsyncKeyState(vcode)) <> down then
  begin
    keybd_event(vcode, MapVirtualkey(vcode, 0), KEYEVENTF_EXTENDEDKEY, 0);
    keybd_event(vcode, MapVirtualkey(vcode, 0), KEYEVENTF_EXTENDEDKEY
      or KEYEVENTF_KEYUP, 0);
  end;
end;

Call by:

SetLockKey(VK_CAPITAL, True); {caps lock down}

Draw lines over a TStringGrid

Problem/Question/Abstract:

I have a TStringGrid with objects put in big coloumns of 4 normal columns. How can I draw a black line from top to bottom over the gray line that the grid itself draws?

Answer:

Handle the OnDrawCell event for the grid. If the cell you are asked to draw is in the column in question you draw the part of the line that crosses the cell:

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
begin
  if (aCol = 1) and not (gdFixed in State) then
  begin
    with (sender as tstringgrid).canvas do
    begin
      Pen.Color := clBlack;
      Pen.Width := 2;
      Pen.Style := psSolid;
      MoveTo(rect.right - 1, rect.top);
      Lineto(rect.right - 1, rect.bottom);
    end;
  end;
end;

How to draw transparent text on a bitmap

Problem/Question/Abstract:

How to draw transparent text on a bitmap

Answer:

The following example demonstrates drawing transparent text on the canvas of a TBitmap:

procedure TForm1.Button1Click(Sender: TObject);
var
  OldBkMode: integer;
begin
  Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;
  OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle, TRANSPARENT);
  Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');
  SetBkMode(Image1.Picture.Bitmap.Canvas.Handle, OldBkMode);
end;