Distributing the BDE with your application

Problem/Question/Abstract:

What are the essential files to ship with an application that uses the BDE?

Answer:

Delphi allows you to generate a nice tight executable file (.EXE), but if you have created a database application you must include the files that make up the Borland Database Engine as well. The table below shows the files that are mandatory when delivering a database application with Delphi.

File Name
Description
IDAPI01.DLL
IDBAT01.DLL
IDQRY01.DLL
IDASCI01.DLL
IDPDX01.DLL
IDDBAS01.DLL
IDR10009.DLL
ILD01.DLL
IDODBC01.DLL
ODBC.New
ODBCINST.NEW
TUTILITY.DLL
BDECFG.EXE
BDECFG.HLP  
IDAPI.CFG
BDE API DLL
BDE Batch Utilities DLL
BDE Query DLL
BDE ASCII Driver DLL
BDE Paradox Driver DLL
BDE dBASE Driver DLL
BDE Resources DLL
Language Driver DLL
BDE ODBC Socket DLL
Microsoft ODBC Driver Manager DLL V2.0
Microsoft ODBC Driver Installation DLL V2.0
BDE Table Repair Utility DLL  
BDE Configuration Utility DLL
BDE Configuration Utility Help
BDE Configuation File (settings)

        
To assist the user, Delphi ships with an install program for exporting the appropriate files that you want deliver to your clients. Also, installation programs such as InnoSetup and InstallShield can automatically include the relevant files in their setup programs.

InnoSetup is my program installation program of choice, and it is FREE! For more information or to download a copy visit Jordan Russell's site at http:// www.jrsoftware.org

Finally a tip on using the setup CAB file that ships with the BDE to install the relevant files can be found in DKB, article title "Installing BDE from BDEINST.CAB"

Combobox instead inplace editor in TStringGrid

Problem/Question/Abstract:

How can I use a combobox as inplace editor in standard TStringGrid?

Answer:

I wrote a small app which demonstrates how you can use the some combobox instead standard inplace editor in TStringGrid component.

Also in this app you can view how change font and/or alignment for some cells.

The form contents as text:

object frmMain: TfrmMain
  Left = 200
    Top = 108
    Width = 510
    Height = 382
    Caption = 'Example: TStringGrid advanced using'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    OnCreate = FormCreate
    PixelsPerInch = 96
    TextHeight = 13
    object StringGrid1: TStringGrid
    Left = 24
      Top = 152
      Width = 457
      Height = 161
      ColCount = 2
      DefaultColWidth = 200
      DefaultRowHeight = 21
      RowCount = 9
      TabOrder = 0
      OnDrawCell = StringGrid1DrawCell
      OnSelectCell = StringGrid1SelectCell
      ColWidths = (
      118
      296)
  end
  object cbInplaceComboBox: TComboBox
    Left = 32
      Top = 320
      Width = 145
      Height = 21
      Style = csDropDownList
      ItemHeight = 13
      Items.Strings = (
      '1 value'
      '2 value'
      '3 value'
      '4 value'
      '5 value'
      '6 value'
      '7 value'
      '8 value'
      '9 value')
      TabOrder = 1
      OnChange = cbInplaceComboBoxChange
  end
  object btnClose: TButton
    Left = 416
      Top = 320
      Width = 75
      Height = 25
      Cancel = True
      Caption = '&Close'
      default = True
      TabOrder = 2
      OnClick = btnCloseClick
  end
  object MemoDescription: TMemo
    Left = 24
      Top = 8
      Width = 457
      Height = 129
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clNavy
      Font.Height = -11
      Font.Name = 'MS Sans Serif'
      Font.Style = [fsBold]
      Lines.Strings = (
      'In this sample I shows how you can:'
      ' '
      '1. change the inplace editor for second column'
      '    from standard inplace editor to user TComboBox component'
      ' '
      '   view the next procedures:'
      '      - TfrmMain.FormCreate'
      '      - TfrmMain.CMDialogKey'
      '      - TfrmMain.cbInplaceComboBoxChange'
      '      - TfrmMain.StringGrid1SelectCell'
      '  '
      '2. draw the cell values with different fonts'
      ' '
      '   view the next procedure:'
      '      - TfrmMain.StringGrid1DrawCell'
      ' '
      '3. change alignment for cells'
      ' '
      '   view the next procedure:'
      '      - TfrmMain.StringGrid1DrawCell')
      ParentFont = False
      ScrollBars = ssVertical
      TabOrder = 3
  end
end

The pas - file for same form:

unit Main;

interface

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

type
  TfrmMain = class(TForm)
    StringGrid1: TStringGrid;
    cbInplaceComboBox: TComboBox;
    btnClose: TButton;
    MemoDescription: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure cbInplaceComboBoxChange(Sender: TObject);
    procedure StringGrid1SelectCell(Sender: TObject; Col, Row: Integer;
      var CanSelect: Boolean);
    procedure StringGrid1DrawCell(Sender: TObject; Col, Row: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure btnCloseClick(Sender: TObject);
  private
    { Private declarations }
    procedure CMDialogKey(var msg: TCMDialogKey); message CM_DIALOGKEY;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}

procedure TfrmMain.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  StringGrid1.DefaultRowHeight := cbInplaceComboBox.Height;
  cbInplaceComboBox.Visible := False;

  StringGrid1.Cells[0, 0] := 'Row No';
  StringGrid1.Cells[1, 0] := 'Values (from Combobox)';
  for i := 1 to StringGrid1.RowCount - 1 do
    StringGrid1.Cells[0, i] := IntToStr(i);
end;

procedure TfrmMain.CMDialogKey(var msg: TCMDialogKey);
begin
  if (ActiveControl = cbInplaceComboBox) then
  begin
    if (msg.CharCode = VK_TAB) then
    begin
      //set focus back to the grid and pass the tab key to it
      cbInplaceComboBox.SetFocus;
      cbInplaceComboBox.Perform(WM_KEYDOWN, msg.CharCode, msg.KeyData);
      // swallow this message
      msg.result := 1;
      Exit;
    end;
  end;

  inherited;
end;

procedure TfrmMain.cbInplaceComboBoxChange(Sender: TObject);
var
  intRow: Integer;
begin
  inherited;

  {Get the ComboBox selection and place in the grid}
  with cbInplaceComboBox do
  begin
    intRow := StringGrid1.Row;
    if (StringGrid1.Col = 2) then
      StringGrid1.Cells[2, intRow] := Items[ItemIndex]
    else
      StringGrid1.Cells[StringGrid1.Col, intRow] := Items[ItemIndex];
    Visible := False;
  end;
  StringGrid1.SetFocus;
end;

procedure TfrmMain.StringGrid1SelectCell(Sender: TObject; Col, Row: Integer;
  var CanSelect: Boolean);
var
  R: TRect;
begin
  if ((Col = 1) and (Row <> 0)) then
  begin
    {Size and position the combo box to fit the cell}
    R := StringGrid1.CellRect(Col, Row);
    R.Left := R.Left + StringGrid1.Left;
    R.Right := R.Right + StringGrid1.Left;
    R.Top := R.Top + StringGrid1.Top;
    R.Bottom := R.Bottom + StringGrid1.Top;

    {Show the combobox}
    with cbInplaceComboBox do
    begin
      Left := R.Left + 1;
      Top := R.Top + 1;
      Width := (R.Right + 1) - R.Left;
      Height := (R.Bottom + 1) - R.Top;

      ItemIndex := Items.IndexOf(StringGrid1.Cells[Col, Row]);
      Visible := True;
      SetFocus;
    end;
  end;
  CanSelect := True;
end;

procedure TfrmMain.StringGrid1DrawCell(Sender: TObject; Col, Row: Integer;
  Rect: TRect; State: TGridDrawState);
const
  AlignFlags: array[TAlignment] of Integer =
  (DT_LEFT or DT_VCENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
    DT_RIGHT or DT_VCENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
    DT_CENTER or DT_VCENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX);
var
  s: string;
begin
  inherited;

  with Rect do
  begin
    Left := Left + 2;
    Top := Top + 2;
    Right := Right - 5
  end;

  s := StringGrid1.Cells[Col, Row];

  if (Row = 0) and (Col < StringGrid1.ColCount) then
  begin
    StringGrid1.Canvas.Font.Style := StringGrid1.Canvas.Font.Style + [fsBold];
    StringGrid1.Canvas.Brush.Color := StringGrid1.FixedColor;
    StringGrid1.Canvas.FillRect(Rect);

    DrawText(StringGrid1.Canvas.Handle,
      PChar(s), Length(s),
      Rect, AlignFlags[taCenter]);
  end
  else if (Col = 0) and (Row > 0) and (Row < StringGrid1.RowCount) then
  begin
    StringGrid1.Canvas.FillRect(Rect);
    DrawText(StringGrid1.Canvas.Handle,
      PChar(s), Length(s),
      Rect, AlignFlags[taRightJustify]);
  end;
end;

procedure TfrmMain.btnCloseClick(Sender: TObject);
begin
  Close
end;

end.


Component Download: http://www.geocities.com/mshkolnik/FAQ/strgrid.zip

How to get and set the volume on a wave device

Problem/Question/Abstract:

How to get and set the volume on a wave device

Answer:

Here are a couple of functions for getting/ setting the volume on the default wave device:


uses
  mmsystem;

function GetWaveVolume: DWord;
var
  Woc: TWAVEOUTCAPS;
  Volume: DWord;
begin
  if WaveOutGetDevCaps(WAVE_MAPPER, @Woc, sizeof(Woc)) = MMSYSERR_NOERROR then
    if Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then
    begin
      WaveOutGetVolume(WAVE_MAPPER, @Volume);
      Result := Volume;
    end;
end;

procedure SetWaveVolume(const AVolume: DWord);
var
  Woc: TWAVEOUTCAPS;
begin
  if WaveOutGetDevCaps(WAVE_MAPPER, @Woc, sizeof(Woc)) = MMSYSERR_NOERROR then
    if Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then
      WaveOutSetVolume(WAVE_MAPPER, AVolume);
end;


Here's how they might be used:


procedure TForm1.Button2Click(Sender: TObject);
var
  LeftVolume: Word;
  RightVolume: Word;
begin
  LeftVolume := StrToInt(Edit1.Text);
  RightVolume := StrToInt(Edit2.Text);
  SetWaveVolume(MakeLong(LeftVolume, RightVolume));
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  Caption := IntToStr(GetWaveVolume);
end;

Form with custom caption bar

Problem/Question/Abstract:

How to remove system caption bar (title bar) or replace it by my own?

Answer:

Below you can find the source code of a unit that performs the task (note that it is not a form). All you need is to inherit your form from TDPCCForm instead of TForm. Property CaptionControl is accessible at run time and defines the control (TGraphicControl) which acts as a caption bar. Usually you assign CaptionControl once in OnCreate event handler of you form, but nothing prevents you from further changes of CaptionControl at run time. If you leave CaptionControl unassigned, the form will have no caption functionality at all.

