Adapting DateTime values for different SQL-Server formats

Problem/Question/Abstract:

How can I adapt DateTime values for different SQL-Server formats?

Answer:

// Torry's Delphi Tips
// Author Sven Sohnel
// Listed 27.10.2002

{
Wenn man mit verschiedensprachigen (MS-)SQL-Servern arbeitet,
hat man ab und an das Problem, Datumswerte in ein f�r den
jeweiligen Server verst�ndliches Format umzuwandeln.
}

{
If you work with different (MS-)SQL-Server, you have sometimes the
problem what the date value is in the correct format.
}

function TForm1.GetSQLDateTimeFormat(UDL: string): string;
begin
Screen.Cursor := crSQLWait;
if ADOConnection1.Connected then
ADOConnection1.Close;
ADOConnection1.ConnectionString := 'FILE NAME=' + UDL;
ADOQuery1.SQL.Clear;
ADOQuery1.SQL.Add('sp_helplanguage @@LANGUAGE');
Application.ProcessMessages;
try
try
ADOQuery1.Open;
except
on E: Exception do
MessageBox(Handle,
PChar('Die Abfrage konnte nicht ge�ffnet werden:' + #13#10 + #13#10 +
E.Message),
PChar('Fehler!'), 16);
end;
if (ADOQuery1.Active) and (ADOQuery1.RecordCount > 0) then
Result := ADOQuery1.FieldByName('dateformat').AsString;
finally
Screen.Cursor := crDefault;
end;
end;

function DateTimeToSQLDateTimeString(Data: TDateTime; Format: string;
OnlyDate: Boolean = True): string;
var
y, m, d, h, mm, s, ms: Word;
begin
DecodeDate(Data, y, m, d);
DecodeTime(Data, h, mm, s, ms);
if Format = 'dmy' then
Result := IntToStr(d) + '-' + IntToStr(m) + '-' + IntToStr(y)
else if Format = 'ymd' then
Result := IntToStr(y) + '-' + IntToStr(m) + '-' + IntToStr(d)
else if Format = 'ydm' then
Result := IntToStr(y) + '-' + IntToStr(d) + '-' + IntToStr(m)
else if Format = 'myd' then
Result := IntToStr(m) + '-' + IntToStr(y) + '-' + IntToStr(d)
else if Format = 'dym' then
Result := IntToStr(d) + '-' + IntToStr(y) + '-' + IntToStr(m)
else
Result := IntToStr(m) + '-' + IntToStr(d) + '-' + IntToStr(y); //mdy: ; //US
if not OnlyDate then
Result := Result + ' ' + IntToStr(h) + ':' + IntToStr(mm) + ':' + IntToStr(s);
end;

//Example:
//Beispiel:

procedure ConvertSQLDateTime;
begin
ShowMessage(DateTimeToSQLDateTimeString(now, GetSQLLanguage('C:\DBEngl.udl')));
end;

Patch binary files

Problem/Question/Abstract:

How to patch binary files?

Answer:

Replaces a string in a file with new string.

procedure TForm1.Button1Click(Sender: TObject);
var
f: file;
l: Longint;
FileName, oldstring, newstring, s: string;
begin
oldstring := 'old string';
newstring := 'new string';
FileName := 'c:\YourFileName.xyz';

s := oldstring;
AssignFile(f, FileName);
Reset(f, 1);
for l := 0 to FileSize(f) - Length(oldstring) - 1 do
begin
Application.ProcessMessages;
Seek(f, l);
BlockRead(f, oldstring[1], Length(oldstring));
if oldstring = s then
begin
Seek(f, l);
BlockWrite(f, newstring[1], Length(newstring));
ShowMessage('String successfully replaced!');
end;
Application.ProcessMessages;
end;
CloseFile(f);
end;

Put the monitor into standby mode

Problem/Question/Abstract:

How to put the monitor into standby mode

Answer:

To put the screen into standby mode, use the SendMessage command to send a system command to the API. Send it the appplication handle, message type and the message values. Here we send SC_MonitorPower command type with the value of 1 to turn on screen standy mode. PostMessage can be used with the same parameters. The only difference is that the message is put into a queue. SendMessage causes direct action.

SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 1);

To manually turn the screen back on, send the same command but with the value of -1. Otherwise standby mode will be turned off by the usual actions associated with screen revival.

SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1);

How can I read a BlobStream with TADOQuery from an AccessDB?

Problem/Question/Abstract:

How can I read a BlobStream with TADOQuery from an AccessDB?

Answer:

// Torry's Delphi Tips - Database
// Author Peppa
// Listed 14.05.2003

function GetBlobStream(Query: TADOQuery): TMemoryStream;
begin
result := TMemoryStream.Create;

// You must connect to AccessDB first.
// See: Query.Connection, TADOConection or Query.ConnectString

// Send SQL command
Query.Active := False;
Query.SQL.Clear;
// data is my row and email the table
Query.SQL.Append('SELECT data FROM email WHERE id=1');
Query.Active := True;

Result.LoadFromStream(Query.CreateBlobStream(Query.FieldByName('Data'), bmRead));
end;

Using the Math Unit

Problem/Question/Abstract:

I've heard of the Math unit that's included with the Developer level version of Delphi. How do I use it?

Answer:

An Unsung Hero?

If you haven't heard of the Math unit, you're not alone. It's one of those units that's kind of buried in the myriad directories under the Delphi directory. Also, it's only included in the Delphi 2.0 Developer version and above. For those of you who have Delphi 2.0 Developer, you can find the source code file in the \\Borland\Delphi 2.0\Source\RTL\SYS directory.

This unit is one of those things I've heard a lot of people mention in the past but unfortunately, I haven't seen many examples of using it. I'm not sure whether it's because developers don't use it much or don't know about it. In any case, it's a shame because what the Math unit has to offer could be helpful to people needing to use mathematical functions in their code.

Not only are they helpful by their mere existence, but several of the member functions are written in Assembly language that is optimized for the Pentium FPU, so they're incredibly fast and efficient. For example, the procedure SinCos, which is one of the procedures written in Assembly, will produce the Sin and Cos simultaneously of an any angle faster than if you called the Sin and Cos functions individually. I've seen it at work and it's amazing.

The Math unit includes several categories of mathematical functions you can incorporate into your code. These include:

Trigonometric, Hyperbolic and Angle Conversion Functions
Logorithmic Functions
Exponential Functions
Some Miscellaneous Computing Functions
Several Statistical Functions
The Standard Set of Quattro Pro Financial Functions

Mind you, not all of the functions are coded in Assembly, but the mere fact that they've already been written means you don't have to, so that's a real time saver. Below are the function prototypes for the unit, so you can see what's in the file:

{-----------------------------------------------------------------------
Copyright (c) Borland International.

Most of the following trig and log routines map directly to Intel 80387 FPU
floating point machine instructions.  Input domains, output ranges, and
error handling are determined largely by the FPU hardware.
Routines coded in assembler favor the Pentium FPU pipeline architecture.
-----------------------------------------------------------------------}

{ Trigonometric functions }
function ArcCos(X: Extended): Extended;  { IN: |X| <= 1  OUT: [0..PI] radians }
function ArcSin(X: Extended): Extended;  { IN: |X| <= 1  OUT: [-PI/2..PI/2] radians }

{ ArcTan2 calculates ArcTan(Y/X), and returns an angle in the correct quadrant.
  IN: |Y| < 2^64, |X| < 2^64, X <> 0   OUT: [-PI..PI] radians }
function ArcTan2(Y, X: Extended): Extended;

{ SinCos is 2x faster than calling Sin and Cos separately for the same angle }
procedure SinCos(Theta: Extended; var Sin, Cos: Extended) register;
function Tan(X: Extended): Extended;
function Cotan(X: Extended): Extended;           { 1 / tan(X), X <> 0 }
function Hypot(X, Y: Extended): Extended;        { Sqrt(X**2 + Y**2) }

{ Angle unit conversion routines }
function DegToRad(Degrees: Extended): Extended;  { Radians := Degrees * PI / 180}
function RadToDeg(Radians: Extended): Extended;  { Degrees := Radians * 180 / PI }
function GradToRad(Grads: Extended): Extended;   { Radians := Grads * PI / 200 }
function RadToGrad(Radians: Extended): Extended; { Grads := Radians * 200 / PI }
function CycleToRad(Cycles: Extended): Extended; { Radians := Cycles * 2PI }
function RadToCycle(Radians: Extended): Extended;{ Cycles := Radians / 2PI }

{ Hyperbolic functions and inverses }
function Cosh(X: Extended): Extended;
function Sinh(X: Extended): Extended;
function Tanh(X: Extended): Extended;
function ArcCosh(X: Extended): Extended;   { IN: X >= 1 }
function ArcSinh(X: Extended): Extended;
function ArcTanh(X: Extended): Extended;   { IN: |X| <= 1 }