unit DPCCForms;

interface

uses
  Windows, Messages, Classes, Controls, Forms;

type
  TDPCCForm = class(TForm)
  private
    { Private declarations }
    FCaptionControl: TGraphicControl;
    procedure WMNCHitTest(var AMessage: TWMNCHitTest); message WM_NCHITTEST;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    { Public declarations }
    property CaptionControl: TGraphicControl
      read FCaptionControl write FCaptionControl default nil;
  end;

  {===============================================================}
implementation

{---------------------------------------------------------------}

procedure TDPCCForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := (Style or WS_POPUP) and (not WS_DLGFRAME);
  end; {with}
end {--TDPCCForm.CreateParams--};

{---------------------------------------------------------------}

procedure TDPCCForm.WMNCHitTest(var AMessage: TWMNCHitTest);
begin
  inherited;
  if ((AMessage.Result = HTCLIENT) and
    Assigned(CaptionControl) and
    PtInRect(CaptionControl.BoundsRect,
    ScreenToClient(Point(AMessage.XPos,
    AMessage.YPos)))) then
  begin
    AMessage.Result := HTCAPTION;
  end; {if}
end; {--TDPCCForm.WMNCHitTest--}

end.

Open registered files

Problem/Question/Abstract:

How to open a registered file from Delphi

Answer:

Example:

OpenRegisteredFile('c:\windows\desktop\MyHTML.html');
OpenRegisteredFile('d:\data\MyDocuments\FAQ.doc');
OpenRegisteredFile('c:\mp3z\MyFavMp3.mp3');

uses
  WinTypes, ShellApi;

procedure OpenRegisteredFile(Path: string);
begin
  ShellExecute(0, nil, PChar(Path), nil, nil, SW_NORMAL);
end;

How to build sets of letters for the currently selected language

Problem/Question/Abstract:

Is there any way to enumerate the contents of a set? Just now I have a set of char, each char is a lower case character, and need to add the corresponding upper case characters to the set. Any other way than looping through the set range and do an inclusion check each time?

Answer:

No. If you are after building sets of letters for the currently selected language you could do it using API functions like IsCharAlpha and IsCharUpper:


unit Charsets;

interface

type
  TCharSet = set of AnsiChar;

const
  Signs: TCharset = ['-', '+'];
  Numerals: TCharset = ['0'..'9'];
  HexNumerals: TCharset = ['A'..'F', 'a'..'f', '0'..'9'];
  IntegerChars: TCharset = ['0'..'9', '-', '+'];
var
  Letters, LowerCaseLetters, UpperCaseLetters: TCharSet;
  FloatChars, SciFloatChars: TCharset;
  AlphaNum, NonAlphaNum: TCharset;

  { Need to call this again when locale changes.  }
procedure SetupCharsets;

implementation

uses
  Windows, Sysutils;

procedure SetupCharsets;
var
  ch: AnsiChar;
begin
  LowerCaseLetters := [];
  UpperCaseLetters := [];
  AlphaNum := [];
  NonAlphaNum := [];
  for ch := Low(ch) to High(ch) do
  begin
    if IsCharAlpha(ch) then
      if IsCharUpper(ch) then
        Include(UpperCaseLetters, ch)
      else
        Include(LowerCaseLetters, ch);
    if IsCharAlphanumeric(ch) then
      Include(AlphaNum, ch)
    else
      Include(NonAlphaNum, ch);
  end;
  Letters := LowerCaseLetters + UpperCaseLetters;
  FloatChars := IntegerChars;
  Include(FloatChars, DecimalSeparator);
  SciFloatChars := FloatChars + ['e', 'E'];
end;

initialization
  SetupCharsets;

end.

Speeding up compilation/ linking process

Problem/Question/Abstract:

When minor change in any file and re-run project in Delphi compile and link time is very long.(2 minutes) How can I speed compile and link process?

Answer:

While developing your project I'd suggest you to compile it with runtime packages, then when the time comes, you recompile everything into your EXE again, this will speed it up.
I've also been working with a rather big project and also experienced that kind of problem since my processor is rather out-dated. I'd also suggest you to divide your code ( if your code is not a mixture of every unit in you project ) into packages, this will help you to have a better organization, and will even speed up more you compile time since you'll be compiling only the unit you are willing to debug.
Compiling every unit in your project every time you make a minor change will make you waste a lot of time.
Runtime Packages are a great tool for developing projects.

Creating an ActiveX for ASP

Problem/Question/Abstract:

How to create an ActiveX that can be used in Active Server Pages for dynamic content?

Answer:

This article shows you how to create a server-side ActiveX library you can use within ASP (Active Server
Pages). We'll keep it very simple.

CREATING THE ACTIVEX SERVER

First, start Delphi and/or close all current projects. Select File|New and change to the "ActiveX" tab. Select the "ActiveX library" project type. AxtiveX libraries, as this can be used for ASP. They are DLL that are implemented by the Server.CreateObject (VBScript) directive.
An ActiveX library must export 4 routines, allowing it to be un-/registered, export its objects and tell the calling process whether it may be unloaded. These for four functions are provided through the ComServ unit, by Borland. You do not have worry about them.
Next, we will create an "Active Server Object". You find these within the File|New dialog on the "ActiveX" tab, too. You will see a dialog with quite a few options. First we will have to enter CoClass Name. This is the name we will use when accessing the object from within our ASP page. Let's call it "Sample". Now we have to choose the "instancing model" and the "threading model". Choose "Single Instance" and "Apartment" from the drop-down lists. (I will explain these models in another article, later on. Drop me an e-mail if you want me to tell you when.) For "Active Server Type" choose "Object Context", leave the check mark in the "Generate template..." check box and press OK.
Delphi will create a new unit (unit1), an ASP (sample.asp), and a type library (project1_tlb). Let's save these files now. (Choose save all and use the following names: uSample.pas, Sample.asp, First.dpr). Goto to the menu and select View|Type Library. This window shows all the objects with their methods and properties within the type library we create. The root object is named "First" (if you've used the same file names). This is your type library name, it must be unique on the machine it is running. Underneath "First" you see two more entries (ISample and Sample). One is the public dispatch interface declaration where all methods and properties are names, the other is the object name that is used within the applications accessing you ActiveX library.
Select the ISampe entry. In the tool bar you will see a green icon (New Method) and a blue icon (New Property) to its right. These are the two we are going to check out in this article.
First select new method. A new entry ("Method1) will appear underneath the ISample entry. Change its name to ShowTime. Select the "Parameters" tab on the right and add a new parameter to the list. Set its name to "TheTime", the type to "BSTR *". Double-click the modifier with your mouse and select "out" and "retval". The "in" box will be deselected automatically. It is not working with "retval" together. We have declared the Parameter "TheTime" as WideString (ASO does not support Pascal Type Strings) as a Return Value. Close the Box by pressing OK.
Save your project files (!), goto to your editor window and select the uSample unit. Delphi has added the following method, automatically:

function ShowTime: WideString; safecall;

Since the parameter "TheTime" was declared as Return Value, Delphi created a function with the Result Type
WideString. The safecall directive tells the Delphi Compiler to ensure the proper DLL/COM wrapping for the
function.

Fill out the ShowTime function as follows:

function TSample.ShowTime: WideString;
begin
  Result := FormatDateTime(
    '"This function was called on " dddd, mmmm d, yyyy, " at " hh:mm AM/PM',
    Now
    );
end;

That's all for the Delphi code. Save your project and select Run|Register ActiveX Server from your menu. The ActiveX server has to be installed on the machine where it is used. Without Delphi you can do this by calling

regsvr32 "Drive:\Path\FileName.dll"

from the command line. Add the parameter /u to unregister the ActiveX server.

THE ACTIVE SERVER PAGE

Delphi has prepare the Sample.asp file already. we just have to fill in the missing parts.

In our case we have to change the line

   DelphiASPObj.{Insert Method name here}

into

   Response.Write DelphiASPObj.ShowTime

"Response.Write" tells ASP to write the following text (provided by our function) into the current place of our HTML code.

Copy the sample ASP into your web server directory (/test) and call it like:

http://localhost/test/sample.asp.

You should have installed either the MS Internet Information Server (IIS) or MS Personal Web Server (PWS).
Good luck and stay tuned for more.

How to apply the Windows Shutdown screen effect to a bitmap

Problem/Question/Abstract:

I would like to apply this "screening" effect to a bitmap. I have tried PatBlt, DrawState, and BitBlt, but I don't know what combination of params I need.

Answer:

Create an 8 x 8 bitmap, where the pixels alternate black and white (as in a checkerboard).

Load that bitmap into the Brush.Bitmap property of whatever Canvas it is that you're trying to modify.

Set the canvas's CopyMode to $00A000C9. (This ANDs the destination with the pattern).

Use CopyRect to draw the canvas onto itself. Example:

var
  Bmp: TBitmap;
begin
  Bmp := TBitmap.Create;
  Bmp.LoadFromFile('brush.bmp');
  with Image1.Picture.Bitmap do
  begin
    Canvas.Brush.Bitmap := Bmp;
    Canvas.CopyMode := $00A000C9;
    Canvas.CopyRect(Rect(0, 0, Width, Height), Canvas, Rect(0, 0, 0, 0));
  end;
  Bmp.Free;
end;

Pulling Digits Out of String to Sum Them

Problem/Question/Abstract:

How do I pull out every second digit from a string and sum them?

Answer:

This is a rather unusual question, but it's not that hard to accomplish.

What must iterate through each character of the string and "grab" the digits whose position is a multiple of two (2). There are a couple of ways to do this, but I took what I felt was the easier route. Since this is more or less a binary problem, setting a Boolean value with each iteration works nicely. Here's the logic:

For all "odd" positions, set Boolean value to False;
For all "even" positions, set Boolean value to True;
If the Boolean value is true, grab that character and add it to a temporary buffer.
Iterate through the buffer, and convert each character to an Integer while adding the converted value to an integer variable.

Here's the code that accomplishes the above:

function AddEvenOrOddChars(S: string; OddOrEven: Boolean): Integer;
var
  I: Integer;
  evn: Boolean;
  buf: string;
begin
  Result := 0;

  {If OddOrEven was passed as True, then the all odd positions
   will be grabbed and summed. If False, then all even positions
   will be grabbed and summed.}
  evn := EvenOdd;

  {First grab the even position characters}
  for I := 1 to Length(S) do
  begin
    if evn then
      buf := buf + S[I];

    {Set boolean to its opposite regardless of its current value.
     If it's currently true, then we've just grabbed a character.
     Setting it to False will make the program skip the next one.}
    evn := not evn;
  end;

  {Now, iterate through the buffer variable to add up the individual
   values}
  for I := 1 to Length(buf) do
    Result := Result + StrToInt(buf[I]);
end;

Customizing the display of IBObject queries

Problem/Question/Abstract:

Customizing the display of IBObject queries

Answer:

If you use IBObjects for your InterBase client application, you can use the powerful TIB_Cursor and TIB_Query to modify how your query results will look for example in a grid. Take a look at the sample source code below.

Note:
All those settings can be made via the object inspector, but when the SQL property is updated at runtime with a new query, some of these properties seem to get wiped out. Therefore it's better to set them at run-time in code.

begin
  with TIB_Query1 do
  begin
    FieldsVisible.Add('ID=F');
    FieldsVisible.Add('SLNR=T'); { not really necessary }
    FieldsCharCase.Add('LAND=UPPER');
    FieldsDisplayLabel.Add('COMMENTS=Your Comments');
    FieldsDisplayWidth.Add('COMMENTS=200');
  end;
end;

Compact an Access database (2)

Problem/Question/Abstract:

How to compact and repair MS Access 2000 (Jet Engine 4) during run time using Delphi 5?

Answer:

Usually the size of MS Access keep growing fast by time because of it&#8217;s internal caching and temporary buffering, which in over whole effect the performance, space required for storing, and backing-up (if needed).  The solution is to compact it from Access menus (Tools &#8211; Database Utilities &#8211; Compact and Repair Database) or to do that from inside your Delphi application.

function CompactAndRepair(sOldMDB: string; sNewMDB: string): Boolean;
const
  sProvider = 'Provider=Microsoft.Jet.OLEDB.4.0;';
var
  oJetEng: JetEngine;
begin
  sOldMDB := sProvider + 'Data Source=' + sOldMDB;
  sNewMDB := sProvider + 'Data Source=' + sNewMDB;

  try
    oJetEng := CoJetEngine.Create;
    oJetEng.CompactDatabase(sOldMDB, sNewMDB);
    oJetEng := nil;
    Result := True;
  except
    oJetEng := nil;
    Result := False;
  end;
end;

Example :

if CompactAndRepair('e:\Old.mdb', 'e:\New.mdb') then
  ShowMessage('Successfully')
else
  ShowMessage('Error&#8230;');

Important Notes:
Include the JRO_TLB unit in your uses clause.
Nobody should use or open the database during compacting.
If the compiler gives you an error on the JRO_TLB unit follow these steps:
Using the Delphi IDE go to Project &#8211; Import Type Library.
Scroll down until you reach &#8220;Microsoft Jet and Replication Objects 2.1 Library&#8221;.
Click on Install button.
Recompile a gain.

Shutting down a machine across the network

Problem/Question/Abstract:

How to send a shutdown command in a network?

Answer:

{-----------------------------------------------------------------------------
Unit Name:     formClient
Author:        Stewart Moss

Creation Date: 27 February, 2002 (16:30)
Documentation Date: 27 February, 2002 (16:30)

Version 1.0
-----------------------------------------------------------------------------

Description:

  This is to demonstrate shutting down a machine over the network.

  ** Tobias R. requests the article "How to send a shutdown command in a network?" **

  This is not really what you want. I think you are looking for some kind
  of IPC or RPC command. But this will work. Each machine needs to run
  a copy of this server.

  It uses the standard delphi ServerSocket found in the "ScktComp" unit.

  Create a form (name frmClient) with a TServerSocket on it (name ServerSocket)
  set the Port property of ServerSocket to 5555. Add a TMemo called Memo1.

  It listens on port 5555 using TCP/IP.

  It has a very simple protocol.
  Z = Show message with "Z"
  B = Beep
  S = Shutdown windows

  Run the program.. Then from the command prompt type in
  "telnet localhost 5555". Type in one of the three commands above
  (all in uppercase) and the server will respond.

Copyright 2002 by Stewart Moss. All rights reserved.
-----------------------------------------------------------------------------}

unit formClient;

interface

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

type
  TfrmClient = class(TForm)
    ServerSocket: TServerSocket;
    Memo1: TMemo;
    procedure ServerSocketClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmClient: TfrmClient;

implementation

{$R *.DFM}

procedure TfrmClient.ServerSocketClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
var
  Incomming: string;
begin
  // read off the socket
  Incomming := Socket.ReceiveText;

  memo1.Lines.Add(incomming);

  if Incomming = 'S' then // Shutdown Protocol
    ExitWindowsEx(EWX_FORCE or EWX_SHUTDOWN, 0);

  if Incomming = 'B' then // Beep Protocol
    Beep;

  if Incomming = 'Z' then // Z protocol
    showmessage('Z');
end;

procedure TfrmClient.FormCreate(Sender: TObject);
begin
  ServerSocket.Active := true;
end;

procedure TfrmClient.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ServerSocket.Active := false;
end;

end.

Simple useful Irc routines for server protocol

Problem/Question/Abstract:

How to implement some elements of the IRC protocol

Answer:

{-----------------------------------------------------------------------------
Unit Name: IrcStructures

Documentation Date: 19/02/02 23:56:45
Release Date: 8/21/2002
Version: 1.0

Compiler directives:

Purpose:

  Quick framework for keeping track of IRC protocol.

  Was written as a base framework for a simple IRC server

History:

          Copyright 2001 by Stewart Moss
          All rights reserved.
-----------------------------------------------------------------------------}

unit IrcStructures;

interface

type
  recNick = record
    Nick, Email: string;
  end;

type
  RecChannel = record
    ChannelName,
      ChannelTopic: string;
    NumberOfPeople: Integer;
    NickCount: Integer;
    Nicks: array[0..99] of recNick;
  end;

var
  ChanCount: Integer;
  Channels: array[0..99] of RecChannel;

function InitializeChannels: Boolean;

function ChanExist(Channel, Nick: string): Boolean;
function AddChannel(Channel, Topic, Nick: string): Boolean;
function FindChannel(Channel, Nick: string): Integer;
function JoinChannel(Channel, Nick: string): string;

function addNick(ChannelNo: Integer; Nick: string): Boolean;
function NickExists(ChannelNo: Integer; Nick: string): Boolean;

implementation

function InitializeChannels: Boolean;
var
  loop2, loop: integer;
begin
  for loop := 0 to 99 do
  begin
    for loop2 := 0 to 99 do
      Channels[Loop].Nicks[Loop2].Nick := '';
  end;
end;

function ChanExist(Channel, Nick: string): Boolean;
var
  loop: integer;
begin
  Result := False;
  for loop := 0 to ChanCount do
  begin
    if Channel = Channels[Loop].ChannelName then
      Result := true;
  end;
end;

function AddChannel(Channel, Topic, Nick: string): Boolean;
begin
  result := false;
  if ChanExist(Channel, Nick) then
    exit;
  inc(ChanCount);
  Channels[ChanCount].ChannelName := Channel;
  Channels[ChanCount].ChannelTopic := Topic;
  Channels[ChanCount].NumberOfPeople := 0;
  Channels[ChanCount].NickCount := 0;
  result := true;
end;

function FindChannel(Channel, Nick: string): Integer;
var
  loop: integer;
begin
  Result := -1;
  for loop := 0 to ChanCount do
  begin
    if Channel = Channels[Loop].ChannelName then
      Result := Loop;
  end;
end;

function NickExists(ChannelNo: Integer; Nick: string): Boolean;
var
  loop: integer;
begin
  Result := false;
  with Channels[ChannelNo] do
  begin
    for loop := 1 to NickCount do
    begin
      if nicks[Loop - 1].Nick = Nick then
        result := true;
    end;
  end;
end;

function addNick(ChannelNo: Integer; Nick: string): Boolean;
begin
  Result := false;
  if NickExists(ChannelNo, Nick) then
    exit;
  with Channels[ChannelNo] do
  begin
    inc(NickCount);
    nicks[NickCount].Nick := Nick;
  end;
  Result := True;
end;

function JoinChannel(Channel, Nick: string): string;
var
  ChanOfs: Integer;
begin
  Result := 'Could not join ' + Channel;
  ChanOfs := FindChannel(Channel, Nick);
  if ChanOfs = -1 then
    exit;
  with Channels[ChanOfs] do
  begin
    if addNick(ChanOfs, Nick) then
      Result := 'Joined ' + Channel;
  end;
end;

end.

Implementing 'Drag Scrolling' in a Grid (as Excel has..)

Problem/Question/Abstract:

When dragging an object over a grid, if the cell you require is not visible, or only partially visible, it would be useful to have the grid automatically scroll to bring the cell into view (a kind of drag-hot-tracking).

Excel does it, Lotus 123 does it, now let's make a humble TStringGrid do it.

This builds on the article/ tutorial of 'Published Objects in Components'

Answer:

This article builds on information given in the article 'Published Objects in Components' (ID 3039) about how to add 'dropdown' properties in the object inspector. You do not need to read or understand that article, but it would serve as background reading!

To provide a 'drag-scrolling' mechanism to a grid, the main principles are:

override the dragover method, and within it:  check whether the cursor is within certain user-defined margins, if within the margins, start the drag-scroll process, initialising a timer  if not within the margins, stop the timer
provide a timer method which will check (at a user-defined interval) whether the cursor still falls within the margin, if so, continue scrolling

The timer is used, as if the user stops moving, but is still over the grid, it will still need checking (a dragmove will only occur when the mouse actually moves).

To facilitate all this, and provide a suite of options, I have gone the route of providing a new object (TDragScrollOptions) which encapsulates all the requied options - margins, timer values, etc. This, in turn, has some objects defined within itself as well (TDragScrollDelays, TDragScrollMargins)..

The structure is as follows:

TDragScrollOptions

property Active: boolean;
  property Delays: TDragScrollDelays;
    |
      - property InitialDelay: integer;
      - property RepeatDelay: integer;
  property Margins: TDragScrollMargins;
          |
            - property TopMargin: integer;
            - property BottomMargin: integer;
            - property LeftMargin: integer;
            - property RightMargin: integer;
end;

The Delays work as one would now expect with any windows application - an initial wait, then a faster response afterwards - hence the Initial and Repeat delays.

The Margins are application from the edges of the component. If the cursor falls between an edge and its repective margin, a scroll can happen.

An Event has been added to allow the developer to monitor the drag scrolling, with an option to cancel the operation (the CanScroll parameter):

TDragScrollEvent = procedure(Sender: TObject; TopRow, LeftCol: LongInt; var
  DragScrollDir: TDragScrollDirection; var CanScroll: boolean) of object;

Enough waffle!! Here is the base component. Copy it into a unit, save and install! Feel free to take out the drag scroll stuff for your own favourite grid (my most used grid has features from all over the place - I wrote this part all myself tho' - no copyright infringement!).

If you use the component, or take the drag scroll engine elsewhere, please let me know (just out of interest really!) - duncanparsons@hotmail.com

unit DragScrollGrid;

{&copy; Duncan Parsons 2002
This Component is freeware, but I am interested in where it ends up!!
Drop me a line on duncanparsons@hotmail.com

Grid with 'Drag Scroll' Option - when an object is dragged over the control,
                                  it will scroll to reveal the hidden cells as needed

If you make any good changes, let me know!
Happy Coding
Duncan Parsons}

interface

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

type
  //For Drag-Scrolling
  TDragScrollDelays = class(TPersistent)
  private
    fInitialDelay: integer;
    fRepeatDelay: integer;
  published
    property InitialDelay: integer read fInitialDelay write fInitialDelay default
      1000;
    property RepeatDelay: integer read fRepeatDelay write fRepeatDelay default 250;
  end;
  TDragScrollMargins = class(TPersistent)
  private
    fTopMargin: integer;
    fBottomMargin: integer;
    fLeftMargin: Integer;
    fRightMargin: Integer;
  published
    property TopMargin: integer read fTopMargin write fTopMargin default 50;
    property BottomMargin: integer read fBottomMargin write fBottomMargin default 50;
    property LeftMargin: Integer read fLeftMargin write fLeftMargin default 50;
    property RightMargin: Integer read fRightMargin write fRightMargin default 50;
  end;

  TDragScrollOptions = class(TPersistent)
  private
    fActive: Boolean;
    fDelays: TDragScrollDelays;
    fMargins: TDragScrollMargins;
  public
    constructor create; //override;
    destructor destroy; override;
  published
    property Active: boolean read fActive write fActive;
    property Delays: TDragScrollDelays read fDelays write fDelays;
    property Margins: TDragScrollMargins read fMargins write fMargins;
  end;

  TDragScrollDirections = (dsdUp, dsdDown, dsdLeft, dsdRight);
  TDragScrollDirection = set of TDragScrollDirections;
  TDragScrollEvent = procedure(Sender: TObject; TopRow, LeftCol: LongInt; var
    DragScrollDir: TDragScrollDirection; var CanScroll: boolean) of object;

type
  TDragScrollGrid = class(TStringGrid)
  private
    { Private declarations }
    //Drag Scrolling
    fDragScrollOptions: TDragScrollOptions;
    fTmr: TTimer;
    fDragScrollDirection: TDragScrollDirection;
    fOnDragScroll: TDragScrollEvent;
    procedure SetDragScrollOptions(Value: TDragScrollOptions);
  protected
    { Protected declarations }
    procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept:
      Boolean); override;
    procedure TimerProc(Sender: Tobject);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property OnDragScroll: TDragScrollEvent read fOnDragScroll
      write fOnDragScroll;
    property DragScrollOptions: TDragScrollOptions read fDragScrollOptions write
      SetDragScrollOptions;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TDragScrollGrid]);