{ Logorithmic functions }
function LnXP1(X: Extended): Extended;   { Ln(X + 1), accurate for X near zero }
function Log10(X: Extended): Extended;                     { Log base 10 of X}
function Log2(X: Extended): Extended;                      { Log base 2 of X }
function LogN(Base, X: Extended): Extended;                { Log base N of X }

{ Exponential functions }

{ IntPower: Raise base to an integral power.  Fast. }
function IntPower(Base: Extended; Exponent: Integer): Extended register;

{ Power: Raise base to any power.
  For fractional exponents, or exponents > MaxInt, base must be > 0. }
function Power(Base, Exponent: Extended): Extended;


{ Miscellaneous Routines }

{ Frexp:  Separates the mantissa and exponent of X. }
procedure Frexp(X: Extended; var Mantissa: Extended; var Exponent: Integer) register;

{ Ldexp: returns X*2**P }
function Ldexp(X: Extended; P: Integer): Extended register;

{ Ceil: Smallest integer >= X, |X| < MaxInt }
function Ceil(X: Extended):Integer;

{ Floor: Largest integer <= X,  |X| < MaxInt }
function Floor(X: Extended): Integer;

{ Poly: Evaluates a uniform polynomial of one variable at value X.
    The coefficients are ordered in increasing powers of X:
    Coefficients[0] + Coefficients[1]*X + ... + Coefficients[N]*(X**N) }
function Poly(X: Extended; const Coefficients: array of Double): Extended;

{-----------------------------------------------------------------------
Statistical functions.

Common commercial spreadsheet macro names for these statistical and
financial functions are given in the comments preceding each function.
-----------------------------------------------------------------------}

{ Mean:  Arithmetic average of values.  (AVG):  SUM / N }
function Mean(const Data: array of Double): Extended;

{ Sum: Sum of values.  (SUM) }
function Sum(const Data: array of Double): Extended register;
function SumOfSquares(const Data: array of Double): Extended;
procedure SumsAndSquares(const Data: array of Double;
  var Sum, SumOfSquares: Extended) register;

{ MinValue: Returns the smallest signed value in the data array (MIN) }
function MinValue(const Data: array of Double): Double;

{ MaxValue: Returns the largest signed value in the data array (MAX) }
function MaxValue(const Data: array of Double): Double;

{ Standard Deviation (STD): Sqrt(Variance). aka Sample Standard Deviation }
function StdDev(const Data: array of Double): Extended;

{ MeanAndStdDev calculates Mean and StdDev in one pass, which is 2x faster than
  calculating them separately.  Less accurate when the mean is very large
  (> 10e7) or the variance is very small. }
procedure MeanAndStdDev(const Data: array of Double; var Mean, StdDev: Extended);

{ Population Standard Deviation (STDP): Sqrt(PopnVariance).
  Used in some business and financial calculations. }
function PopnStdDev(const Data: array of Double): Extended;

{ Variance (VARS): TotalVariance / (N-1). aka Sample Variance }
function Variance(const Data: array of Double): Extended;

{ Population Variance (VAR or VARP): TotalVariance/ N }
function PopnVariance(const Data: array of Double): Extended;

{ Total Variance: SUM(i=1,N)[(X(i) - Mean)**2] }
function TotalVariance(const Data: array of Double): Extended;

{ Norm:  The Euclidean L2-norm.  Sqrt(SumOfSquares) }
function Norm(const Data: array of Double): Extended;

{ MomentSkewKurtosis: Calculates the core factors of statistical analysis:
  the first four moments plus the coefficients of skewness and kurtosis.
  M1 is the Mean.  M2 is the Variance.
  Skew reflects symmetry of distribution: M3 / (M2**(3/2))
  Kurtosis reflects flatness of distribution: M4 / Sqr(M2) }
procedure MomentSkewKurtosis(const Data: array of Double;
  var M1, M2, M3, M4, Skew, Kurtosis: Extended);

{ RandG produces random numbers with Gaussian distribution about the mean.
  Useful for simulating data with sampling errors. }
function RandG(Mean, StdDev: Extended): Extended;

{-----------------------------------------------------------------------
Financial functions.  Standard set from Quattro Pro.

Parameter conventions:

From the point of view of A, amounts received by A are positive and
amounts disbursed by A are negative (e.g. a borrower's loan repayments
are regarded by the borrower as negative).

Interest rates are per payment period.  11% annual percentage rate on a
loan with 12 payments per year would be (11 / 100) / 12 = 0.00916667

-----------------------------------------------------------------------}

type
  TPaymentTime = (ptEndOfPeriod, ptStartOfPeriod);

{ Double Declining Balance (DDB) }
function DoubleDecliningBalance(Cost, Salvage: Extended;
  Life, Period: Integer): Extended;

{ Future Value (FVAL) }
function FutureValue(Rate: Extended; NPeriods: Integer; Payment, PresentValue:
  Extended; PaymentTime: TPaymentTime): Extended;

{ Interest Payment (IPAYMT)  }
function InterestPayment(Rate: Extended; Period, NPeriods: Integer; PresentValue,
  FutureValue: Extended; PaymentTime: TPaymentTime): Extended;