end;

//---TDragScrollOptions

constructor TDragScrollOptions.create;
begin
  inherited;
  fDelays := TDragScrollDelays.create;
  fDelays.InitialDelay := 1000;
  fDelays.RepeatDelay := 250;
  fMargins := TDragScrollMargins.create;
  fMargins.TopMargin := 50;
  fMargins.BottomMargin := 50;
  fMargins.LeftMargin := 50;
  fMargins.RightMargin := 50;
end;

destructor TDragScrollOptions.destroy;
begin
  fDelays.free;
  fMargins.free;
  inherited;
end;

//---TDragScrollGrid

constructor TDragScrollGrid.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fDragScrollOptions := TDragScrollOptions.create;
end;

destructor TDragScrollGrid.Destroy;
begin
  if Assigned(fTmr) then
  begin
    fTmr.enabled := false;
    fTmr.Free;
  end;
  fDragScrollOptions.free;

  inherited Destroy;
end;

//---Drag Scroll initialisation and finalisation

procedure TDragScrollGrid.DragOver(Source: TObject; X, Y: Integer; State: TDragState;
  var Accept: Boolean);
var
  CurrentlyScrolling: boolean;
begin
  if not (fDragScrollOptions.Active) then
  begin
    if Assigned(fTmr) then
    begin
      fTmr.enabled := false;
      fTmr.free;
      fTmr := nil;
    end;
    inherited;
    exit;
  end;
  if fDragScrollDirection = [] then
    CurrentlyScrolling := false
  else
    CurrentlyScrolling := true;
  fDragScrollDirection := [];
  case State of
    dsDragEnter, dsDragMove:
      begin
        //Moving in the Grid, Check the Borders
        if y Include(fDragScrollDirection, dsdUp)
  else
    if y > (Height - fDragScrollOptions.Margins.BottomMargin) then
      Include(fDragScrollDirection, dsdDown);
    if x Include(fDragScrollDirection, dsdLeft)
  else
    if x > (width - fDragScrollOptions.Margins.RightMargin) then
      Include(fDragScrollDirection, dsdRight);
    //Any Borders hit?
    if fDragScrollDirection = [] then
    begin
      //Turn Timer off
      if Assigned(fTmr) then
      begin
        fTmr.Enabled := false;
        fTmr.free;
        fTmr := nil;
      end;
    end
    else
    begin
      if not (Assigned(fTmr)) then
      begin
        fTmr := TTimer.Create(Parent);
        fTmr.Interval := fDragScrollOptions.Delays.InitialDelay;
        fTmr.OnTimer := TimerProc;
        fTmr.enabled := true;
      end
      else
      begin
        //Reset the Timer if a new scroll is required
        if not (CurrentlyScrolling) then
          fTmr.Interval := fDragScrollOptions.Delays.InitialDelay;
      end;
    end;
  end;
  dsDragLeave:
  begin
    if Assigned(fTmr) then
    begin
      fTmr.Enabled := false;
      fTmr.free;
      fTmr := nil;
    end;
  end;
end;
inherited;
end;

//---Drag Scroll Timer..

procedure TDragScrollGrid.TimerProc(Sender: Tobject);
var
  CanScroll: Boolean;
  DSD: TDragScrollDirection;
begin
  if not (fDragScrollOptions.Active) then
  begin
    fTmr.Enabled := false;
    fTmr.free;
    fTmr := nil;
    exit;
  end;
  fTmr.Interval := fDragScrollOptions.Delays.RepeatDelay;
  //Do Scroll if User is OK with it
  DSD := fDragScrollDirection;
  if Assigned(fOnDragScroll) then
  begin
    CanScroll := true;
    fOnDragScroll(Self, TopRow, LeftCol, DSD, CanScroll);
    if not (CanScroll) then
      exit;
  end;
  //Allow scroll
  if dsdUp in DSD then
  begin
    if TopRow > FixedRows then
      TopRow := TopRow - 1;
  end;
  if dsdDown in DSD then
  begin
    if (TopRow + VisibleRowCount) < (RowCount) then
      TopRow := TopRow + 1;
  end;
  if dsdLeft in DSD then
  begin
    if LeftCol > FixedCols then
      LeftCol := LeftCol - 1;
  end;
  if dsdRight in DSD then
  begin
    if (LeftCol + VisibleColCount) < (ColCount) then
      LeftCol := LeftCol + 1;
  end;
end;

//---

procedure TDragScrollGrid.SetDragScrollOptions(Value: TDragScrollOptions);
begin
  fDragScrollOptions.Assign(Value);
  if csDesigning in ComponentState then
    invalidate;
end;

end.


Component Download: DragScrollGrid.zip

How to avoid the "Drive A Not Ready" error

Problem/Question/Abstract:

How to avoid the "Drive A Not Ready" error

Answer:

When your program accesses drive 'A', it would be handy to intercept the 'Drive Not Ready' system error message. You can create your own generic function to test any drive letter.


function DiskInDrive(Drive: Char): Boolean;
var
  ErrorMode: word;
begin
  Drive: = UpCase(Drive);
  if not (Drive in ['A'..'Z']) then
    raise EConvertError.Create('Not a valid drive ID');
  ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
  try
    if DiskSize(Ord(Drive) - $40) = -1 then
      DiskInDrive := False
    else
      DiskInDrive := True;
  finally
    SetErrorMode(ErrorMode);
  end;
end;


Your function forces the passed drive letter to uppercase and assures it is a valid drive. Then you turn off the system error reporting and perform a disk operation. Your function will return True indicating the disk is present or False if there was an error. The last bit of housekeeping is to turn on the system error reporting.

Base64 (MIME) Encode and Decode

Problem/Question/Abstract:

This article gives you two routines allowing for fast encoding and decoding in and out of the MIME format.

Answer:

I have written the following unit to replace the INDY TIdEncoderMIME and TIdDecoderMIME components. This "Codec" is used in Email-Software, primarely.

First reason was the lack of speed of these components. Second reason was, that they are components and therefore require the VCL - an heavy extra load on otherwise nonVCL systems.

Both routines are written in Assembler and overloaded by different versions allowing for easy access.

I am sure, some of your are able to increase the speed even some more. Please let me know. Thanks.

I have introduced a compiler switch to switch between a fast decoding mode and a more secure decoding mode. It is up to you, which you like to use. I recomend using the more secure mode, especially if the user is required to work with the encoded data.

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
* Unit Name : uBase64Codec
* Author    : Daniel Wischnewski
* Copyright : Copyright &copy; 2001-2003 by gate(n)etwork GmbH. All Rights Reserved.
* Creator   : Daniel Wischnewski
* Contact   : Daniel Wischnewski (e-mail: delphi3000(at)wischnewski.tv);
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

//                               * * * License * * *
//
// The contents of this file are used with permission, subject to the Mozilla
// Public License Version 1.1 (the "License"); you may not use this file except
// in compliance with the License. You may obtain a copy of the License at
//
//                       http://www.mozilla.org/MPL/MPL-1.1.html
//
// Software distributed under the License is distributed on an "AS IS" basis,
// WITHOUT WARRANTY OF ANY KIND, either express or  implied. See the License for
// the specific language governing rights and limitations under the License.
//

//                               * * * My Wish * * *
//
// If you come to use this unit for your work, I would like to know about it.
// Drop me an e-mail and let me know how it worked out for you. If you wish, you
// can send me a copy of your work. No obligations!
// My e-mail address: delphi3000(at)wischnewski.tv
//

//                               * * * History * * *
//
// Version 1.0 (Oct-10 2002)
//    first published on Delphi-PRAXiS (www.delphipraxis.net)
//
// Version 1.1 (May-13 2003)
//    introduced a compiler switch (SpeedDecode) to switch between a faster
//    decoding variant (prior version) and a litte less fast, but secure variant
//    to work around bad formatted data (decoding only!)
//

unit Base64;

interface

// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
// !! THE COMPILER SWITCH MAY BE USED TO ADJUST THE BEHAVIOR !!
// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

// enable "SpeedDecode"
//     the switch to gain speed while decoding the message, however, the codec
//     will raise different exceptions/access violations or invalid output if
//     the incoming data is invalid or missized.

// disable "SpeedDecode"
//     the switch to enable a data check, that will scan the data to decode to
//     be valid. This method is to be used if you cannot guarantee to validity
//     of the data to be decoded.

{.DEFINE SpeedDecode}

{$IFNDEF SpeedDecode}
{$DEFINE ValidityCheck}
{$ENDIF}

uses SysUtils;

// codiert einen String in die zugeh�rige Base64-Darstellung
function Base64Encode(const InText: AnsiString): AnsiString; overload;
// decodiert die Base64-Darstellung eines Strings in den zugeh�rigen String
function Base64Decode(const InText: AnsiString): AnsiString; overload;

// bestimmt die Gr��e der Base64-Darstellung
function CalcEncodedSize(InSize: Cardinal): Cardinal;
// bestimmt die Gr��e der bin�ren Darstellung
function CalcDecodedSize(const InBuffer; InSize: Cardinal): Cardinal;

// codiert einen Buffer in die zugeh�rige Base64-Darstellung
procedure Base64Encode(const InBuffer; InSize: Cardinal; var OutBuffer); overload;
  register;
// decodiert die Base64-Darstellung in einen Buffer
{$IFDEF SpeedDecode}
procedure Base64Decode(const InBuffer; InSize: Cardinal; var OutBuffer); overload;
  register;
{$ENDIF}
{$IFDEF ValidityCheck}
function Base64Decode(const InBuffer; InSize: Cardinal; var OutBuffer): Boolean;
  overload; register;
{$ENDIF}

// codiert einen String in die zugeh�rige Base64-Darstellung
procedure Base64Encode(const InText: PAnsiChar; var OutText: PAnsiChar); overload;
// decodiert die Base64-Darstellung eines Strings in den zugeh�rigen String
procedure Base64Decode(const InText: PAnsiChar; var OutText: PAnsiChar); overload;

// codiert einen String in die zugeh�rige Base64-Darstellung
procedure Base64Encode(const InText: AnsiString; var OutText: AnsiString); overload;
// decodiert die Base64-Darstellung eines Strings in den zugeh�rigen String
procedure Base64Decode(const InText: AnsiString; var OutText: AnsiString); overload;

implementation

const
  cBase64Codec: array[0..63] of AnsiChar =
  'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  Base64Filler = '=';

function Base64Encode(const InText: string): string; overload;
begin
  Base64Encode(InText, Result);
end;

function Base64Decode(const InText: string): string; overload;
begin
  Base64Decode(InText, Result);
end;

function CalcEncodedSize(InSize: Cardinal): Cardinal;
begin
  // no buffers passed along, calculate outbuffer size needed
  Result := (InSize div 3) shl 2;
  if ((InSize mod 3) > 0) then
    Inc(Result, 4);
end;

function CalcDecodedSize(const InBuffer; InSize: Cardinal): Cardinal;
type
  BA = array of Byte;
begin
  Result := 0;
  if InSize = 0 then
    Exit;
  if InSize mod 4 <> 0 then
    Exit;
  Result := InSize div 4 * 3;
  if (BA(InBuffer)[InSize - 2] = Ord(Base64Filler)) then
    Dec(Result, 2)
  else if BA(InBuffer)[InSize - 1] = Ord(Base64Filler) then
    Dec(Result);
end;

procedure Base64Encode(const InBuffer; InSize: Cardinal; var OutBuffer
  ); register;
var
  ByThrees, LeftOver: Cardinal;
  // reset in- and outbytes positions
asm
  // load addresses for source and destination
  // PBYTE(InBuffer);
  mov  ESI, [EAX]
  // PBYTE(OutBuffer);
  mov  EDI, [ECX]
  // ByThrees := InSize div 3;
  // LeftOver := InSize mod 3;
  // load InSize (stored in EBX)
  mov  EAX, EBX
  // load 3
  mov  ECX, $03
  // clear upper 32 bits
  xor  EDX, EDX
  // divide by ECX
  div  ECX
  // save result
  mov  ByThrees, EAX
  // save remainder
  mov  LeftOver, EDX
  // load addresses
  lea  ECX, cBase64Codec[0]
  // while I < ByThrees do
  // begin
  xor  EAX, EAX
  xor  EBX, EBX
  xor  EDX, EDX
  cmp  ByThrees, 0
  jz   @@LeftOver
  @@LoopStart:
    // load the first two bytes of the source triplet
    LODSW
    // write Bits 0..5 to destination
    mov  BL, AL
    shr  BL, 2
    mov  DL, BYTE PTR [ECX + EBX]
    // save the Bits 12..15 for later use [1]
    mov  BH, AH
    and  BH, $0F
    // save Bits 6..11
    rol  AX, 4
    and  AX, $3F
    mov  DH, BYTE PTR [ECX + EAX]
    mov  AX, DX
    // store the first two bytes of the destination quadruple
    STOSW
    // laod last byte (Bits 16..23) of the source triplet
    LODSB
    // extend bits 12..15 [1] with Bits 16..17 and save them
    mov  BL, AL
    shr  BX, 6
    mov  DL, BYTE PTR [ECX + EBX]
    // save bits 18..23
    and  AL, $3F
    xor  AH, AH
    mov  DH, BYTE PTR [ECX + EAX]
    mov  AX, DX
    // store the last two bytes of the destination quadruple
    STOSW
    dec  ByThrees
  jnz  @@LoopStart
  @@LeftOver:
  // there are up to two more bytes to encode
  cmp  LeftOver, 0
  jz   @@Done
  // clear result
  xor  EAX, EAX
  xor  EBX, EBX
  xor  EDX, EDX
  // get left over 1
  LODSB
  // load the first six bits
  shl  AX, 6
  mov  BL, AH
  // save them
  mov  DL, BYTE PTR [ECX + EBX]
  // another byte ?
  dec  LeftOver
  jz   @@SaveOne
  // save remaining two bits
  shl  AX, 2
  and  AH, $03
  // get left over 2
  LODSB
  // load next 4 bits
  shl  AX, 4
  mov  BL, AH
  // save all 6 bits
  mov  DH, BYTE PTR [ECX + EBX]
  shl  EDX, 16
  // save last 4 bits
  shr  AL, 2
  mov  BL, AL
  // save them
  mov  DL, BYTE PTR [ECX + EBX]
  // load base 64 'no more data flag'
  mov  DH, Base64Filler
  jmp  @@WriteLast4
  @@SaveOne:
  // adjust the last two bits
  shr  AL, 2
  mov  BL, AL
  // save them
  mov  DH, BYTE PTR [ECX + EBX]
  shl  EDX, 16
  // load base 64 'no more data flags'
  mov  DH, Base64Filler
  mov  DL, Base64Filler
  // ignore jump, as jump reference is next line !
  // jmp  @@WriteLast4
  @@WriteLast4:
    // load and adjust result
    mov  EAX, EDX
    ror EAX, 16
    // save it to destination
    STOSD
  @@Done:
end;

{$IFDEF SpeedDecode}