{ Interest Rate (IRATE) }
function InterestRate(NPeriods: Integer;
  Payment, PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;

{ Internal Rate of Return. (IRR) Needs array of cash flows. }
function InternalRateOfReturn(Guess: Extended;
  const CashFlows: array of Double): Extended;

{ Number of Periods (NPER) }
function NumberOfPeriods(Rate, Payment, PresentValue, FutureValue: Extended;
  PaymentTime: TPaymentTime): Extended;

{ Net Present Value. (NPV) Needs array of cash flows. }
function NetPresentValue(Rate: Extended; const CashFlows: array of Double;
  PaymentTime: TPaymentTime): Extended;

{ Payment (PAYMT) }
function Payment(Rate: Extended; NPeriods: Integer;
  PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;

{ Period Payment (PPAYMT) }
function PeriodPayment(Rate: Extended; Period, NPeriods: Integer;
  PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;

{ Present Value (PVAL) }
function PresentValue(Rate: Extended; NPeriods: Integer;
  Payment, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;

{ Straight Line depreciation (SLN) }
function SLNDepreciation(Cost, Salvage: Extended; Life: Integer): Extended;

{ Sum-of-Years-Digits depreciation (SYD) }
function SYDDepreciation(Cost, Salvage: Extended; Life, Period: Integer): Extended;

Clearing Things Up: Usage

Whew! That's a lot of information to digest! I listed it here to impress upon you just how much there is. For those of you creating financial applications, the financial functions will come in handy (I sure wish I had these functions available when I was writing financial software).

Listing the functions is one thing - actually using them is another. As you can see, most of the input parameters require an Extended numeric type, which is a 10-byte number ranging from 3.4 * 10e-4932 to 1.1 * 10e4932 in scientific notation. In other words, you can have incredibly huge numbers as input values.

Take a moment to look at the statistical functions. Notice anything odd about almost all of the functions' input parameters? Most of them take a constant open array of double! This implies you can pass any size array as an input parameter, but it must be passed as a constant array, which means that you have to pass the array in the form of (1, 2, 3, 4, 5, 6 ..). That's not so difficult with small known sets of numbers; just hard code them in. But arrays in Pascal are typically of the variable type, where you define a finite number of elements, then fill in the element values. This poses a bit of a problem. Fortunately, there's a solution.

Buried in the System unit is a function called Slice: function Slice(var A: array; Count: Integer): array; Essentially, what Slice does is take a certain number of elements from an array, starting at the beginning, and passes the slice of the array as an open array parameter, fooling the compiler into thinking a constant array is being passed. This means that you can pass the entire array or smaller subset. In fact, Slice can only be used within the context of being passed as an open array parameter. Using it outside of this context will create a compiler error. What a convenient function! So, we can define a variable type array as we're used to in Delphi, fill it up, put it into Slice, which is then used in one of the functions. For example: MyExtendedNumber := Mean(Slice(MyArray, NumElementsPassed));

At this point, you're probably thinking this is pretty incredible stuff. But there's one thing that still bothers me about it: The place where the statistical functions would be most useful is on columnar calculations on tables. Unfortunately, you never know how many records are in a table until runtime. Granted, depending upon the amount of RAM in your system, you could make an incredibly large array of let's say 100K elements, fill it up to the record count of your table, then apply Slice to grab only those you need. However, that's pretty inefficient. Also, in my immediate experience, many of my tables have well over 100K records, which means I'd have to hard code an even greater upper limit. But there will also be tables that have far fewer records than 100K - more like 10K. So the idea then is to strike a balance. No thanks!

Doing the DynArray Thing

So where am I if I can't accept defining a huge array, or making some sort of size compromise? I guess I need to create a variable sized array whose size can be defined at runtime.

Wait a minute! You're not supposed to be able to do that in Delphi!

You can, but it takes some pointers to be able to pull it off. For an in-depth discussion of the technique, I'm going to point you to an article on the enquiry site entitled Runtime Resizeable Arrays, which will show you how to create an array that has an element count you don't know about until runtime. I highly suggest reading the article before continuing, if you're not familiar with the technique.

What gives you the ability to create a dynamic array is a function like the following (this in the article):

type
  TResizeArr = array[0..0] of string;
  PResizeArr = ^TResizeArr;
  ...

  {============================================================================
   Procedure which defines the dynarray. Note that the THandle and Pointer to
   the array are passed by reference. This is so that they may defined outside
   the scope of this proc.
   ============================================================================}

procedure DefineDynArray(var h: THandle; {Handle to mem pointer}
  NumElements: LongInt; {Number of items in array}
  var PArr: PResizeArr); {Pointer to array struct}
begin
  {Allocate Windows Global Heap memory}
  h := GlobalAlloc(GMEM_FIXED, NumElements * sizeof(TResizeArr));
  PArr := GlobalLock(h);
end;

Note that you can just as easily replace the array of String with an array of Double. In any case, the gist of what the procedure does is allocate memory for the number of elements that you want to have in your array (TResizeArr), then locks that area of the heap and assigns it to an array pointer (PResizeArr). To load values into the array, you de-reference the pointer as follows: MyPointerArray^[0] := 1234.1234;

To pass the entire array into the Mean function as above, all we have to do is de-reference the entire array as follows: MyExtendedNumber := Mean(Slice(MyPointerArray^, NumElementsPassed));

Putting It All Together

I mentioned above that the best place to employ the statistical functions is in performing statistics on columnar data in a table. The unit code below provides a simple example of loading a DynArray with columnar data, then performing the Mean function on the loaded array. Note the table that I used had about 80K records in it.

unit parrmain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  DB, DBTables, ComCtrls, Math, StdCtrls, ds_stats;

type
  TResizeArr = array[0..0] of Double;
  PResizeArr = ^TResizeArr;
  TForm1 = class(TForm)
    StatusBar1: TStatusBar;
    Button1: TButton;
    Table1: TTable;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    PA: PResizeArr;
    Hndl: THandle;
    procedure DefineDynArray(var H: THandle;
      NumElem: LongInt;
      var PArr: PResizeArr);
    procedure FillArray;
    procedure SaveScreen;
  public
    { Public declarations }

  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.DefineDynArray(var H: THandle;
  NumElem: LongInt;
  var PArr: PResizeArr);
begin
  H := GlobalAlloc(GMEM_FIXED, NumElem * SizeOf(TResizeArr));
  PArr := GlobalLock(H);
end;

procedure TForm1.LoadArray;
var
  tbl: TTable;
  recs: LongInt;
begin
  tbl := TTable.Create(Application); //Create a TTable instance
  with tbl do
  begin //and set properties
    Active := False;
    DatabaseName := 'Primary';
    TableName := 'Test';
    TableType := ttParadox;
    Open;

    recs := RecordCount; //Get number of records in table

    DefineDynArray(Hndl, recs, PA); //Now, define our dynarray
    recs := 0; //Reset recs for reuse

    StatusBar1.SimpleText := 'Now filling array';

    while not EOF do
    begin
      Application.ProcessMessages; //allow background processing
      try
        PA^[recs] := FieldByName('Charge').AsFloat;
        StatusBar1.SimpleText := 'Grabbed value of: ' + FloatToStr(PA^[recs]);
        StatusBar1.Invalidate;
        Inc(recs);
        Next;
      except
        GlobalUnlock(Hndl);
        GlobalFree(Hndl);
        Exit;
      end;
    end;

    //Pop up a message to show what was calculated.
    ShowMessage(FloatToStr(Mean(Slice(PA^, RecordCount))));
      //pass the array using Slice
    GlobalUnlock(Hndl); //Unlock and Free memory and TTable instance.
    GlobalFree(Hndl);
    tbl.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  LoadArray;
end;

end.

You could get pretty complex with this by creating a component that encapsulates the statistical functions and grabs data off a table. Using the principles of the code above, it shouldn't be too hard to do. Follow the code; better yet, try it out, supply your own values, and see what you come up with.

We covered a lot of ground here. I wasn't happy to tell you merely about the Math unit and all the wonderful routines it contains; I wanted to show you a way to employ a major portion of it in as flexible a way as possible.

In my opinion, it's not enough just to know about something in programming; you have to know how to use it. With the material I've presented, you should be able to employ the functions of the Math unit in very little time.

Create and free a window handle inside a TThread object

Problem/Question/Abstract:

I have a (separate) thread that spends most of its time waiting for (synchronisation) events, and when an event occurs it performs some processing which involves user-specific (Delphi) event handling. In these event handlers I would now like to be able to create objects that uses Windows messages, such as TTimers or some other own-developed components we have, and that these objects should be able to generate (Delphi) events as they normally would (although executed in my separate thread, of course).

Answer:

I usually use messages within threads and works fine, I attach 2 procedures that allows you to create/ free a window handle inside a TThread object and to use the standard Delphi way to handle messages. The function are:

CreateWindowHandle(AObject: TObject): integer;
FreeWindowHandle(AHandle: integer);

You should use them in the following way:

{ ... }
type
  TMyThread = class(TThread)
  private
    hwnd: integer;
  protected
    procedure handler1(var message: TMessage); message WM_USER; {or any other message}
  end;

constructor Create { ... }
begin
  { ... }
  hwnd := CreateWindowHandle(Self);
  { ... }
end;

destructor Destroy { ... }
begin
  { ... }
  freewindowhandle(hwnd);
  { ... }
end;

var
  ObjectWindowClass: TWndClass = (style: 0; lpfnWndProc: @windows.DefWindowProc;
    cbClsExtra: 0; cbWndExtra: 0; hInstance: 0; hIcon: 0;
    hCursor: 0; hbrBackground: 0; lpszMenuName: nil;
    lpszClassName: 'ObjectWindowClass@wbuwbvubvy');

function ObjectWindowProc(HWnd, Msg, wParam, lParam: integer): integer; stdcall;
var
  m: TMessage;
begin
  m.Msg := uint(msg);
  m.wParam := wParam;
  m.lParam := lParam;
  TObject(GetWindowLong(hwnd, GWL_USERDATA)).Dispatch(m);
  result := m.Result;
end;

function CreateWindowHandle(AObject: TObject): integer;
var
  TempClass: TWndClass;
  ClReg: Boolean;
  hwnd: integer;
begin
  {register the window class (if not already registered) }
  ObjectWindowClass.hInstance := HInstance;
  ClReg := GetClassInfo(HInstance, ObjectWindowClass.lpszClassName, TempClass);
  if (not ClReg) or (TempClass.lpfnWndProc <> @windows.DefWindowProc) then
  begin
    if ClReg then
      Windows.UnregisterClass(ObjectWindowClass.lpszClassName, HInstance);
    Windows.RegisterClass(ObjectWindowClass);
  end;
  {create the window}
  HWnd := CreateWindow(ObjectWindowClass.lpszClassName, '', 0, 0, 0, 0, 0, 0, 0,
    HInstance, nil);
  {subclass the window}
  SetWindowLong(HWnd, GWL_USERDATA, integer(AObject));
  SetWindowLong(HWnd, GWL_WNDPROC, integer(@ObjectWindowProc));
  Result := HWnd;
end;

procedure FreeWindowHandle(AHandle: integer);
begin
  SetWindowLong(AHandle, GWL_WNDPROC, integer(@windows.DefWindowProc));
  DestroyWindow(AHandle);
end;

Display the multimedia properties from the control panel

Problem/Question/Abstract:

Display the multimedia properties from the control panel

Answer:

Displaying the multimedia properties dialog from the control panel is very easy with the following code; the secret is to know to call rundll32.


begin
  // Audio
  WinExec('rundll32 shell32.dll,Control_RunDLL MMSys.cpl,,0', SW_SHOW);
  // Video
  WinExec('rundll32 shell32.dll,Control_RunDLL MMSys.cpl,,1', SW_SHOW);
  // Midi
  WinExec('rundll32 shell32.dll,Control_RunDLL MMSys.cpl,,2', SW_SHOW);
  // CD Music
  WinExec('rundll32 shell32.dll,Control_RunDLL MMSys.cpl,,3', SW_SHOW);
end

Move components on a form during runtime

Problem/Question/Abstract:

Move components on a form during runtime

Answer:

Moves misc. components on a form, e.g. TButton, TLabel, etc. Put the call in the components OnMouseDown-Eventhandler;
  
Example: MoveObject(Sender, X, Y);

uses
  Windows, Messages;

procedure MoveObject(Sender: TObject; X, Y: Integer);
const
  SC_DragMove = $F012;
begin
  ReleaseCapture;
  (Sender as TControl).Perform(WM_SysCommand, SC_DragMove, 0);
end;

Debugger skips code

Problem/Question/Abstract:

I trace the instructions in the debugger and find that it suddenly skips code I've written - it moves through it, but doesn't take action.

Answer:

I also had this problem with the skipped code. I removed all of the temp type files, just kept the DFM and PAS files + DPR,did a rebuild and it seemed to be ok. It seems to get out of step with itself sometimes.

Today's date on database server

Problem/Question/Abstract:

Today's date on database server

Answer:

This is another case where ORACLE and InterBase differ.

// make the SQL dependent on type of DBMS

if AppLibrary.Database.DriverName = 'ORACLE' then
  SQL.Add('and entry_date < SYSDATE')
else
  SQL.Add('and entry_date < "TODAY"');
end;

How to use all the capabilities of windows fonts?

Problem/Question/Abstract:

TFont doesn't give you all the capabilities of Windows fonts when you need to draw some text.
This is because the mechanism TFont uses differs from the one Windows have.

Answer:

TFont is a descent of TGraphicsObject. This is the abstract base class for objects which encapsulate a system graphics object: TBrush, TFont, and TPen.
Internally TFont uses the TFontData record to keep track of all changes to our font.

While TFontData structure is like this:

TFontData = record
  Handle: HFont;
  Height: Integer;
  Pitch: TFontPitch;
  Style: TFontStylesBase;
  Charset: TFontCharset;
  Name: TFontDataName;
end;

windows LogFont structure defines the following attributes of a font:

tagLOGFONTA = packed record
  lfHeight: Longint;
  lfWidth: Longint;
  lfEscapement: Longint;
  lfOrientation: Longint;
  lfWeight: Longint;
  lfItalic: Byte;
  lfUnderline: Byte;
  lfStrikeOut: Byte;
  lfCharSet: Byte;
  lfOutPrecision: Byte;
  lfClipPrecision: Byte;
  lfQuality: Byte;
  lfPitchAndFamily: Byte;
  lfFaceName: array[0..LF_FACESIZE - 1] of AnsiChar;
end;

TLogFontA = tagLOGFONTA;
TLogFont = TLogFontA;

you can already see the difference between both. Anyway, while trying to simplify the process Delphi team forgot to add to TFontData : lfEscapment, lfOrientation (with the two we can rotate a font) and lfQuality (this one give us the possibility of drawing an antialised font).

When you call TextOut, internally when the draw text routine gets the handle for the font to be used with the windows API ExtTextOut, TFont maps the TFont structure to windows logfont structure (much like the way I did the DrawText routine forward).

In TFont.GetHandle we see the following:

(...split...)
lfEscapement := 0; { only straight fonts }
lfOrientation := 0; { no rotation }
(...split...)
lfQuality := DEFAULT_QUALITY;
(...split...)

so... they didn't want to code just a little more :)

I thougth about changing (or even extending) TFont class to have these two properties available, anyway (if someone is interested I could do that) I'll just present here a routine that can draw some text (rotated and with more quality).

procedure DrawText(ACanvas: TCanvas; AAngle: Integer; AQuality: byte; X, Y: Integer;
  AText: string);
var
  lf: TLogFont;

begin
  with ACanvas do
  begin
    GetObject(Font.Handle, SizeOf(lf), @lf);
    with lf do
    begin
      lfQuality := AQuality;
      lfOrientation := AAngle * 10;
      lfEscapement := lfOrientation;
    end;
    Font.Handle := CreateFontIndirect(lf);
    TextOut(X, Y, AText);
  end;
end;

AQuality can be :
DEFAULT_QUALITY
Appearance of the font does not matter.

DRAFT_QUALITY
Appearance of the font is less important than when PROOF_QUALITY is used. For GDI raster fonts, scaling is enabled, which means that more font sizes are available, but the quality may be lower. Bold, italic, underline, and strikeout fonts are synthesized if necessary.

PROOF_QUALITY
Character quality of the font is more important than exact matching of the logical-font attributes. For GDI raster fonts, scaling is disabled and the font closest in size is chosen. Although the chosen font size may not be mapped
exactly when PROOF_QUALITY is used, the quality of the font is high and there is no distortion of appearance. Bold, italic, underline, and strikeout fonts are synthesized if necessary.

NONANTIALIASED_QUALITY
ANTIALIASED_QUALITY

Note: Remember that the 3 attributes just work with True Type Fonts.

How to get unique ItemIndexes across multiple TRadioGroups

Problem/Question/Abstract:

Is there a clean, simple solution to this problem: You have three RadioGroups: RgA, RgB, and RgC. Each has the same three items (numbered 0, 1, and 2 - actual string values are irrelevant here). Initially, RgA.ItemIndex = 0, RgB.ItemIndex = 1, and RgC.ItemIndex =2. The problem is to ensure that each selection (ItemIndex) is unique across all the RadioGroups. If the user clicks RgA and changes its index to 2, RgC's ItemIndex must change to 0 (the unused value). You'll always have one RadioGroup with an ItemIndex of 0, one with 1, and one with 2.

Answer:

Here is a possible approach:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    RadioGroup1: TRadioGroup;
    RadioGroup2: TRadioGroup;
    RadioGroup3: TRadioGroup;
    procedure FormCreate(Sender: TObject);
    procedure AllRadiogroupsClick(Sender: TObject);
  private
    { Private declarations }
    FRGroups: array[1..3] of TRadioGroup;
    FRGroupItemIndices: array[1..3] of 0..2;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  FRGroups[1] := RadioGroup1;
  FRGroups[2] := RadioGroup2;
  FRGroups[3] := RadioGroup3;
  for i := 1 to 3 do
  begin
    FRGroupItemIndices[i] := FRGroups[i].ItemIndex;
    FRGroups[i].Tag := i;
  end;
  { assumes indices have been set up correctly at design time! }
end;

procedure TForm1.AllRadiogroupsClick(Sender: TObject);
var
  oldvalue: Integer;
  swapWith: Integer;
  thisGroup: TRadioGroup;

  function FindOldValue(value: Integer): Integer;
  var
    i: integer;
  begin
    result := 0;
    for i := 1 to 3 do
      if FRGroupItemIndices[i] = value then
      begin
        result := i;
        break;
      end;
    if result = 0 then
      raise exception.create('Error in FindOldValue');
  end;

begin
  {Tag property of radiogroup stores index for arrays}
  {Find old value of the group that changed}
  thisGroup := Sender as TRadioGroup;
  oldvalue := FRGroupItemIndices[thisGroup.Tag];
  if oldvalue = thisGroup.ItemIndex then
    Exit;
  {Find the index of the group that currently has the value this group changed to}
  swapWith := FindOldValue(thisGroup.ItemIndex);
  {Change the array values}
  FRGroupItemIndices[thisGroup.Tag] := thisGroup.ItemIndex;
  FRGroupItemIndices[swapWith] := Oldvalue;
  {Change the Itemindex of the other group. Disconnect handler while doing so}
  with FRGroups[swapWith] do
  begin
    OnClick := nil;
    ItemIndex := oldValue;
    OnClick := AllRadioGroupsClick;
  end;
end;

end.

How to create a non-rectangular TShape that accepts mouse clicks only in the shape's region itself

Problem/Question/Abstract:

How to create a non-rectangular TShape that accepts mouse clicks only in the shape's region itself

Answer:

This will show you how to do a TShape that has mouse clicks only in the shape itself and not it's surrounding box.

unit NoMouseShape;

interface

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

type
  TNoMouseShape = class(TShape)
  private
    { Private declarations }
  protected
    { Protected declarations }
    procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
  published
    { Published declarations }
    function ValidPoint(pt: TPoint): Boolean;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('EXS', [TNoMouseShape]);
end;

constructor TNoMouseShape.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Shape := stCircle;
end;

function TNoMouseShape.ValidPoint(pt: TPoint): Boolean;
var
  i, j: Integer;
begin
  Result := False;
  for i := 0 to Width do
    for j := 0 to Height do
      if (Self.Canvas.Pixels[pt.x, pt.y] = clWhite) or (Self.Canvas.Pixels[pt.x, pt.y] = clBlack) then
        Result := True;
end;

procedure TNoMouseShape.CMHitTest(var Message: TCMHitTest);
begin
  if ValidPoint(SmallPointToPoint(Message.Pos)) then
    Message.Result := HTCLIENT {Handle the message}
  else
    Message.Result := HTNOWHERE; {pass on to parent}
end;

end.

Now, if you want a real non-rectangular area, using SetWindowRgn would be the way to go. You do not have to derive from TWinControl, drive it from TCustomControl as TCustomControl provides a canvas and handles paint messages. Then you will need to re-write the ValidPoint function to use the PtInRegion API function.

Select an area with similar color

Problem/Question/Abstract:

In my application, I want to select an area with similar color. This tool should work like Photoshop's Magic Wizard Tool. But how can I determine if 2 pixels are similar if they don't have the same RGB value?

Answer:

A "quick" solution is to compare the RGB components separately - if none of the red, green or blue components differ by more than the threshold amount then you can assume that the colours are "similar". There are more optically correct methods of comparing colours but this might be good enough for your purposes.

function ColoursAreSimilar(Col1, Col2: TRGBQuad; Threshold: Integer): Boolean;
begin
  Result := (Abs(Col1.rgbRed - Col2.rgbRed) <= Threshold) and
    (Abs(Col1.rgbGreen - Col2.rgbGreen) <= Threshold) and
    (Abs(Col1.rgbBlue - Col2.rgbBlue) <= Threshold);
end;

How to check for duplicates in a dynamic array of elements containing random integers

Problem/Question/Abstract:

Say I have a dynamic array of five elements containing random integers. I want to be able to check for duplicate numbers among the 5 elements and if found, call a random number generator function until all the numbers are different.

Answer:

Solve 1:

This strategy goes through the array one element at a time, making sure it is unique. All we have to do is make sure it is unique from all the preceding elements, and by the time you get to the end of the array, it is all unique.

procedure ForceUnique;
var
  i, j: integer;
begin
  for i := 2 to 5 do {the first element is unique by definition}
  begin
    j := 1;
    while (j < i) do
    begin
      if MyArray[j] = MyArray[i] then
      begin
        MyArray[i] := Random(MyRange);
        j := 1; {start over with a new number}
      end
      else
        j := j + 1;
    end;
  end;
end;

Watch out for potential infinite loop problem if the range of random numbers is less than the size
of the array.


Solve 2:

How about filling the arrays with ascending order of number and then shuffling it randomly afterwards. This is the quickest and surest way to achieve the same effect.

What I am afraid is a situation like this. Let us say you have an array of 32767 small integers. Let us say you want to fill the individual elements with Random values ranging from 0 to 32767. Using random number generator, the probability that all of the elements will be unique is zero. Now, let us say, you sort the random list first, then it is easy to find duplicates, and let us say for each duplicate you try to generate a random number which is not in the array and hopefully replace those duplicates. In this situation, your program will take forever to complete.

If you only have 5 elements, a bubble-type comparison would suffice, if you have more than a hundred elements, you need to sort your array first and do a binary search to find duplicates. If your random number ranges from 0 to MaxInt, this has a greater chance of successfully completing than with a smaller random number range.

Here's the slowest but easy to understand working code for bubble-wise comparisons. Assume iArray is your dynamic array 1 based.

{declare these first:
i, j, k, iRand, iCurr: integer;
iAlreadyExists: boolean;}

{ ... }
for i := 1 to 5 do
begin
  icurr := iArray[i];
  for j := i + 1 to 5 do
  begin
    if icurr = iArray[j] then
    begin
      repeat
        irand := Random(MaxInt);
        iAlreadyExists := False;
        for k := 1 to 5 do
        begin
          if irand = iArray[k] then
          begin
            iAlreadyExists := True;
            break;
          end;
        end;
      until
        not iAlreadyExists;
      iArray[i] := irand;
      break;
    end;
  end;
end;
{ ... }

Capturing all of the Output from a Console application (32 bit)

Problem/Question/Abstract:

Use the function GetDosOutput in your application to capture all the output from a DOS application (this version only supports 32-bit console applications for how to do this with 16 bit see the update to this article "Capturing all of the Output from a Console application (16 bit)").

Code recieved from Mike Lischke (Team JEDI) in response to a question I asked on the borland winapi newsgroup.  It came from his app "Compiler Generator" (www.lischke-online.de/DCG.html) and then was converted to the GetDosOutput function by me.  You can contact me at johnwlong@characterlink.net.

Answer:

unit consoleoutput;

interface

uses
  Controls, Windows, SysUtils, Forms;

function GetDosOutput(const CommandLine: string): string;

implementation

function GetDosOutput(const CommandLine: string): string;
var
  SA: TSecurityAttributes;
  SI: TStartupInfo;
  PI: TProcessInformation;
  StdOutPipeRead, StdOutPipeWrite: THandle;
  WasOK: Boolean;
  Buffer: array[0..255] of Char;
  BytesRead: Cardinal;
  WorkDir, Line: string;
begin
  Application.ProcessMessages;
  with SA do
  begin
    nLength := SizeOf(SA);
    bInheritHandle := True;
    lpSecurityDescriptor := nil;
  end;
  // create pipe for standard output redirection
  CreatePipe(StdOutPipeRead, // read handle
    StdOutPipeWrite, // write handle
    @SA, // security attributes
    0 // number of bytes reserved for pipe - 0
    default
    );
  try
    // Make child process use StdOutPipeWrite as standard out,
    // and make sure it does not show on screen.
    with SI do
    begin
      FillChar(SI, SizeOf(SI), 0);
      cb := SizeOf(SI);
      dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
      wShowWindow := SW_HIDE;
      hStdInput := GetStdHandle(STD_INPUT_HANDLE); // don't redirect std
      input
        hStdOutput := StdOutPipeWrite;
      hStdError := StdOutPipeWrite;
    end;

    // launch the command line compiler
    WorkDir := ExtractFilePath(CommandLine);
    WasOK := CreateProcess(nil, PChar(CommandLine), nil, nil, True, 0, nil,
      PChar(WorkDir), SI, PI);

    // Now that the handle has been inherited, close write to be safe.
    // We don't want to read or write to it accidentally.
    CloseHandle(StdOutPipeWrite);
    // if process could be created then handle its output
    if not WasOK then
      raise Exception.Create('Could not execute command line!')
    else
    try
      // get all output until dos app finishes
      Line := '';
      repeat
        // read block of characters (might contain carriage returns and  line feeds)
        WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);

        // has anything been read?
        if BytesRead > 0 then
        begin
          // finish buffer to PChar
          Buffer[BytesRead] := #0;
          // combine the buffer with the rest of the last run
          Line := Line + Buffer;
        end;
      until not WasOK or (BytesRead = 0);
      // wait for console app to finish (should be already at this point)
      WaitForSingleObject(PI.hProcess, INFINITE);
    finally
      // Close all remaining handles
      CloseHandle(PI.hThread);
      CloseHandle(PI.hProcess);
    end;
  finally
    result := Line;
    CloseHandle(StdOutPipeRead);
  end;
end;

end.

Retrieving names, addresses, e-mails from MS Outlook

Problem/Question/Abstract:

So how to read a collection of Contacts which are exist in MS Outlook?

Answer:

As you know I like MS Outlook because there a lot of possibilities and OLE automation of Outlook allow to solve possible any task.

Today I want continue a serie of tips for MS Outlook.

So how to read a collection of Contacts which are exist in MS Outlook?

This task is very popular. For example, you want to develop a sample tool which will notify you about birthday for someone or you want to send messages to "mailing list". So you want to naviagte thru list of defined contacts and process any item.

Below you'll find a sample code:

const
  olFolderContacts = $0000000A;
var
  outlook, NameSpace, Contacts, Contact: OleVariant;
  i: Integer;
begin
  outlook := CreateOleObject('Outlook.Application');
  NameSpace := outlook.GetNameSpace('MAPI');

  Contacts := NameSpace.GetDefaultFolder(olFolderContacts);
  for i := 1 to Contacts.Items.Count do
  begin
    Contact := Contacts.Items.Item(i);
    {now you can read any property of contact. For example, full name
                and email address}
    ShowMessage(Contact.FullName + ' <' + Contact.Email1Address + '>');
  end;

  Outlook := UnAssigned;
end;

if you need a birthday, you can retrieve it as DateToStr(Contact.Birthday)

Any contact item have a lot of properties. See a list (alphabet):

Birthday
Business2TelephoneNumber
BusinessAddress
BusinessAddressCity
BusinessAddressCountry
BusinessAddressPostalCode
BusinessAddressPostOfficeBox
BusinessAddressState
BusinessAddressStreet
BusinessFaxNumber
BusinessHomePage
BusinessTelephoneNumber
CompanyAndFullName
CompanyMainTelephoneNumber
CompanyName
ComputerNetworkName
Department
Email1Address
Email1AddressType
Email1DisplayName
Email2Address
Email2AddressType
Email2DisplayName
Email3Address
Email3AddressType
Email3DisplayName
FirstName
FTPSite
FullName
FullNameAndCompany
GovernmentIDNumber
Hobby
Home2TelephoneNumber
HomeAddress
HomeAddressCity
HomeAddressCountry
HomeAddressPostalCode
HomeAddressPostOfficeBox
HomeAddressState
HomeAddressStree
HomeFaxNumber
HomeTelephoneNumber
Initials
ISDNNumber
JobTitle
Language
LastName
LastNameAndFirstName
MailingAddress
MailingAddressCity
MailingAddressCountry
MailingAddressPostalCode
MailingAddressPostOfficeBox
MailingAddressState
MailingAddressStreet
MiddleName
NickName
OfficeLocation
OrganizationalIDNumber
PersonalHomePage
PrimaryTelephoneNumber
Profession
Suffix
Title
WebPage

Customize Toolbars at runtime

Problem/Question/Abstract:

Professional applications like Word or Excel let the user design the toolbars and let create new toolbars at runtime. This is't usually done with a little customize dialog and drag & drop functions.

Answer:

Professional applications like Word or Excel let the user design the toolbars and let create new toolbars at runtime. This ist usually done with a little customize dialog and drag & drop functions. This sample shows you, how to get this functionality simple into your program.

First of all, you must make some decissions to your program design. All functions, that can be put on a toolbar must defined in an Actionlist, because we need a list of functions that can be asigned to the toolbuttons. To minimize this work an Actionlist is the right thing, because wie can walk through the functions, have an automatic integration of the images for the toolbuttons via the imagelist, centralized shortcuts and have unique names for the functions to save and restore it.

The next thing is, that you should save and restore the customized toolbars to an inifile or the registry. This is done by the TFiletoolbar component included with this sample. Note, that you must assign the Actionlist to TFiletoolbars to get the save/restore work.

The customize dialog is built with formstyle fsStayOnTop, so the window is on top of our application. The form is displayed with the Show methode, because we must interact in the mainform for doing Drag & Drop.

For further details look at the TFiletoolbar documentation and to the source of the demo project. In the source you find detailed comments to anything that ist neccesary for get it working in your application.

Download the whole sample project including TFiletoolbar component for saving and restoring Toolbars.
http://www.helli.de/DelphiCorner/dc_tips/dc_tip4/dc_tip4.html

TToolbar97 component pack by Jordan Russel, Version 1.75 or higher available from http://www.jordanr.dhs.org/ (Freeware for non commercial use) is needed.

Example of Drag&Drop functions from Sample project:

//---------------------------------------------------------------
// Drag & Drop of Toolbar Buttons
// These functions are plugged to the OnDragOver, OnDragDrop and
// OnDragEnd property of any toolbar and any button on it.
// By user defined buttons and toolbars this is done automatic,
// by predefined toolbars you must plug in the functions in
// Objectinspector
//---------------------------------------------------------------

procedure TForm1.ToolbarDragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
// This function must be plugged to the OnDragOver property of
// any toolbars and toolbuttons
//
// Check if Dropping is allowed
begin
  if Source is TListView then
    // Docking allowed only from CustomizeDialog Command Listview
    Accept := (Source as TListView).Name = CustomizeDialog.Commands.Name;
end;

procedure TForm1.ToolbarDragDrop(Sender, Source: TObject; X, Y: Integer);
// This function must be plugged to the OnDragDrop property of
// any toolbars and toolbuttons
//
// Handler for TToolbutton97 objects for dropping from CustomizeDialog
var
  t: TListView;
  act: TAction;
  ti: TListItem;
  tb, tb2: TToolbarButton97;
  ftb: TFileToolbar;
  oi: Integer;
begin
  if Source is TListView then
  begin // Is it from the Listview?
    t := Source as TListView;
    if Assigned(t) then
    begin
      // Get the selected item, it holds the desired action
      ti := t.Selected;
      if Assigned(ti) then
      begin
        // The action is stored in the data property of the item
        act := ti.Data;
        if Assigned(act) then
        begin
          // create a toolbutton on the fly
          tb := TToolbarButton97.Create(self);
          if Assigned(tb) then
          begin
            tb.Images := ImageList1; // Assign the Imagelist
            tb.DisplayMode := dmGlyphOnly; // display only the image
            // mode is turned to dmManual when leaving the
            // CustomizeDialog but to handle Drag&Drop, it must be
            // dmAutomatic by now
            tb.DragMode := dmAutomatic;
            tb.Action := act; // the desired Action
            // Assign the handlers
            tb.OnDragDrop := ToolbarDragDrop;
            tb.OnDragOver := ToolbarDragOver;
            tb.OnEndDrag := ToolbarEndDrag;
            // Hints like parent
            tb.ParentShowHint := True;
            // Look for the place to add the button on the toolbar
            ftb := nil;
            oi := x div tb.Width;
            // Convert Position from pixel to number of buttons
            if Sender is TFileToolbar then
            begin
              // dropped direct to the toolbar?
              ftb := Sender as TFileToolbar;
            end
            else if Sender is TToolbarButton97 then
            begin
              // placed on an other button?
              tb2 := Sender as TToolbarButton97;
              if Assigned(tb2) then
              begin
                // Get parent and Orderindex of the button
                ftb := tb2.Parent as TFileToolbar;
                oi := ftb.OrderIndex[tb2];
              end;
            end;
            if Assigned(ftb) then
            begin // We have a parent...
              // generate a unique name for the button
              tb.Name := 'tbB' + CustomizeDialog.DateStamp;
              // Insert the button on the toolbar
              ftb.InsertControl(tb);
              ftb.OrderIndex[tb] := oi; // and set the Orderindex
            end;
          end;
        end;
      end;
    end;
  end;
end;

procedure TForm1.ToolbarEndDrag(Sender, Target: TObject; X, Y: Integer);
// This function must be plugged to the OnEndDrag property of any
// toolbutton. The toolbars must not have this, because you cant
// throw them out of the program...
//
// Handler for TToolbarbutton97 objects to throw 'em out
// of the Toolbar
var
  tb: TToolbarButton97;
  ftb: TFileToolbar;
begin
  if not Assigned(Target) then
  begin
    // No target > so throw the button away
    tb := Sender as TToolbarButton97;
    if Assigned(tb) then
    begin
      ftb := tb.Parent as TFileToolbar;
      // Delete the button
      if Assigned(ftb) then
        ftb.RemoveControl(tb);
    end;
  end;
end;

How can I find out the Internet Explorer Version

Problem/Question/Abstract:

How can I find out the Internet Explorer version?

Answer:

uses
  Registry;

function GetIEVersion(Key: string): string;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    Reg.OpenKey('Software\Microsoft\Internet Explorer', False);
    try
      Result := Reg.ReadString(Key);
    except
      Result := '';
    end;
    Reg.CloseKey;
  finally
    Reg.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage('IE-Version: ' + GetIEVersion('Version')[1] + '.' +
    GetIEVersion('Version')[3]);
  ShowMessage('IE-Version: ' + GetIEVersion('Version'));
  // <major version>.<minor version>.<build number>.<sub-build number>
end;

How to colour specific cells in a TDBGrid

Problem/Question/Abstract:

Do you know any way to make a row in a DBGrid have a different color. I would like the color to be based on a value in the row. Like a status flag that says if a an account is over 90 days due, show the row in red.

Answer:

Respond to an OnDrawDataCell event. Here's an example that uses the demo COUNTRY table and draws the text of each row in red where the population is less than a certain value.

{ ... }
begin
  if Table1.FieldByName('Population').AsFloat < 10000000 then
    DBGrid1.Canvas.Font.Color := clRed;
  DBGrid1.DefaultDrawDataCell(Rect, Field, State);
end;
{ ... }

How to synchronize a TTreeView with a TMemo

Problem/Question/Abstract:

I'm trying to synchronize different nodes in a TTreeView with different text displayed in a TMemo control.

Answer:

Lets assume you want to store the memo text into TStringList instances and store the stringlist reference into the node.data property. The first order of the day is to create the stringlists. You do that when you create the nodes, that is the logical place to do it. So after you have added a node you do a

node.Data := TStringlist.Create;

The stringlist is initially empty, of course. So if you have some data to load into the node you can load it into the stringlist with a statement like

TStringlist(node.data).Text := SomeStringValue;

The act of moving the text to the memo and back is now a simple assignment, no stringlists get created for that since we already have them. The main problem is to get aware when the user moves to a new node, so the old (perhaps edited) node can be updated from the memo. This seems to be another problem that is giving you grief. The solution is to track the *last* selected node, the one whos content is currently in the memo. Add a field

FLastNode: TTreeNode;

to your form (private section). This field starts out as Nil (no node active).

procedure TForm1.tv_eg5Change(Sender: TObject; Node: TTreeNode);
begin
  if Node.Selected and (FLastNode <> Node) then
  begin
    if Assigned(FLastNode) then
      TStringlist(FLastNode.Data).Assign(memo1.lines);
    Memo1.Lines.Assign(TStringlist(Node.Data));
    FLastNode := Node;
  end;
end;

procedure TForm1.Memo1Exit(Sender: TObject);
begin
  if assigned(FLastnode) then
    TStringlist(FLastNode.Data).Assign(memo1.lines);
end;

You have to check whether the memos Onexit event happens before or after the treeviews OnChange event if you have focus on the memo and click on an item in the treeview. If it happens after the OnChange event the Onexit handler needs to be modified to look like

procedure TForm1.Memo1Exit(Sender: TObject);
begin
  if assigned(FLastnode) and not treeview1.focused then
    TStringlist(FLastNode.Data).Assign(memo1.lines);
end;

Otherwise you will assign the memos content just back from the node the OnChange handler just loaded it from.

A final thing you have to do is free the stringlist items attached to the treeview before the form is destroyed. If you don't use drag & dock with the treeview or the form it is on you could use the OnDeletion event of the treeview for this, doing a

TObject(node.data).Free;

in the handler. If drag & dock is involved this is not a good idea since the event fires each time the treeview or its parent changes from undocked to docked status and back. In this case the forms OnCloseQuery or OnClose event may be suitable. There you iterate over the treeviews nodes and do the free on each as above.

Copy/delete a BDE table

Problem/Question/Abstract:

Copy/delete a BDE table

Answer:

Here is an example of a routine that I use for copying and deleting tables. It uses DB, DBTables, DbiProcs,DbiErrs, and DbiTypes.

You simply provide the directory to copy from, the source table name, the directory to copy to, and the destination table name, and the BDE will copy the entire table, indexes and all to the new file.

The delete function takes the path to delete from and the name of the table to delete, the BDE takes care of deleting all associated files (indexes, etc.).

These procedures have been pulled off a form of mine, and I've edited them to remove some dependencies that existed with that form. They should now be completely stand-alone.

procedure TConvertForm.CopyTable(FromDir, SrcTblName, ToDir, DestTblName: string);
var
  DBHandle: HDBIDB;
  ResultCode: DBIResult;
  Src, Dest, Err: array[0..255] of Char;
  SrcTbl, DestTbl: TTable;
begin
  SrcTbl := TTable.Create(Application);
  DestTbl := TTable.Create(Application);
  try
    SrcTbl.DatabaseName := FromDir;
    SrcTbl.TableName := SrcTblName;
    SrcTbl.Open;
    DBHandle := SrcTbl.DBHandle;
    SrcTbl.Close;
    ResultCode := DbiCopyTable(DBHandle, false,
      StrPCopy(Src, FromDir + '\' + SrcTblName), nil,
      StrPCopy(Dest, ToDir + '\' + DestTblName));
    if ResultCode <> DBIERR_NONE then
    begin
      DbiGetErrorString(ResultCode, Err);
      raise EDatabaseError.Create('While copying ' +
        FromDir + '\' + SrcTblName + ' to ' +
        ToDir + '\' + DestTblName + ', the '
        + ' database engine   generated the error '''
        + StrPas(Err) + '''');
    end;
  finally
    SrcTbl.Free;
    DestTbl.Free;
  end;
end;

procedure TConvertForm.DeleteTable(Dir, TblName: string);
var
  DBHandle: HDBIDB;
  ResultCode: DBIResult;
  tbl, Err: array[0..255] of Char;
  SrcTbl, DestTbl: TTable;
begin
  SrcTbl := TTable.Create(Application);
  try
    SrcTbl.DatabaseName := Dir;
    SrcTbl.TableName := TblName;
    SrcTbl.Open;
    DBHandle := SrcTbl.DBHandle;
    SrcTbl.Close;
    ResultCode := DbiDeleteTable(DBHandle,
      StrPCopy(Tbl, Dir + '\' + TblName), nil);
    if ResultCode <> DBIERR_NONE then
    begin
      DbiGetErrorString(ResultCode, Err);
      raise EDatabaseError.Create('While deleting ' +
        Dir + '\' + TblName + ', the database ' +
        'engine generated the error ''' + StrPas(Err) + '''');
    end;
  finally
    SrcTbl.Free;
  end;
end;

How to access menuitems like an array and how to write just one onclick procedure for all of them

Problem/Question/Abstract:

How to access menuitems like an array and how to write just one onclick procedure for all of them?

Answer:


// Suppose you have an application with a TMainMenu.
// Under the MenuItem, with caption "File" of the MainMenu, you can
// choose the "normal" things, like:
// "Open", "New", "Close", Save", "Print", "Printer Setup", "Exit" and
// so on.
// At the end of the "File" menu there is a recent file list with all
// the files in it which you recently opened with this application.
// (Just like in Word.) Suppose the names of these MenuItems are:
//
//    FileLastFile1 : TMenuItem;
//    FileLastFile2 : TMenuItem;
//    FileLastFile3 : TMenuItem;
//    FileLastFile4 : TMenuItem;
//    FileLastFile5 : TMenuItem;
//    FileLastFile6 : TMenuItem;
//    FileLastFile7 : TMenuItem;
//    FileLastFile8 : TMenuItem;
//    FileLastFile9 : TMenuItem;
//
// When the application starts, it opens a config file, where the drive,
// path and filenames of the recent file list are read. You can set the
// captions of the MenuItems with the following procedure:
//----------------------------------------------------------------------

procedure ReadConfigFile;

var
  // It is better to make this a global TMenuItem array so you only
  // have to assign once.
  aMenuItem: array[1..9] of TMenuItem
  f: TextFile;
  I: Integer;
  S: string;

begin
  // If this array is global, you only have to assign once. F.i. in the
  // procedure OnFormCreate. After that you can always access the
  // MenuItems like an array, with: aMenuItem[Index].
  aMenuItem[1] := FileLastFile1;
  aMenuItem[2] := FileLastFile2;
  aMenuItem[3] := FileLastFile3;
  aMenuItem[4] := FileLastFile4;
  aMenuItem[5] := FileLastFile5;
  aMenuItem[6] := FileLastFile6;
  aMenuItem[7] := FileLastFile7;
  aMenuItem[8] := FileLastFile8;
  aMenuItem[9] := FileLastFile9;

  // Now the MenuItems are in an TMenuItem array, we can get easy access
  // to the individual MenuItems. Like this:
  for I := 1 to 9 do
    aMenuItem[I].Caption := ''; // Make the caption empty.

  // Open the config file with the recent file list. Example:
  AssignFile(f, 'c:\my_ini_file.ini');
  Reset(f);

  // Read out the recent file names and put them in a global string array.
  // Example:
  for I := 1 to 9 do
    if not Eof(f) then
      ReadLn(f, aRecentfile[I]);
  System.CloseFile(f);
  //
  // Of course you can also do it the "windows" way with:
  // MyIniFile := TIniFile.Create('c:\my_ini_file.ini');
  // For I := 1 to 9 do
  //    aRecentFile[I] := MyIniFile.ReadString('Section','RecentFile' +
  //       Chr(I + Ord('0')), '');
  // MyIniFile.Free;
  //
  // If the content of the IniFile looks like this:
  //
  // [Section]
  // RecentFile1=c:\firstfile.bmp
  // RecentFile2=c:\secondfile.txt
  // ...
  //
  // Now you can assign the filenames to the caption of the TMenuItems.
  // Example:
  for I := 1 to 9 do
    aMenuItem[I].Caption := ExtractFileName(aRecentFile[I]);
end;
//----------------------------------------------------------------------
// You can also point ALL the OnClick events of the TMenuItems to just
// one procedure. F.i. the procedure below.
// The procedure finds out on which MenuItem is clicked, and opens the
// right file from the array with the recent filenames.
//----------------------------------------------------------------------

procedure TMainForm.FileLastFileClick(Sender: TObject);

var
  sFilename: string;
  I: Integer;
  sS: string;
  iErr: Integer;

begin
  // Assumes that the global string array aRecentFile[1..9] holds the
  // filenames of the recent file list, read during startup of the app.

  // Find out which one is clicked.
  // Get the name of the sender: FileLastFile1..FileLastFile9
  sS := (Sender as TComponent).Name;
  // Get the number at the end of the name of the sender, so you know
  // which one is clicked. Example:
  Val(sS[13], I, iErr);
  if iErr <> 0 then
  begin
    // sS[13] is an illegal character.
    Exit;
  end;

  // Now the variable "I" holds the number of the MenuItem, which was
  // clicked on.

  // Get the filename from the array of filenames and do something with
  // it. Example:
  sFileName := aRecentFile[I];
  if sFileName <> '' then
  begin

    if FileExists(sFileName) then
    begin
      // Open the file
      // Do your stuff
    end
    else
    begin
      // Something wrong! The file cannot be found.
      // Send a message. Example:
      // ShowMessage('Cannot find the requested file: ' + sFilename + '.');
      // Or grayout this MenuItem in the "File" menu. Example:
      // (Sender as TComponent).Enabled := False;
      // Or hide this MenuItem in the "File" menu. Example:
      // (Sender as TComponent).Hide;
    end;
  end;
end;
//----------------------------------------------------------------------

How to get the IP address for a given URL string and the URL string for a given IP address

Problem/Question/Abstract:

How to get the IP address for a given URL string and the URL string for a given IP address

Answer:

Maybe these functions will help you:

uses
  Winsock, { etc. }

function IpAddrToHostName(const sIP: string): string;
var
  I: Integer;
  P: PHostEnt;
begin
  Result := '';
  I := inet_addr(PChar(sIP));
  if I <> u_long(INADDR_NONE) then
  begin
    P := GetHostByAddr(@I, SizeOf(Integer), PF_INET);
    if P <> nil then
      Result := P^.h_name;
  end
  else
    Result := 'Invalid IP address';
end;

function HostNameToIpAddr(const sHost: string): string;
var
  P: PHostEnt;
  Ia: TInAddr;
begin
  Ia.S_addr := 0;
  P := gethostbyname(PChar(sHost));
  if P <> nil then
    with Ia.S_un_b, P^ do
    begin
      s_b1 := h_addr_list^[0];
      s_b2 := h_addr_list^[1];
      s_b3 := h_addr_list^[2];
      s_b4 := h_addr_list^[3];
    end;
  Result := inet_ntoa(ia);
end;

How to play sound from a resource file (2)

Problem/Question/Abstract:

How do I play an audio waveform from a memory buffer without writing to disk?

Answer:

procedure TFrmWaves.PlayTheSound(AName: PChar);
var
  resInfo: THandle;
  wavHdl: THandle;
  wavPtr: Pointer;
begin
  case RgrMethod.ItemIndex of
    0:
      begin
        resInfo := FindResource(HInstance, AName, RES_TYPE);
        if resInfo <> 0 then
        begin
          Label1.Caption := StrPas(AName);
          wavHdl := LoadResource(HInstance, resInfo);
          wavPtr := LockResource(wavHdl);
          sndPlaySound(wavPtr, SND_ASYNC or SND_MEMORY);
          if (wavHdl <> 0) then
          begin
            UnlockResource(wavHdl);
            FreeResource(wavHdl);
          end;
        end
        else
          Label1.Caption := StrPas(AName) + ': Not found';
      end;
    1: PlaySound(AName, HInstance, SND_RESOURCE);
  end;
end;

How to do case insensitive search with SQL

Problem/Question/Abstract:

Does anyone know how to do a SELECT WHERE statement where it covers all cases. Like, when a user types in 'new york' to search a city field, it finds all occurrences of the string, like 'NEW YORK', 'New York', 'new york', 'NeW yOrk', etc..

Answer:

SELECT * FROM MyTable
WHERE UPPER(City) = 'NEW YORK'

Using UPPER makes it impossible to use an index which may hurt performance.

How to drag and drop TPanels within a scrollbox to rearrange the order

Problem/Question/Abstract:

All I want to do is to allow the user to drag/ drop panels within a scrollbox to rearrange the order. They are initially created in alpha order by caption anf pointers stored in a stringlist. When the user moves one it is moved in the stringlist, the scrollbox is cleared (note: the panels cannot be freed because they contain info) and re-parented in stringlist sequence. If you do more than one move, the resulting sequence of the panels in the scrollbox seems completely random, and certainly bears no resemblance to the sequence in the stringlist! I have tried doing this by index up from and downto zero; neither works.

Answer:

All your trouble comes from using the alTop style for the panels. Simply set it to alNone and size and position the panels in code, using their SetBounds method.

procedure TForm1.FormCreate(Sender: TObject);
var
  iCount: integer;
  APanel: TPanel;
  y: Integer;
begin
  AStrList := TStringList.Create;
  y := 0;
  for iCount := 0 to 4 do
  begin
    APanel := TPanel.Create(Self);
    with APanel do
    begin
      Name := 'P' + IntToStr(iCount);
      Align := alNone;
      OnMouseDown := PanelMouseDown;
      OnDragOver := PanelDragOver;
      OnDragDrop := PanelDragDrop;
      SetBounds(0, y, scrollbox1.clientwidth, height);
      Inc(y, height);
    end;
    AStrList.AddObject(APanel.Caption, APanel);
  end;
  for iCount := 0 to (AStrList.Count - 1) do
    TPanel(AStrList.Objects[iCount]).Parent := ScrollBox1;
end;

procedure TForm1.PanelDragDrop(Sender, Source: TObject; X, Y: Integer);
var
  iFrom, iTo, iCount: integer;
begin
  iFrom := AStrList.IndexOfObject(TPanel(Sender));
  iTo := AStrList.IndexOfObject(TPanel(Source));
  AStrList.Move(iFrom, iTo);
  y := 0;
  for iCount := 0 to (AStrList.Count - 1) do
    with TPanel(AStrList.Objects[iCount]) do
    begin
      Top := y;
      Inc(y, Height);
    end;
end;

Moving Controls over the form

Problem/Question/Abstract:

How is it possiple to move an control over the form ?

Answer:

It's very simple - so don't try to write hundreds of lines to solve this problem

Just take a look at this small source-snip

All what we need to do is to override the dynamic MouseDown method of the TControl-BaseClass and fire an WM_SysCommand event with the magicKey $F012.

I hope this article is helpful for you

{-----------------------------------------------------------------------------

hEaDRoOm Development
29.10.2002

Unit Name: HREdit
Author:    Benjamin Benjamin Wittfoth
Purpose:
History:
-----------------------------------------------------------------------------}
unit HREdit;

interface

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

type
  THREdit = class(TEdit)
  private
    fDragable: Boolean;
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Dragable: Boolean read fDragable write fDragable;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('HEADROOM DEVELOPMENT', [THREdit]);
end;

{ THREdit }

constructor THREdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
end;

destructor THREdit.Destroy;
begin
  inherited;
end;

procedure THREdit.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
const
  SC_DragMove = $F012; // important key  !!
begin
  inherited;
  if assigned(onMouseDown) then
    OnMouseDown(self, Button, Shift, x, y);
  if fDragable then
  begin
    ReleaseCapture;
    (self as TControl).perform(WM_SysCommand, SC_DragMove, 0); // this is the key !
  end;
end;

end.

If you put then next line after ReleaseCapture; the object will even come to the front before moving it and not just after.

(self as TControl).BringToFront;

Cordinates of control. Simply use an Timer on your form - i know this is not elegant, but it works.

procedure TForm1.TimerTimer(Sender: TObject);
begin
  Edit1.text := inttostr(Edit1.Left) + '/' + inttostr(Edit1.top);
end;

InterBase: Error msg about file 'SAA.AAA'

Problem/Question/Abstract:

InterBase: Error msg about file 'SAA.AAA'

Answer:

The 'SAA.AAA' file is a temporary file used in processing a query.

A failure involving this file generally means that InterBase has run out of disk space processing the query.

(Remember that this will be a temporary file on the server, so the server is out of disk space, not your local machine!)

How to open a registry key for reading data without requesting write access

Problem/Question/Abstract:

How can an application open a registry key for reading data without requesting write access? TRegistry seems to open keys always for ReadWrite, which fails on WindowsNT if the user has no write permission on that key (which is the default for HKEY_LOCAL_MACHINE if the user is no Administrator). I want to write user independant registry data into HKEY_LOCAL_MACHINE during installation (which is supposed to be the standard according to the WIN API Help) and have the program, which is normally not run by an administrator, to read these data on startup.

Since everything in TRegistry is static - as always when I want to inherit from a VCL anchestor - I cannot simply write a descendant of TRegistry that overrides the OpenKey and GetKey methods. Do I have to patch the source or to copy and modify the whole TRegistry code or am I missing something obvious?

Answer:

Alternatively you can directly use the Win32API calls:


{Local. Read the registry for the given key}

function GetKeyValue(const key: string): string;
var
  hkey: THandle;
  buf: array[0..255] of Char;
  n: Longint;
begin
  Result := '';
  if regOpenKeyEx(HKEY_CLASSES_ROOT, @key[1], 0, KEY_READ, hKey) = ERROR_SUCCESS then
  begin
    n := 255;
    if regQueryValue(hKey, nil, buf, n) = ERROR_SUCCESS then
    begin
      Result := StrPas(buf);
    end;
    RegCloseKey(hkey);
  end
  else
    Result := '';
end;

{Local. Look through the Registry looking for the descriptions of the given extension.}

function GetDescription(Extension: string): string;
var
  intermediate: string;
begin
  {Get intermediate value}
  intermediate := GetKeyValue(Extension);
  if intermediate <> '' then
  begin
    {Look up definition for the full description}
    Result := GetKeyValue(intermediate);
  end
  else
    Result := '';
end;

{Local. Read the registry for the description of the given file extension.}

function getExtensionDescription(const extension: string): string;
var
  description: string;
begin
  {Try to get the description from the registry}
  description := GetDescription(extension);
  {Make sure we have a description to present to the user}
  if description = '' then
    description := extension + ' file';
  {Return the description to the caller}
  Result := description;
end;

How to programmatically shift focus to the next control

Problem/Question/Abstract:

How to programmatically shift focus to the next control

Answer:

To shift focus from one control to the next in the tab order without using the tab key, set the KeyPreview property of the parent form to True and drop the following into the OnKeyPress of the first control (and every control you want to "exit" with the [programmer specified] key).

if Key = chr(XXX) then
  SendMessage(form1.Handle, WM_NEXTDLGCTL, 0, 0);

XXX = the ASCII code of a Key (e.g. ENTER = 13)