procedure Base64Decode(const InBuffer; InSize: Cardinal; var OutBuffer);
  overload; register;
{$ENDIF}
{$IFDEF ValidityCheck}
  function Base64Decode(const InBuffer; InSize: Cardinal; var OutBuffer):
      Boolean; overload; register;
  {$ENDIF}
  const
  {$IFDEF SpeedDecode}
    cBase64Codec: array[0..127] of Byte =
  {$ENDIF}
  {$IFDEF ValidityCheck}
    cBase64Codec: array[0..255] of Byte =
  {$ENDIF}
    (
      $FF, $FF, $FF, $FF, $FF, {005>} $FF, $FF, $FF, $FF, $FF, // 000..009
      $FF, $FF, $FF, $FF, $FF, {015>} $FF, $FF, $FF, $FF, $FF, // 010..019
      $FF, $FF, $FF, $FF, $FF, {025>} $FF, $FF, $FF, $FF, $FF, // 020..029
      $FF, $FF, $FF, $FF, $FF, {035>} $FF, $FF, $FF, $FF, $FF, // 030..039
      $FF, $FF, $FF, $3E, $FF, {045>} $FF, $FF, $3F, $34, $35, // 040..049
      $36, $37, $38, $39, $3A, {055>} $3B, $3C, $3D, $FF, $FF, // 050..059
      $FF, $FF, $FF, $FF, $FF, {065>} $00, $01, $02, $03, $04, // 060..069
      $05, $06, $07, $08, $09, {075>} $0A, $0B, $0C, $0D, $0E, // 070..079
      $0F, $10, $11, $12, $13, {085>} $14, $15, $16, $17, $18, // 080..089
      $19, $FF, $FF, $FF, $FF, {095>} $FF, $FF, $1A, $1B, $1C, // 090..099
      $1D, $1E, $1F, $20, $21, {105>} $22, $23, $24, $25, $26, // 100..109
      $27, $28, $29, $2A, $2B, {115>} $2C, $2D, $2E, $2F, $30, // 110..119
      $31, $32, $33, $FF, $FF, {125>} $FF, $FF, $FF // 120..127

  {$IFDEF ValidityCheck}
      {125>}, $FF, $FF, // 128..129
      $FF, $FF, $FF, $FF, $FF, {135>} $FF, $FF, $FF, $FF, $FF, // 130..139
      $FF, $FF, $FF, $FF, $FF, {145>} $FF, $FF, $FF, $FF, $FF, // 140..149
      $FF, $FF, $FF, $FF, $FF, {155>} $FF, $FF, $FF, $FF, $FF, // 150..159
      $FF, $FF, $FF, $FF, $FF, {165>} $FF, $FF, $FF, $FF, $FF, // 160..169
      $FF, $FF, $FF, $FF, $FF, {175>} $FF, $FF, $FF, $FF, $FF, // 170..179
      $FF, $FF, $FF, $FF, $FF, {185>} $FF, $FF, $FF, $FF, $FF, // 180..189
      $FF, $FF, $FF, $FF, $FF, {195>} $FF, $FF, $FF, $FF, $FF, // 190..199
      $FF, $FF, $FF, $FF, $FF, {205>} $FF, $FF, $FF, $FF, $FF, // 200..209
      $FF, $FF, $FF, $FF, $FF, {215>} $FF, $FF, $FF, $FF, $FF, // 210..219
      $FF, $FF, $FF, $FF, $FF, {225>} $FF, $FF, $FF, $FF, $FF, // 220..229
      $FF, $FF, $FF, $FF, $FF, {235>} $FF, $FF, $FF, $FF, $FF, // 230..239
      $FF, $FF, $FF, $FF, $FF, {245>} $FF, $FF, $FF, $FF, $FF, // 240..249
      $FF, $FF, $FF, $FF, $FF, {255>} $FF // 250..255
  {$ENDIF}
      );
  asm
  push EBX
  mov  ESI, [EAX]
  mov  EDI, [ECX]
  {$IFDEF ValidityCheck}
    mov  EAX, InSize
    and  EAX, $03
    cmp  EAX, $00
    jz   @@DecodeStart
    jmp  @@ErrorDone
    @@DecodeStart:
  {$ENDIF}
  mov  EAX, InSize
  shr  EAX, 2
  jz   @@Done
  lea  ECX, cBase64Codec[0]
  xor  EBX, EBX
  dec  EAX
  jz   @@LeftOver
  push EBP
  mov  EBP, EAX
  @@LoopStart:
    // load four bytes into EAX
    LODSD
    // save them to EDX as AX is used to store results
    mov  EDX, EAX
    // get bits 0..5
    mov  BL, DL
    // decode
    mov  AH, BYTE PTR [ECX + EBX]
    {$IFDEF ValidityCheck}
      // check valid code
      cmp  AH, $FF
      jz   @@ErrorDoneAndPopEBP
    {$ENDIF}
    // get bits 6..11
    mov  BL, DH
    // decode
    mov  AL, BYTE PTR [ECX + EBX]
    {$IFDEF ValidityCheck}
      // check valid code
      cmp  AL, $FF
      jz   @@ErrorDoneAndPopEBP
    {$ENDIF}
    // align last 6 bits
    shl  AL, 2
    // get first 8 bits
    ror  AX, 6
    // store first byte
    STOSB
    // align remaining 4 bits
    shr  AX, 12
    // get next two bytes from source quad
    shr  EDX, 16
    // load bits 12..17
    mov  BL, DL
    // decode
    mov  AH, BYTE PTR [ECX + EBX]
    {$IFDEF ValidityCheck}
      // check valid code
      cmp  AH, $FF
      jz   @@ErrorDoneAndPopEBP
    {$ENDIF}
    // align ...
    shl  AH, 2
    // ... and adjust
    rol  AX, 4
    // get last bits 18..23
    mov  BL, DH
    // decord
    mov  BL, BYTE PTR [ECX + EBX]
    {$IFDEF ValidityCheck}
      // check valid code
      cmp  BL, $FF
      jz   @@ErrorDoneAndPopEBP
    {$ENDIF}
    // enter in destination word
    or   AH, BL
    // and store to destination
    STOSW
    // more coming ?
    dec  EBP
  jnz  @@LoopStart
  pop  EBP
  // no
  // last four bytes are handled separately, as special checking is needed
  // on the last two bytes (may be end of data signals '=' or '==')
  @@LeftOver:
  // get the last four bytes
  LODSD
  // save them to EDX as AX is used to store results
  mov  EDX, EAX
  // get bits 0..5
  mov  BL, DL
  // decode
  mov  AH, BYTE PTR [ECX + EBX]
  {$IFDEF ValidityCheck}
    // check valid code
    cmp  AH, $FF
    jz   @@ErrorDone
  {$ENDIF}
  // get bits 6..11
  mov  BL, DH
  // decode
  mov  AL, BYTE PTR [ECX + EBX]
  {$IFDEF ValidityCheck}
    // check valid code
    cmp  AL, $FF
    jz   @@ErrorDone
  {$ENDIF}
  // align last 6 bits
  shl  AL, 2
  // get first 8 bits
  ror  AX, 6
  // store first byte
  STOSB
  // get next two bytes from source quad
  shr  EDX, 16
  // check DL for "end of data signal"
  cmp  DL, Base64Filler
  jz   @@SuccessDone
  // align remaining 4 bits
  shr  AX, 12
  // load bits 12..17
  mov  BL, DL
  // decode
  mov  AH, BYTE PTR [ECX + EBX]
  {$IFDEF ValidityCheck}
    // check valid code
    cmp  AH, $FF
    jz   @@ErrorDone
  {$ENDIF}
  // align ...
  shl  AH, 2
  // ... and adjust
  rol  AX, 4
  // store second byte
  STOSB
  // check DH for "end of data signal"
  cmp  DH, Base64Filler
  jz   @@SuccessDone
  // get last bits 18..23
  mov  BL, DH
  // decord
  mov  BL, BYTE PTR [ECX + EBX]
  {$IFDEF ValidityCheck}
    // check valid code
    cmp  BL, $FF
    jz   @@ErrorDone
  {$ENDIF}
  // enter in destination word
  or   AH, BL
  // AH - AL for saving last byte
  mov  AL, AH
  // store third byte
  STOSB
  @@SuccessDone:
  {$IFDEF ValidityCheck}
    mov  Result, $01
    jmp  @@Done
    @@ErrorDoneAndPopEBP:
    pop  EBP
    @@ErrorDone:
    mov  Result, $00
  {$ENDIF}
  @@Done:
  pop  EBX
  end;

  procedure Base64Encode(const InText: PAnsiChar; var OutText: PAnsiChar);
  var
    InSize, OutSize: Cardinal;
  begin
    // get size of source
    InSize := Length(InText);
    // calculate size for destination
    OutSize := CalcEncodedSize(InSize);
    // reserve memory
    OutText := StrAlloc(Succ(OutSize));
    OutText[OutSize] := #0;
    // encode !
    Base64Encode(InText, InSize, OutText);
  end;

  procedure Base64Encode(const InText: AnsiString; var OutText: AnsiString);
    overload;
  var
    InSize, OutSize: Cardinal;
    PIn, POut: Pointer;
  begin
    // get size of source
    InSize := Length(InText);
    // calculate size for destination
    OutSize := CalcEncodedSize(InSize);
    // prepare string length to fit result data
    SetLength(OutText, OutSize);
    PIn := @InText[1];
    POut := @OutText[1];
    // encode !
    Base64Encode(PIn, InSize, POut);
  end;

  procedure Base64Decode(const InText: PAnsiChar; var OutText: PAnsiChar);
    overload;
  var
    InSize, OutSize: Cardinal;
  begin
    // get size of source
    InSize := Length(InText);
    // calculate size for destination
    OutSize := CalcDecodedSize(InText, InSize);
    // reserve memory
    OutText := StrAlloc(Succ(OutSize));
    OutText[OutSize] := #0;
    // encode !
{$IFDEF SpeedDecode}
    Base64Decode(InText, InSize, OutText);
{$ENDIF}
{$IFDEF ValidityCheck}
    if not Base64Decode(InText, InSize, OutText) then
      OutText[0] := #0;
{$ENDIF}
  end;

  procedure Base64Decode(const InText: AnsiString; var OutText: AnsiString);
    overload;
  var
    InSize, OutSize: Cardinal;
    PIn, POut: Pointer;
  begin
    // get size of source
    InSize := Length(InText);
    // calculate size for destination
    PIn := @InText[1];
    OutSize := CalcDecodedSize(PIn, InSize);
    // prepare string length to fit result data
    SetLength(OutText, OutSize);
    FillChar(OutText[1], OutSize, '.');
    POut := @OutText[1];
    // encode !
{$IFDEF SpeedDecode}
    Base64Decode(PIn, InSize, POut);
{$ENDIF}
{$IFDEF ValidityCheck}
    if not Base64Decode(PIn, InSize, POut) then
      SetLength(OutText, 0);
{$ENDIF}
  end;

end.

Check for a duplicate key index programmatically

Problem/Question/Abstract:

I have a DBISAM 2.04 table with several indexes. It actually lists project details. One field is the ProjectNo (a text field some 20 char wide). I want to make sure that the same PropjectNo is not entered twice. I could make the index unique, and that would no doubt work. But the error message returned in not very user friendly - I would rather trap it myself. I assume that in the OnBeforEInsert event I would have some code that checks to see if this index key already exists. If so, then I warn the user (perhaps even allowing the record to be saved if the user insists). And then aborting the save if a duplicate. How do I find an existing key, i.e. something like KeyExists(['99023']) ? Would I have to do a Locate or something?

Answer:

Make a generic function like:

function TMyForm.CheckDuplicateKey(ATable: string; const Field: TField): Boolean;
var
  cSQL, KeyField, cValue: string;
begin
  KeyField := Field.FieldName;
  cValue := Field.AsString;
  cSQL := Format('select %s from %s where %s = %s', [KeyField, ATable, KeyField,
    cValue]);
  with LookupQuery do
  begin
    SQL.Clear;
    SQL.Add(cSQL);
    Open;
    if RecordCount > 0 then
      Result := True
    else
      Result := False;
    Close;
  end;
end;

and use it in your key field's OnValidate handler like:

procedure TMyForm.MainQueryMyIDValidate(Sender: TField);
begin
  if CheckDuplicateKey('MyTable', Sender) then
    raise Exception.Create('The table already has a record with this key.');
end;

Retrieve the password of a protected access database

Problem/Question/Abstract:

The password of an access database can easily be retrieved using the function below

Answer:

I know there that there are many utilities out there costing $$ for removing the password of an access database. Here's how to implement it in Delphi.Please note that this method is not meant for a database with user-level security and work group information file. The idea is based on the file format of an access db.

The password is stored from location $42 and encrypted using simple xoring. The following function does decryption.

function GetPassword(filename: string): string;
var
  Stream: TFilestream;
  buffer: array[0..12] of char;
  str: string;
begin
  try
    stream := TFileStream.Create(filename, fmOpenRead);
  except
    ShowMessage('Could not open the file.Make sure that the file is not in use.');
    exit;
  end;
  stream.Seek($42, soFromBeginning);
  stream.Read(buffer, 13);
  stream.Destroy;

  str := chr(Ord(buffer[0]) xor $86);
  str := str + chr(Ord(buffer[1]) xor $FB);
  str := str + chr(Ord(buffer[2]) xor $EC);
  str := str + chr(Ord(buffer[3]) xor $37);
  str := str + chr(Ord(buffer[4]) xor $5D);
  str := str + chr(Ord(buffer[5]) xor $44);
  str := str + chr(Ord(buffer[6]) xor $9C);
  str := str + chr(Ord(buffer[7]) xor $FA);
  str := str + chr(Ord(buffer[8]) xor $C6);
  str := str + chr(Ord(buffer[9]) xor $5E);
  str := str + chr(Ord(buffer[10]) xor $28);
  str := str + chr(Ord(buffer[11]) xor $E6);
  str := str + chr(Ord(buffer[12]) xor $13);
  Result := str;
end;

Better way to display [error] messages

Problem/Question/Abstract:

Better way to display [error] messages

Answer:

If you display more than a few [error] messages in your application, using a simple method such as the following may not be the best approach:

Application.MessageBox('File not found', 'Error', mb_OK);

Above method of displaying errors will make it harder to modify actual messages since they are distributed all over your application source code. It may be better to have a "centralized" function that can display error messages, or better yet, a centralized function that can display replaceable error messages. Consider the following example:

type
  cnMessageIDs =
    (
    nMsgID_NoError,
    nMsgID_FileNotFound,
    nMsgID_OutOfMemory,
    nMsgID_ExitProgram
    // list your other error
    // IDs here...
    );

const
  csMessages_ShortVersion: array[Low(cnMessageIDs)..High(cnMessageIDs)] of PChar =
  (
    'No error',
    'File not found',
    'Out of memory',
    'Exit program?'
    // other error messages...
    );

  csMessages_DetailedVersion: array[Low(cnMessageIDs)..High(cnMessageIDs)]
  of PChar =
    (
    'No error; please ignore!',

    'File c:\config.sys not found.' +
    'Contact your sys. admin.',

    'Out of memory. You need ' +
    'at least 4M for this function',

    'Exit program? ' +
    'Save your data first!'
    // other error messages...
    );

procedure MsgDisplay(
  cnMessageID: cnMessageIDs);
begin
  // set this to False to display
  // short version of the messages
  if (True) then
    Application.MessageBox(csMessages_DetailedVersion[cnMessageID], 'Error', mb_OK)
  else
    Application.MessageBox(csMessages_ShortVersion[cnMessageID], 'Error', mb_OK);
end;

Now, whenever you want to display an error message, you can call the MsgDisplay() function with the message ID rather than typing the message itself:

MsgDisplay(nMsgID_FileNotFound);

MsgDisplay() function will not only let you keep all your error messages in one place -- inside one unit for example, but it will also let you keep different sets of error messages -- novice/expert, debug/release, and even different sets for different languages.

Function to Populate a column of the DBGrid PickList so as to facilitate easy data entry in a grid

Problem/Question/Abstract:

A function to populate the DBGrid PickList to have auto selection of added field value when the grid is used to display a table

Answer:

The PickList of a DBGrid can be made useful for data entry through a dbgrid. This can be accomplished by the following function.Whenever a new entry is added to a particular field, that too can be made to appear in the picklist with the function given below.The PopulatePickList function can be called within DataSource.OnDataChange event so that it gets updated whenever a new entry is added.

procedure PopulatePickList(Column: TColumn; Table: TTable; FieldName: string);
var
  QryTemp: TQuery;
  i: integer;
begin
  Column.PickList.Clear;
  QryTemp := TQuery.Create(nil);
  with QryTemp do
  begin
    DatabaseName := Table.DatabaseName;
    SQL.Clear;
    SQL.Add('SELECT DISTINCT ' + FieldName + ' from ' + Table.TableName);
  end;

  with QryTemp do
  begin
    Active := True;
    First;
    for i := 0 to QryTemp.RecordCount - 1 do
    begin
      if FieldByName(FieldName).AsString <> '' then
        Column.PickList.Add(FieldByName(FieldName).AsString);
      Next;
    end;
    Active := False;
  end;
  QryTemp.Free;
end;

procedure TForm1.DataSourceDataChange(Sender: TObject; Field: TField);
begin
  PopulatePickList(DBGrid.Columns[2], Table, 'Field');
  //replace table with your tableName of the grid
  //DBGrid.Columns[2] with your DBGrid Column that you want the PickList for
  //Field with the field for the PickList
end;

Track the mouse position over a TPanel on a form

Problem/Question/Abstract:

I want to track the position of the mouse over a TPanel within the client area of my main form. Using WM_MOUSEMOVE, I can track the mouse position over the main form easily enough, but once the mouse moves over my panel, the tracking stops. What do I need to do to track the position of the mouse over the panel?

Answer:

This is happening because TPanel is a different window with a handle of its own. You need to intercept the WM_MOUSEMOVE message in the TPanels WindowProc procedure. Assuming the form is TForm1 and the panel is Panel1:

First declare the following in the forms class:

private
{ Private declarations }
OldPanelWndProc: TWndMethod;

procedure NewPanelWndProc(var Message: TMessage);

Finally, implement the relevant code. Note how you should always call the old WindowProc procedure after you've handled the message. Also, WindowProc should be restored to it's original procedure when the form (containing the panel) is hidden. It would be a bad idea to restore the WindowProc procedure in the forms OnDestroy event because if it (the form) is hidden and shown again, it's going to cause problems with WindowProc being reassigned when it shouldn't be.

procedure TForm1.FormShow(Sender: TObject);
begin
  OldPanelWndProc := Panel1.WindowProc;
  Panel1.WindowProc := NewPanelWndProc;
end;

procedure TForm1.FormHide(Sender: TObject);
begin
  Panel1.WindowProc := OldPanelWndProc;
end;

procedure TForm1.NewPanelWndProc(var Message: TMessage);
begin
  case Message.Msg of
    WM_MOUSEMOVE:
      Caption := 'x = ' + inttostr(Message.LParamLo) + ' y = ' +
                         inttostr(Message.LParamHi);
  end;
  OldPanelWndProc(Message);
end;

Managing a Single Instance of a Non-Modal Form

Problem/Question/Abstract:

How to manage the application's non-modal forms properly - to make sure that only one instance of a form is present at any given time, like it is done automatically for modal forms?

Answer:

When you have a modal form, you create, display and destroy it usually in a single uninterrupted sequence of code instructions, therefore it is easy to ensure that your form variable is equal to NIL after the form is expired, so you easily eliminate the risk of creating the same form twice or, even worse, attempting to access non-existing form when the only form's remains you actually have is the form variable with non-NIL value in it.

The problem with non-modal forms is that you usually create and display them in one place, then do whatever you want with your application (and not only that form), and order them to destroy themselves when they are no longer needed at any time - you cannot say beforehand where and when that will happen.
It is natural to close and free such a non-modal form from itself, but where to put clean-up instructions then? Without them, the application cannot know whether the form is alive - it relies merely on the form variable value (is it equal to NIL?) to determine if the form is still around. It is possible to introduce some application-level flags to keep track of the forms presence, but it is not an elegant solution.

Fortunately, as almost always with Delphi, there is a clear way to solve the problem.

Suppose you have frmNonModal as a form variable of TfrmNonModal class.

The procedure is simple:

   1. Add the following OnDestroy event handler to the form:

procedure TfrmNonModal.FormDestroy(Sender: TObject);
begin
  frmNonModal := nil;
  inherited;
end; {TfrmNonModal.FormDestroy}

Note that you cannot substitute frmNonModal with Self, though it seems to be the same from the first glance. The difference is that Self points to the object itself (and we don't want to nullify it prematurely), and frmNonModal is just an external (to the object) variable, which points to the object. By setting this variable to NIL we do not affect any internal functionality of the object, but rather just disconnect its link to the outer world. In our case this is exactly what we need, as we plan to check this variable when creating the form, as shown below.  

   2. Add the following OnClose event handler to the form:

procedure TfrmNonModal.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  inherited;
  Action := caFree;
end; {TfrmNonModal.FormClose}

This is needed to instruct our form to free itself when we close it. Note that by default Action is caHide, i.e. your form is just being closed (hidden), but not destroyed after calling TForm.Close.
  
   3. Bring your form to life as follows, for example in the menu item's OnClick event handler on your main form (of TfrmMain class):

procedure TfrmMain.itmNonModalFormClick(Sender: TObject);
begin
  if Assigned(frmNonModal) then
  begin
    {if the form already exists, just bring it to the front}
    frmNonModal.Show;
    frmNonModal.WindowState := wsNormal;
    frmNonModal.BringToFront;
  end
  else
  begin
    {create the form if it does not exist}
    frmNonModal := TfrmNonModal.Create(Application);
    try
      {display as non-modal form}
      frmNonModal.Show;
    except
      {clean up the form and form variable if unsuccessful}
      FreeAndNil(frmNonModal);
    end; {try}
  end; {if}
end; {TfrmMain.itmNonModalFormClick}

That's it. Now your application always knows whether your non-modal form is present (created), and manages to allow not more than a single instance of such form at a time.

How to resize open forms automatically when the Desktop size changes

Problem/Question/Abstract:

I have created a form which is snapped to the top of the screen. When I change the size of the Windows Desktop, the visible form isn't resized accordingly.

Answer:

I use the following code and it works quite good, even if the desktop size is changed:

type
  TForm1 = class(TForm)
  private
    procedure WMWindowPosChanging(var Message: TWMWindowPosMsg);
      message WM_WINDOWPOSCHANGING;

    { ... }

implementation

{ ... }

var
  WorkAreaRect: TRect;
  NewWorkAreaFlag: Boolean;

  { ... }

procedure TForm1.WMWindowPosChanging(var Message: TWMWindowPosMsg);
begin
  if (WindowState <> wsMaximized) then
  begin
    if (Message.WindowPos.Flags and SWP_NOMOVE) = 0 then
    begin {form is moved}
      if NewWorkAreaFlag then
      begin {workarea might have changed since last call}
        SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkAreaRect, 0);
      end;
      {snap form to border here, something
                        like Message.WindowPos.X := WorkAreaRect.Left if near to left border}
      { ... }
    end;
    NewWorkAreaFlag := ((Message.WindowPos.Flags and (SWP_NOMOVE or SWP_NOSIZE)) <>
      0);
    {True if form was (probably) dropped => get workarea again}
  end;
end;

{ ... }

initialization
  NewWorkAreaFlag := True;

Splitting a string in a string list

Problem/Question/Abstract:

A function that splits a string in parts separated by a substring and returns the parts in a StringList

Answer:

Solve 1:

The following functions split a string in parts separated by a substring and return the parts in a string list that may be passed as third parameter or created by the function (and in this latter case it must be freed by the caller):

interface

uses classes;

function SplitStrings(const str: string;
  const separator: string = ',';
  Strings: TStrings = nil): TStrings;
function AnsiSplitStrings(const str: string;
  const separator: string = ',';
  Strings: TStrings = nil): TStrings;

implementation

uses sysutils;

function SplitStrings(const str: string; const separator: string;
  Strings: TStrings): TStrings;
// Fills a string list with the parts of "str" separated by
// "separator". If Nil is passed instead of a string list,
// the function creates a TStringList object which has to
// be freed by the caller
var
  n: integer;
  p, q, s: PChar;
  item: string;
begin
  if Strings = nil then
    Result := TStringList.Create
  else
    Result := Strings;
  try
    p := PChar(str);
    s := PChar(separator);
    n := Length(separator);
    repeat
      q := StrPos(p, s);
      if q = nil then
        q := StrScan(p, #0);
      SetString(item, p, q - p);
      Result.Add(item);
      p := q + n;
    until q^ = #0;
  except
    item := '';
    if Strings = nil then
      Result.Free;
    raise;
  end;
end;

function AnsiSplitStrings(const str: string; const separator: string;
  Strings: TStrings): TStrings;
// Fills a string list with the parts of "str" separated by
// "separator". If Nil is passed instead of a string list,
// the function creates a TStringList object which has to
// be freed by the caller
// ANSI version
var
  n: integer;
  p, q, s: PChar;
  item: string;
begin
  if Strings = nil then
    Result := TStringList.Create
  else
    Result := Strings;
  try
    p := PChar(str);
    s := PChar(separator);
    n := Length(separator);
    repeat
      q := AnsiStrPos(p, s);
      if q = nil then
        q := AnsiStrScan(p, #0);
      SetString(item, p, q - p);
      Result.Add(item);
      p := q + n;
    until q^ = #0;
  except
    item := '';
    if Strings = nil then
      Result.Free;
    raise;
  end;
end;

Examples:

procedure TForm1.Button1Click(Sender: TObject);
begin
  SplitStrings(Edit1.Text, ', ', ListBox1.Items);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  Parts: TStrings;
begin
  Parts := nil;
  try
    Parts := SplitStrings(Edit1.Text, ', ');
    ShowMessage('First part is "' + Parts[0] + '"');
  finally
    Parts.Free;
  end;
end;

You can see an example using a dynamic array instead of a StringList in a separate article "Splitting a string in an dynamic array".


Solve 2:

Shorten way:

function SplitStrings(const str: string; const separator: string;
  Strings: TStrings): TStrings;
// Fills a string list with the parts of "str" separated by
// "separator". If Nil is passed instead of a string list,
// the function creates a TStringList object which has to
// be freed by the caller
begin
  if Strings = nil then
    Result := TStringList.Create
  else
    Result := Strings;

  //This replaces the separators in str with CRLF so as to fit the format  of a stringlist.
  Result.Text := StringReplace(str, separator, #13#10, [rfReplaceAll]);
end;

How to read the color of a pixel

Problem/Question/Abstract:

I need to determine if certain portions of my canvas are black. While this seemed easy enough at first, I'm at a roadblock trying to determine pixel color. As I usually do, I wrote a little test program and painted a certain area black. I tried the following code to read a pixel in that area:

if Canvas.Pixels[444, 399] = clBlack then
  MessageBeep(mb_ok);

I never get the beep. What am I doing wrong, and what would be the correct way to do this.

Answer:

Are you shure you hit the right pixel ? Try


canvas.pixels[444, 399] = clBlack
if canvas.pixels[444, 399] = clBlack then
  MessageBeep(mb_ok);


Windows converts colors (at least if you are using less than 24 bit screen mode). But black should exists on all palettes, I think. The color value of a pixel will be a DWORD (32 bit), encoded like this:

$XXRRGGBB

where XX are return values (as far as I remember, it even tells you , if it had to convert a color here). So you could try something like

(color and $FFFFFF) = clBlack

to get the return value out or

= $000000

to be sure it not depends on clBlack .

If that doesn't work, let it write the pixel color to screen an compare to value of clBlack. If worst case , get R,G and B and check if (near to ) 0.

Disable a form movement

Problem/Question/Abstract:

How can I disable the any form movement?

Answer:

Always I saw a question: how can I move a window by hit in any part of form?
But I never saw a reverse question: how to disable a movement.

type
  TyourForm = class(TForm)
  private
    { Private declarations }
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  end;

procedure TyourForm.WMNCHitTest(var Message: TWMNCHitTest);
begin
  inherited;

  with Message do
    if Result = HTCAPTION then
      Result := HTNOWHERE;
end;

Retrieve just 1 row from a table (SQL)

Problem/Question/Abstract:

How do i retrive just 1 row from a sql table

Answer:

found this nice sql-tip for ya::

you have 2 options:

- use TOP function in sql

-----start
SELECT TOP 1 * FROM myTable
-----end

- by setting the rowcount before selecting in sql

-----start
SET ROWCOUNT 1
SELECT * FROM myTable
-----end

Note: If you use SET ROWCOUNT and you have a batch of commands, make sure you SET ROWCOUNT immediately before the SELECT statement. If you SET ROWCOUNT before an UPDATE or DELETE it will limit the number of rows affected by those operations.

How to switch focus to an existing instance of an application

Problem/Question/Abstract:

How can I switch focus to an existing instance of an application instead of creating a new instance (HPrevInst)?

Answer:

{usual stuff at the top of the project source file}

var
  hwnd: Word;
begin
  if hPrevInst = 0 then
  begin
    Application.CreateForm(TForm1, Form1);
    Application.Run;
  end
  else
  begin
    hwnd := FindWindow('TForm1', nil);
    if (not IsWindowVisible(hwnd)) then
    begin
      ShowWindow(hwnd, sw_ShowNormal);
      PostMessage(hwnd, wm_User, 0, 0);
    end
    else
      SetWindowPos(hwnd, HWND_TOP, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE);
  end;
end.

in the form's PAS file add a message response function for the wm_User message.

{in the form declaration}
public

procedure WMUser(var msg: TMessage); message wm_User;

{in the implementation section}

procedure TForm1.WMUser(var msg: TMessage);
begin
  Application.Restore;
end;

Streaming COM Objects as XML

Problem/Question/Abstract:

Streaming COM Objects as XML

Answer:

Introduction

When I was making my first COM objects I used to think that I could give my COM classes the same shape of regular Delphi ones. I am specifically talking about properties and a "stateful life-style" in which you keep using its methods similarily to what you'd do with a DataSet (i.e. Open, Next, Next, Close). Well yes, COM allows you to do that and if the objects lives on the client's computer everything works fast and efficiently. The problem araises if and when you move your object to another machine. In that situation then your application suddenly starts to slow down and your client becomes dependent on the network condition. Each time you access a property you are invoking a method that executes on another machine. If your code makes such calls continuosly you will be in big trouble. The ideal solution would be to redesign such objects making them "stateless". With "stateless object" I mean those whose methods do all they say they will do (i.e. ExecuteMoneyTransfer) and don't depend on other methods (i.e. ExecuteMoneyTransfer doesn't expect a Commit or Rollback method to be called by the client after it is completion). But often the amount of legacy code makes a resedign not practical. Is it possible then to do anything to improve performance and makes stateful objects stateless? As you would expect it is possible (no point in writing this article otherwise ;-) ). By persisting the object's state in some kind of intermediary format (I choose XML) and streaming it in one shot you can achieve the goal. Remember that this is not an optimal solution and the code I am presenting here is not optimized either. If you are starting from scratch you should design stateless objects.

TlbInf32.dll

Included in Visual Studio 6 and Visual Basic 6.0 CDs you can find a very handy DLL called TlbInf32. You can download the documentation for this file on the MSDN webside. If you don't have Visual Studio you can download the DLL from the website Compiled.org

TlbInf32 includes a set of classes that can help you reading type information for both type libaries and COM objects. Now, download my example by clicking here.

The code

The example is very straightforward. I won't spend too much time on it. There's a simple COM library with an object which implements the following interface:

ISimpleObject = interface(IDispatch)
  function Name: WideString[propget, dispid $00000001]; safecall;
  procedure Name(Value: WideString)[propput, dispid $00000001]; safecall;
  function Age: Integer[propget, dispid $00000002]; safecall;
  procedure Age(Value: Integer)[propput, dispid $00000002]; safecall;
end;

Then there's a client application that is able to persist and restore the state of it by using an auxiliary class called TTypeInfoStreamer which is defined as:

TTypeInfoStreamer = class
private
  fTLI: _TLIApplication;
public
  constructor Create;

  function GetObjectAsXML(const anObject: IDispatch): widestring;
  procedure SetObjectAsXML(const anObject: IDispatch; aString: widestring);
end;

The two methods GetObjectAsXML and SetObjectAsXMl are what interest us. Please, don't make an example of the code. I put this sample togheter in 10 minutes to answer a question of a guy in a newsgroup. Take a look at the lines I highlighted:

function TTypeInfoStreamer.GetObjectAsXML(const anObject: IDispatch): widestring;
var
  xml: DOMDocument30;
  intfinfo: InterfaceInfo;
  root,
    node: IXMLDOMNode;
  i: integer;
  val: OleVariant;
  p: PSafeArray;
begin
  p := MakeEmptyParmsArray;

  try
    intfinfo := fTLI.InterfaceInfoFromObject(anObject);

    xml := CoDOMDocument30.Create;
    xml.async := FALSE;

    root := xml.createNode('element', intfinfo.Get_Name, '');
    xml.appendChild(root);

    with intfinfo do
      for i := 1 to (Members.Count) do
      begin
        if not (Members[i].InvokeKind = INVOKE_PROPERTYGET) then
          Continue;

        val := fTLI.InvokeHook(anObject, Members[i].Get_MemberId, INVOKE_PROPERTYGET,
          p);

        node := xml.createNode('element', Members[i].Name, '');
        node.text := VarToStr(val);
        root.appendChild(node);
      end;

  finally
    result := root.xml;
    SafeArrayDestroy(p);
  end;
end;

As you can see we created an instance of the TLIApplication object (included in TlbInf32.dll), passed a pointer to the object we want to stream and then looped tough its Members collections. The members collection is the list of methods implemented by the object. What we want to read is the value of the object's properties so we will only stop on the methods that return the value of a property (Members[i].InvokeKind=INVOKE_PROPERTYGET) . In order to invoke the method we need to call the method TLIApplication.InvokeHook which is defined as:

function InvokeHook(const Object_: IDispatch; ID: OleVariant; InvokeKind: InvokeKinds;
  var ReverseArgList: PSafeArray): OleVariant; safecall;

It's interesting to note how the ID parameter could be either the name of the method or its DispID. So, in case you have the DispID already, you wouldn't need to use late bound calls (which first invoke the IDispatch.GetIDOfNames method slowing things down a *lot*). InvokeKind tells the TLIApplication *how* to invoke it and finally the ReverseArgList is a safe array that in our case only contains no values. See the rest of the code to find out how I build one. The result is something like this:

<ISimpleObject>
  <Name>Alessandro Federici</Name>
  <Age>25</Age>
</ISimpleObject>

Et voila'! We have our COM object persisted into XML! Now we need to set back these values. See the code below.

procedure TTypeInfoStreamer.SetObjectAsXML(const anObject: IDispatch;
  aString: widestring);
var
  xml: DOMDocument30;
  intfinfo: InterfaceInfo;
  root,
    node: IXMLDOMNode;
  i: integer;
  val: OleVariant;
  p: PSafeArray;
  s: string;
begin
  p := MakeOneElementArray;

  try
    intfinfo := fTLI.InterfaceInfoFromObject(anObject);

    xml := CoDOMDocument30.Create;
    xml.async := FALSE;
    xml.loadXML(aString);
    root := xml.documentElement;

    with root do
      for i := 0 to (childNodes.length - 1) do
      begin
        s := childNodes[i].nodeName;
        SetOneElementArray(p, childNodes[i].Text);
        fTLI.InvokeHook(anObject, s, INVOKE_PROPERTYPUT, p);
      end;

  finally
    SafeArrayDestroy(p);
  end;
end;

As you can see we did the exact opposite of what the had done before except that in this case we invoked the method as a property writer. I hope this will demistify a little how to read COM type information and stream its contents in an arbitraty format. The TTypeInfoStreamer class is far from being a complete class but feel free to use the code as a start. Happy coding!