TPicture and non-standard image file name extensions

Problem/Question/Abstract:

Can we use TPicture.LoadFromFile() for loading images while their file extension isn't recognized by TPicture? For example if BMP files have been renamed to *.img.

Answer:

If you know the format and it is indeed a bitmap then you can force it to work - see the first piece of code below.

You can even register your own extension with the second piece of code.

begin
  // force it to be treated as a bitmap:
  Image1.Picture.Bitmap.LoadFromFile('APicture.img');

  // register your IMG extension application-wide to be treated as a bitmap:
  Image1.Picture.RegisterFileFormat('img', 'Bitmap file', TBitmap);
  Image1.Picture.LoadFromFile('APicture.img');
end.

How to change the directory while a TOpenDialog is open

Problem/Question/Abstract:

I have created an extra TSpeedButton on my TOpenDialog and would like to change the active directory if the user clicks it. If I change the current directory, nothing happens.

Answer:

{ ... }
hDlg := GetForeGroundWindow;
repeat
  {Sending the path. Try until the dialog has received it}
  SendDlgItemMessage(hDlg, 1152, WM_SETTEXT, 0, Integer(PChar(sDir)));
  L := SendDlgItemMessage(hDlg, 1152, WM_GETTEXTLENGTH, 0, 0);
  Application.ProcessMessages;
  if Application.Terminated then
    Exit;
until
L <> 0;
{And now click OK}
SendMessage(hDlg, WM_COMMAND, 1 + BN_CLICKED * $10000, GetDlgItem(hDlg, 1));
{Clear}
SendDlgItemMessage(hDlg, 1152, WM_SETTEXT, 0, Integer(PChar('')));
{ ... }

Change the hint display delay

Problem/Question/Abstract:

How to change the hint display delay

Answer:

Solve 1:

I usually use a procedure like this, so it�ll calculate the needed time to display any hint:

procedure TDM.DoShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo:
  THintInfo);
begin
  CanShow := not ExibirHints;
    {Global variable the user configured to display the hint or not}
  HintInfo.HideTimeout := Length(HintStr) * 50;
    {Calculate the size of the string to wait a certain time}
end;


Solve 2:

Put a TApplicationEvents component and play with the OnShowHint event handler:

procedure TForm1.ApplicationEvents1ShowHint(var HintStr: string; var CanShow: Boolean;
  var HintInfo: THintInfo);
begin
  {Check here the HintInfo class, eg.
  if HintInfo.HintControl = MyControl then
    HintInfo.ReshowTimeout := ...
    HintInfo.HideTimeout := ... }
end;

Finding a substring in a TStrings

Problem/Question/Abstract:

How to find a substring in a TStrings

Answer:

The IndexOf function in TStrings is great because it lets you quickly get the index of Item that holds the string in question. Unfortunately, it doesn't work for sub-strings. In that case, I've put together a neat little function called IndexOfSubString where you pass in the TStrings descendant you want to search on and a search value, and it'll return the index. Check it out:

{Purpose  : Binary search algorithm for a
            TStrings object. Finds the first
            occurence of any substring within
            a TStrings object or descendant}

function IndexOfSubString(List: TStrings; SubString: string): Integer;
var
  I,
    LowIdx,
    HighIdx: Integer;
  Found: boolean;
begin
  Found := false;
  Result := -1;
  {This type of search uses the first half
   of the TStrings list, so initialize the
   LowIdx and HighIdx to the first and approximate
   half of the list, respectively.}
  LowIdx := 0;
  HighIdx := List.Count div 2;

  {Note that Found and the LowIdx are used
   as conditionals. It's obvious why Found
   is used, but less apparent why LowIdx is
   used instead of HighIdx. The reason for
   this is that the way I've set it up here,
   HighIdx will never exceed (List.Count - 2),
   whereas LowIdx can equal (List.Count - 1)
   by nature of the assignment
   if Found remains false after the for loop.}
  while not Found and (LowIdx < (List.Count - 1)) do
  begin
    for I := LowIdx to HighIdx do
      if (Pos(SubString, List[I]) > 0) and
        not Found then
      begin
        Found := true;
        Result := I;
      end;

    if not Found then
    begin
      LowIdx := HighIdx + 1;
      HighIdx := HighIdx + ((List.Count - HighIdx) div 2);
    end;
  end;
end;

How to detect if a point lies on a polyline

Problem/Question/Abstract:

I would like to know if a point is in a polyline (not polygon). Any code?

Answer:

The main procedure is called ExploreLine. In this procedure Fst and Lst may be two consecutively points in the polyline. Srch is the point searched.

{ ... }
const {global}
  BigM = 1000000;

function Pend(Pi, Pf: TPoint): Real;
begin
  if (Pf.X = Pi.X) then
    Result := BigM {for a vertical line}
  else
    Result := (Pf.Y - Pi.Y) / (Pf.X - Pi.X);
end;

function Dist(Pi, Pf: TPoint): Real;
begin
  Result := sqrt(sqr(Pi.Y - Pf.Y) + sqr(Pi.X - Pf.X))
end;

function CalcPoint(Pi, Pf: TPoint; d: Word): TPoint;
var
  k, m: Real; { k=d / (1 + m2)� }
begin
  m := Pend(Pi, Pf);
  k := d / (Sqrt(1 + Sqr(m)));
  if ((Pf.X - Pi.X) < 0) then
  begin
    Result.X := Pi.X - Round(k);
    Result.Y := Pi.Y - Round(m * k);
  end
  else
  begin
    Result.X := Pi.X + Round(k);
    Result.Y := Pi.Y + Round(m * k);
  end;
end;

function ExploreLine(Srch, Fst, Lst: TPoint): Boolean;
var
  p: Word;
  Any: TPoint;
  lim, dis: Real;
begin
  lim := Dist(Lst, Fst);
  p := 1;
  Any := Fst;
  repeat
    Result := TestPoint(Srch, Any);
    dis := Dist(Any, Fst);
    Any := CalcPoint(Fst, Lst, Rad * p);
    Inc(p);
  until
    (Result)rr(dis >= lim);
end;

How to display the value of a field in the hint of a TDBGrid

Problem/Question/Abstract:

Does someone have a code snippet showing how I can display a field value from the TDBGrid row where the mouse pointer has stayed long enough to invoke the hint?

Answer:

This is the way I would do it:

{ ... }
if not VarIsNull(table1['PARTNO']) then
  dbGrid1.hint := table1['PARTNO'];

I found that you have to check to see if there is data in the field before you use it, also you would need to convert to a string inttostr(table1['PARTNO']) if needed.

How to get a list of all subdirectories in the current folder

Problem/Question/Abstract:

How to get a list of all subdirectories in the current folder

Answer:

Enumerating all folders in a subfolder/ directory:

procedure EnumFolders(root: string; folders: TStrings);

  procedure Enum(dir: string);
  var
    SR: TSearchRec;
    ret: Integer;
  begin
    if dir[length(dir)] <> '\' then
      dir := dir + '\';
    ret := FindFirst(dir + '*.*', faDirectory, SR);
    if ret = 0 then
    try
      repeat
        if ((SR.Attr and faDirectory) < > 0) and (SR.Name <> '.') and
                                                 (SR.Name <> '..') then
        begin
          folders.add(dir + SR.Name);
          Enum(dir + SR.Name);
        end;
        ret := FindNext(SR);
      until
        ret <> 0;
    finally
      FindClose(SR)
    end;
  end;

begin
  Folders.Clear;
  if root < > emptyStr then
    Enum(root);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  EnumFolders('C:\windows', memo1.lines);
end;

How to tell when to time-out an application

Problem/Question/Abstract:

How can I determine that a user has been inactive for a certain length of time so that I may exit the application?

Answer:

This is an interesting question because it introduces one form of security for an application, and that is time- sensitive, user activity-based processing. This type of "awareness" in a program can usually be found in dialup programs (CompuServe, MSN), but they also reside in security log-ins, in which if a response is not made within a discrete period of time, the program will close and you'll have to start all over again.

In Delphi, this is pretty easy to implement. What you're about to see is not the prettiest solution in the world, but it works.

Here's how to implement user activity-based time-sensitivity in your programs:

1. In the main form of your application, set the KeyPreview property to True so the form will see keystrokes before any other components (you'll see why when you see the code for the OnKeyDown method). And in the FormCreate method, write the following code:

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

2. Drop a Timer component on the form and set its interval to 1000 milliseconds (the default).
3. Switch to the editor. Under the implementation section, declare the following const and var:

const
  MaxTimeOutValue = 300; {This is 300 seconds, or five minutes}
var
  TimeOut: Integer; {This will be incremented by the Timer}

4. Write the following procedure and declare in the private section of your form:

procedure TForm1.ResetTimeOut;
begin
  � TimeOut := 0;
end;

5. Open up the OnKeyDown method for your form and put the following code:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  ResetTimeOut;
end;

This calls ResetTheTimer which, in turn, resets the TimeOut variable to zero, then disables and re- enables the Timer. The reason we do form-level processing of the keystrokes is so that no matter which component the user is typing in, keystrokes are always picked up by the form. Otherwise, you'd have to add this code to every component, and if you have a lot on your form ... yikes! I'd rather not think about it

6. In the OnTimer event of the Timer, put the following code:

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Inc(TimeOut);
  if TimeOut = MaxTimeOutValue then
  begin
    Timer1.Enabled := False;
    Close;
  end;
end;

This increments the TimeOut variable and compares it against the MaxTimeOutValue. If TimeOut equals MaxTimeOutValue, the timer is disabled and Close is called.

So how does this all work?

When the user presses a key while the form is running, TimeOut is reset to 0. This means that if the user is constantly typing, there's no way TimeOut can ever reach MaxTimeOutValue. However, once the user stops typing, because the timer is always enabled, TimeOut will be incremented every second, and will eventually reach the value equivalent to MaxTimeOutValue.

This isn't pretty, but it works.

Set the level of transparency for a TForm

Problem/Question/Abstract:

I want to create a form that has some degree of transparency. I know that in Windows 2000 SDK there is a very good resource to do that (SetLayeredWindowAttributes), but this one is not implemented in Windows.pas. I tried to import directly from user32.dll, and I even could find the value for some constants (WS_EX_LAYERED) with non documented value (MS C++.net), but at the end, I got some weird messages of "invalid variant type conversion" when trying to use this function. Does somebody have any example written in Delphi using this function?

Answer:

Solve 1:

{ ... }
const
  WS_EX_LAYERED = $80000;
  LWA_COLORKEY = 1;
  LWA_ALPHA = 2;
type
  TSetLayeredWindowAttributes = function(
    hwnd: HWND; {handle to the layered window}
    crKey: TColor; {specifies the color key}
    bAlpha: byte; {value for the blend function}
    dwFlags: DWORD {action}
    ): BOOL; stdcall;

procedure TfBaseSplash.FormCreate(Sender: TObject);
var
  Info: TOSVersionInfo;
  F: TSetLayeredWindowAttributes;
begin
  inherited;
  Info.dwOSVersionInfoSize := SizeOf(Info);
  GetVersionEx(Info);
  if (Info.dwPlatformId = VER_PLATFORM_WIN32_NT) and (Info.dwMajorVersion >= 5) then
  begin
    F := GetProcAddress(GetModulehandle(user32), 'SetLayeredWindowAttributes');
    if Assigned(F) then
    begin
      SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle,
        GWL_EXSTYLE) or WS_EX_LAYERED);
      F(Handle, 0, Round(255 * 80 / 100), LWA_ALPHA);
    end;
  end;
end;


Solve 2:

Make sure you check that the OS supports it. Here's how I do it:

function ALLOWALPHA: Boolean;
type
  TSetLayeredWindowAttributes = function(hwnd: HWND; crKey: LongInt; bAlpha: Byte;
    dwFlags: LongInt): LongInt; stdcall;
var
  FhUser32: THandle;
  SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
begin
  AllowAlpha := False;
  FhUser32 := LoadLibrary('USER32.DLL');
  if FhUser32 <> 0 then
  begin
    @SetLayeredWindowAttributes := GetProcAddress(FhUser32,
      'SetLayeredWindowAttributes');
    if @SetLayeredWindowAttributes <> nil then
    begin
      FreeLibrary(FhUser32);
      Result := TRUE;
    end
    else
    begin
      FreeLibrary(FhUser32);
      Result := False;
    end;
  end;
end;

Creating a roll-up form

Problem/Question/Abstract:

How can I create a form that will roll up; that is, a form that when clicked will reduce its height to nothing but the title bar?

Answer:

I have seen a demo of a commercially available component in DCU form that does this and it's pretty slick. Because it's a component, the implementation is really nice. Just drop it in and you're off.

What I'm showing here does the pretty much the same thing, but is coded directly into the form. I did this because building a component would have required more event-handling code than I cared to perform. However, with Delphi 2.0's Object Repository, it's a very simple to add a form with this functionality into it and use it over and over again.

Let's look at the code, then discuss it:

unit testmain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, enhimage, StdCtrls, Printers, rollup, Buttons, ShellAPI;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    FOldHeight: Integer;
    procedure WMNCRButtonDown(var Msg: TWMNCRButtonDown); message WM_NCRBUTTONDOWN;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FOldHeight := ClientHeight;
end;

procedure TForm1.WMNCRButtonDown(var Msg: TWMNCRButtonDown);
var
  I: Integer;
begin
  if (Msg.HitTest = HTCAPTION) then
    if (ClientHeight = 0) then
    begin
      I := 0;
      while (I < FOldHeight) do
      begin
        I := I + 40;
        if (I > FOldHeight) then
          I := FOldHeight;
        ClientHeight := I;
        Application.ProcessMessages;
      end;
    end
    else
    begin
      FOldHeight := ClientHeight;
      I := ClientHeight;
      while (I > 0) do
      begin
        I := I - 40;
        if (I < 0) then
          I := 0;
        ClientHeight := I;
        Application.ProcessMessages;
      end;
    end;
end;

end.

First, by way of synopsis, the roll-up/down occurs in response to a WM_NCRBUTTONDOWN message firing off and the WMNCRButtonDown procedure handling the message, telling the window to roll up/down depending upon the height of the client area. WM_NCRBUTTONDOWN fires whenever the right mouse button is clicked in a "non-client" area, such as a border, menu or, for our purposes, the caption bar of a form. (The client area of a window is the area within the border where most of the interesting activity usually occurs. In general, the Windows API restricts application code to drawing only within the client area.)

Delphi encapsulates the WM_NCRBUTTONDOWN in a TWMNCRButtonDown type, which is actually an assignment from a TWMNCHitMessage type that has the following structure:

type
  TWMNCHitMessage = record
    Msg: Cardinal;
    HitTest: Integer;
    XCursor: SmallInt;
    YCursor: SmallInt;
    Result: Longint;
  end;

Table 1 below discusses the parameters of the TWMCHitMessage structure in more detail:

Table 1 - TWMNCHitMessage record fields

Parameter
Type
Description
Msg
Cardinal
Each Windows message has an integer value which is its assigned ID
HitTest
Integer
This is a constant value that is returned by an internal Windows callback function that specifies the area on window when the message fired. Look in the Win32 Developer's Reference under WM_NCRBUTTONDOWN for values of nHitTest. For our purposes, we'll use HTCAPTION as the test value.
XCursor
SmallInt
This is the X value of the cursor position relative to the top left corner of the window
YCursor
SmallInt
This is the Y value of the cursor position relative to the top left corner of the window
Result
LongInt
The result value of WM_NCRBUTTONDOWN. Should be 0 if the application handled the message.


Now that you know about the message, let's look more closely at the code.

It's easy to create message wrappers in Delphi to deal with messages that aren't handled by an object by default. Since a right-click on the title bar of a form isn't handled by default, I had to create a wrapper. The procedure procedure WMNCRButtonDown(var Msg : TWMNCRButtonDown); message WM_NCRBUTTONDOWN; is the wrapper I created. All that goes on in the procedure is the following:

If the value of the message's HitTest field is equal to HTCAPTION (which means a right-click on the caption bar) then,
If height of the form's client area is equal to 0 then

1. Roll the form down

else if the height of the form's client area is not equal to 0 then

1. Roll the form up

In order to make this work, I had to create a variable called FOldHeight and set its value at FormCreate whenever the form was to be rolled up. FOldHeight is used as a place for the form to remember what size it was before it was re-sized to 0. When a form is to be rolled up, FOldHeight is immediately set to the current ClientHeight, which means you can interactively set the form's size, and the function will always return the form's ClientHeight to what it was before you rolled it up.

So what use is this? Well, sometimes I don't want to iconize a window; I just want to get it out of the way so I can see what's underneath. Having the capability to roll a form up to its title bar makes it a lot easier to see underneath a window without iconizing it, then having to Alt-tab back to it. (If you are familiar with the Macintosh platform, the System 7.5 environment offers a very similar facility called a "window shade," and makes a roll-up sound when the shade goes up.)

On an ending note, my good friend and colleague, Peter Jagielski, gave me a challenge: to create the effect of imploding and exploding windows. About eight years ago, he wrote an article in the DB Advisor for doing exploding and imploding windows in Paradox for DOS. When he saw the code for this, he smugly said, "That's pretty slick, but can you do exploding and imploding windows like I did?" How could I pass up that challenge? So be on the lookout for an example of exploding and imploding windows in a future tip.

By the way, a big thanks goes to Keith Bartholomess of TeamBorland for turning me on to the WM_NCRBUTTONDOWN message. I wouldn't have been able to write the event code without Keith pointing this message out to me.

Convert a number to text

Problem/Question/Abstract:

How to convert a number to text?

Answer:

Here a code to covert a Number (Real) to string:

function RealToTxt(Amount: Real): string;
var
  Num: LongInt;
  Fracture: Integer;

  function Num2Str(Num: LongInt): string;
  const
    hundred = 100;
    thousand = 1000;
    million = 1000000;
    billion = 1000000000;
  begin
    if Num >= billion then
      if (Num mod billion) = 0 then
        Num2Str := Num2Str(Num div billion) + ' Billion'
      else
        Num2Str := Num2Str(Num div billion) + ' Billion ' +
          Num2Str(Num mod billion)
    else if Num >= million then
      if (Num mod million) = 0 then
        Num2Str := Num2Str(Num div million) + ' Million'
      else
        Num2Str := Num2Str(Num div million) + ' Million ' +
          Num2Str(Num mod million)
    else if Num >= thousand then
      if (Num mod thousand) = 0 then
        Num2Str := Num2Str(Num div thousand) + ' Thousand'
      else
        Num2Str := Num2Str(Num div thousand) + ' Thousand ' +
          Num2Str(Num mod thousand)
    else if Num >= hundred then
      if (Num mod hundred) = 0 then
        Num2Str := Num2Str(Num div hundred) + ' Hundred'
      else
        Num2Str := Num2Str(Num div hundred) + ' Hundred ' +
          Num2Str(Num mod hundred)
    else
      case (Num div 10) of
        6, 7, 9: if (Num mod 10) = 0 then
            Num2Str := Num2Str(Num div 10) + 'ty'
          else
            Num2Str := Num2Str(Num div 10) + 'ty-' +
              Num2Str(Num mod 10);
        8: if Num = 80 then
            Num2Str := 'Eighty'
          else
            Num2Str := 'Eighty-' + Num2Str(Num mod 10);
        5: if Num = 50 then
            Num2Str := 'Fifty'
          else
            Num2Str := 'Fifty-' + Num2Str(Num mod 10);
        4: if Num = 40 then
            Num2Str := 'Forty'
          else
            Num2Str := 'Forty-' + Num2Str(Num mod 10);
        3: if Num = 30 then
            Num2Str := 'Thirty'
          else
            Num2Str := 'Thirty-' + Num2Str(Num mod 10);
        2: if Num = 20 then
            Num2Str := 'Twenty'
          else
            Num2Str := 'Twenty-' + Num2Str(Num mod 10);
        0, 1: case Num of
            0: Num2Str := 'Zero';
            1: Num2Str := 'One';
            2: Num2Str := 'Two';
            3: Num2Str := 'Three';
            4: Num2Str := 'Four';
            5: Num2Str := 'Five';
            6: Num2Str := 'Six';
            7: Num2Str := 'Seven';
            8: Num2Str := 'Eight';
            9: Num2Str := 'Nine';
            10: Num2Str := 'Ten';
            11: Num2Str := 'Eleven';
            12: Num2Str := 'Twelve';
            13: Num2Str := 'Thirteen';
            14: Num2Str := 'Fourteen';
            15: Num2Str := 'Fifteen';
            16: Num2Str := 'Sixteen';
            17: Num2Str := 'Seventeen';
            18: Num2Str := 'Eightteen';
            19: Num2Str := 'Nineteen'
          end
      end
  end {Num2Str};

begin
  Num := Trunc(Amount);
  Fracture := Round(1000 * Frac(Amount));
  if Num > 0 then
    Result := Num2Str(Num) + ' and ';
  if Fracture > 0 then
    Result := Result + IntToStr(Fracture) + '/1000'
  else
    Result := Result + '000/1000';
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  form1.Caption := realtotxt(123);
end;

How to hide and show icons on the Windows Desktop

Problem/Question/Abstract:

I have seen code to hide the taskbar, but is there an API call or Delphi Code to hide the whole desktop except the applications you want to show?

Answer:

Not a single call, you would have to do an enumWindows and hide whatever windows you do not want to show. This hides and shows the icons on the desktop, for example:

procedure TForm1.Button1Click(Sender: TObject);
const
  b: Boolean = false;
var
  wnd: HWND;
begin
  wnd := FindWindow('progman', nil);
  if wnd <> 0 then
  begin
    if b then
      ShowWindow(wnd, SW_SHOW)
    else
      ShowWindow(wnd, SW_HIDE);
    b := not b;
  end
  else
    showmessage('Desktop not found');
end;

The Classes vs Object declaration

Problem/Question/Abstract:

99.9% (if not 100%) of the times we are using the Class declaration even when we do not need it.

Answer:

First of all lets clear what are the diffrences between the two type of declaration.

Class declaration is actully like the TObject object. There isn't any diffrence between the 2 declarations:

type
  TMyClass1 = class
    {.......}
  end;

and the second declaration:

type
  TMyClass2 = class(TObject)
    {         ....... }
  end;

If you will notice in delphi (in Delphi 3 and above) when you press on CTRL+Space you will find in the first declaration the same functions like the second declaration.

And if you will look in the delphi help file, you will find that Class word created for components !!!!

If you will declare this:

type
  TMyObject = object
    { ....... }
  end;

You will not find any function or property inside of it, if you did not declare of it.
In the Delphi help file, they are writing that the Object declaration can not receave any properties.

TheObject reserve word is very good for OOP of functions, like let say a CODEC (Encryption and Decryption) of the same thing, we can build it in OOP without the need of a component or a memory allocations (although we can).

How to get the printer margins

Problem/Question/Abstract:

Does anybody know how to get, programmatically, the location of the canvas on the piece of paper that emerges from the printer? i.e. the size of the top, left, right and bottom margins?

Answer:

procedure TPrtPvw.GetOffsetPrinter;
var
  pt: TPoint;
  tmpAncho, tmpAlto: longint;
begin
  Escape(hPrinter, GETPRINTINGOFFSET, 0, nil, @pt);
  gOffSetLeft := pt.X;
  gOffSetTop := pt.Y;
  Escape(hPrinter, GETPHYSPAGESIZE, 0, nil, @pt);
  tmpAncho := pt.X;
  tmpAlto := pt.Y;
  gOffSetRight := tmpAncho - gOffSetLeft - Printer.PageWidth;
  gOffSetBottom := tmpAlto - gOffSetTop - Printer.PageHeight;
end;

How to detect if a system is set to Large Font

Problem/Question/Abstract:

How to detect if a system is set to Large Font

Answer:

Returns True if small fonts are set, False if using Large Fonts:

function SmallFonts: boolean;
var
  DC: HDC;
begin
  DC := GetDC(0);
  {LOGPIXELSX will be 120, if large fonts are in use}
  result := (GetDeviceCaps(DC, LOGPIXELSX) = 96);
  ReleaseDC(0, DC);
end;

Change the Windows start button bitmap

Problem/Question/Abstract:

Change your windows start button image

Answer:

{ define Global vars }

var
  Form1: TForm1;
  StartButton: hWnd;
  OldBitmap: THandle;
  NewImage: TPicture;

  { put the Code in the OnCreate event of your form }

procedure TForm1.FormCreate(Sender: TObject);
begin
  NewImage := TPicture.create;
  NewImage.LoadFromFile('C:\Windows\Circles.BMP');
  StartButton := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil);
  OldBitmap := SendMessage(StartButton, BM_SetImage, 0, NewImage.Bitmap.Handle);
end;

{ OnDestroy-Event }

procedure TForm1.FormDestroy(Sender: TObject);
begin
  SendMessage(StartButton, BM_SetImage, 0, OldBitmap);
  NewImage.Free;
end;

Sending an email from Delphi using MAPI

Problem/Question/Abstract:

Sending an email from Delphi using MAPI

Answer:

If you do not want to rely on Outlook to send an email but you know that MAPI is installed, then you can also send mails with the following handy routine SendMailMAPI(). You need to add unit MAPI to your uses clause.

Note that MAPI is not always installed with Windows.

program MAPIMail;

uses
  MAPI;

function SendMailMAPI(const Subject, Body, FileName, SenderName, SenderEMail,
  RecepientName, RecepientEMail: string): Integer;
var
  message: TMapiMessage;
  lpSender,
    lpRecepient: TMapiRecipDesc;
  FileAttach: TMapiFileDesc;
  SM: TFNMapiSendMail;
  MAPIModule: HModule;
begin
  FillChar(message, SizeOf(message), 0);
  with message do
  begin
    if (Subject <> '') then
    begin
      lpszSubject := PChar(Subject)
    end;
    if (Body <> '') then
    begin
      lpszNoteText := PChar(Body)
    end;
    if (SenderEMail <> '') then
    begin
      lpSender.ulRecipClass := MAPI_ORIG;
      if (SenderName = '') then
      begin
        lpSender.lpszName := PChar(SenderEMail)
      end
      else
      begin
        lpSender.lpszName := PChar(SenderName)
      end;
      lpSender.lpszAddress := PChar('SMTP:' + SenderEMail);
      lpSender.ulReserved := 0;
      lpSender.ulEIDSize := 0;
      lpSender.lpEntryID := nil;
      lpOriginator := @lpSender;
    end;
    if (RecepientEMail <> '') then
    begin
      lpRecepient.ulRecipClass := MAPI_TO;
      if (RecepientName = '') then
      begin
        lpRecepient.lpszName := PChar(RecepientEMail)
      end
      else
      begin
        lpRecepient.lpszName := PChar(RecepientName)
      end;
      lpRecepient.lpszAddress := PChar('SMTP:' + RecepientEMail);
      lpRecepient.ulReserved := 0;
      lpRecepient.ulEIDSize := 0;
      lpRecepient.lpEntryID := nil;
      nRecipCount := 1;
      lpRecips := @lpRecepient;
    end
    else
    begin
      lpRecips := nil
    end;
    if (FileName = '') then
    begin
      nFileCount := 0;
      lpFiles := nil;
    end
    else
    begin
      FillChar(FileAttach, SizeOf(FileAttach), 0);
      FileAttach.nPosition := Cardinal($FFFFFFFF);
      FileAttach.lpszPathName := PChar(FileName);
      nFileCount := 1;
      lpFiles := @FileAttach;
    end;
  end;
  MAPIModule := LoadLibrary(PChar(MAPIDLL));
  if MAPIModule = 0 then
  begin
    Result := -1
  end
  else
  begin
    try
      @SM := GetProcAddress(MAPIModule, 'MAPISendMail');
      if @SM <> nil then
      begin
        Result := SM(0, Application.Handle, message, MAPI_DIALOG or
          MAPI_LOGON_UI, 0);
      end
      else
      begin
        Result := 1
      end;

    finally
      FreeLibrary(MAPIModule);
    end;
  end if Result <> 0 then
    begin
      MessageDlg('Error sending mail (' + IntToStr(Result) + ').', mtError, [mbOk],
        0)
    end;
end;

end.

Copy from the active control to the clipboard

Problem/Question/Abstract:

Copy from the active control to the clipboard

Answer:

Use the following piece of code for this.

Note: You may trigger the menu open event and enable/disable the copy/paste menu items depending on the type of control that is active.


procedure CopyButtonClick(Sender: TObject);
begin
  if ActiveControl is TMemo then
    TMemo(ActiveControl).CopyToClipboard;
  if ActiveControl is TDBMemo then
    TDBMemo(ActiveControl).CopyToClipboard;
  if ActiveControl is TEdit then
    TEdit(ActiveControl).CopyToClipboard;
  if ActiveControl is TDBedit then
    TDBedit(ActiveControl).CopyToClipboard;
end;

procedure PasteButtonClick(Sender: TObject);
begin
  if ActiveControl is TMemo then
    TMemo(ActiveControl).PasteFromClipboard;
  if ActiveControl is TDBMemo then
    TDBMemo(ActiveControl).PasteFromClipboard;
  if ActiveControl is TEdit then
    TEdit(ActiveControl).PasteFromClipboard;
  if ActiveControl is TDBedit then
    TDBedit(ActiveControl).PasteFromClipboard;
end;

Handle Excel through OLE Automation

Problem/Question/Abstract:

Handle Excel through OLE Automation

Answer:

The example below shows how to create and control an embedded Excel object. In case of Delphi 3, you need to use unit OleAuto, in Delphi 5 you have to use ComObj instead.

A good additional source is here.


uses
  OleAuto; // Delphi 3
  ComObj; // Delphi 5

var
  vExcel: variant;

procedure TForm1.Button1Click(Sender: TObject);
begin
  vExcel := CreateOleObject('Excel.Application');
  vExcel.Workbooks.Add;
  vExcel.ActiveWorkbook.Worksheets(1).Range('A1').Value := 'Hello World';
  vExcel.Visible := True;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if not VarIsEmpty(vExcel) then
    vExcel.Quit;
end;

Categories in the Object Inspector

Problem/Question/Abstract:

In Delphi 5 the object inspector allow us to view properties and events by categories. We can instruct Delphi which category the properties and events of our components belongs to and even to create our own categories.

Answer:

1. To instruct Delphi which category a property belongs to:
We have to do that in the Register procedure. The function RegisterPropertyInCategory has four overloaded versions. This is one of them. In this version we instruct Delphi to assign the property "Version" of our component "TMyButton" to the "TMiscellaneousCategory" standard category.

procedure Register;
begin
  RegisterComponents('Samples', [TMyButton]);
  RegisterPropertyInCategory(TMiscellaneousCategory, TMyButton, 'Version');
end;

Search Delphi help for more information about other overloaded versions of this function.

2.To create our own category:
We have to create a new class and derive it from TPropertyCategory or one of the existing categories (for example TMiscellaneousCategory). Then, we need to override the Name class function. The result value is the name shown by the object inspector.

interface

TMyCategory = class(TPropertyCategory)
public
  class function Name: string; override;
end;

implementation

class function TMyCategory.Name: string;
begin
  Result := 'My Category';
end;

Then we could use our new category.

procedure Register;
begin
  RegisterComponents('Samples', [TMyButton]);
  RegisterPropertyInCategory(TMyCategory, TMyButton, 'Version');
end;

You can also use RegisterPropertiesInCategory to register more than one property with one category at a time.

How to determine if a formatted disk is in a drive

Problem/Question/Abstract:

I am trying to create a backup-routine for one of my applications. For that purpose I need a routine to test if there is a formatted disk in the disk-drive.

Answer:

There are two routines in the Object Pascal Language that can be used to determine if a formatted diskette is in a drive, as both return the same results if there is not a diskette in the drive. "DiskFree" and "DiskSize". You need to disable Windows error handling before using them or else Windows will display an error window and cause the functions to return invalid results.


procedure TForm1.Button1Click(Sender: TObject);
var
  emode: word;
begin
  emode := SetErrorMode(SEM_FAILCRITICALERRORS);
  edit1.text := IntToStr(Diskfree(1));
  SetErrorMode(emode);
end;


If DiskFree returns "-1" then there is not a formatted diskette in the drive.

Convert color value into gray-scaled color value

Problem/Question/Abstract:

How can I convert the color value into gray-scaled value?

Answer:

If you want to convert a colored image into same gray scaled, then you must convert the color of the each pixel by the next schema:

function RgbToGray(Source: TColor): TColor;
var
  Target: Byte;
begin
  Target := Round((0.30 * GetRValue(Source)) +
    (0.59 * GetGValue(Source)) +
    (0.11 * GetBValue(Source)));
  Result := RGB(Target, Target, Target);
end;

How to add text completion capability to a TComboBox

Problem/Question/Abstract:

How to add text completion capability to a TComboBox

Answer:

Solve 1:

The Netscape Communicator location box, The Windows 98 'Run' dialog, and other programs, have implemented a very user friendly feature known commonly as text completion. This document describes how to add similar functionality to a TComboBox. The most elegant and reusable way to add this functionality is by descending from TComboBox and overriding the ComboWndProc to handle the WM_KEYUP message. By adding a new property 'TextCompletion', the functionality can be toggled to act like a regular TComboBox. Below is the component unit that implements text completion in a TComboBox. This unit can be installed as is.

unit CompletingComboBox;

interface

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

type
  TCompletingComboBox = class(TComboBox)
  private
    FTextCompletion: Boolean;
    function GetTextCompletion: Boolean;
    procedure SetTextCompletion(const Value: Boolean);
  protected
    {override the WndProc() so that we can trap KeyUp events}
    procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd;
      ComboProc: Pointer); override;
  public
    {Public declarations}
  published
    property TextCompletion: Boolean read GetTextCompletion write SetTextCompletion;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Standard', [TCompletingComboBox]);
end;

{TCompletingComboBox}

function TCompletingComboBox.GetTextCompletion: Boolean;
begin
  Result := fTextCompletion;
end;

procedure TCompletingComboBox.SetTextCompletion(const Value: Boolean);
begin
  fTextCompletion := Value;
end;

procedure TCompletingComboBox.ComboWndProc(var Message: TMessage;
  ComboWnd: HWnd; ComboProc: Pointer);
var
  rc, len: Integer;
begin
  inherited;
  case Message.Msg of
    WM_KEYUP:
      begin
        {test to see if its a character that should not be processed}
        if (Message.WParam <> 8) and (Message.WParam <> VK_DELETE) and
          (Message.WParam <> VK_SHIFT) and (FTextCompletion = True) then
        begin
          {Use CB_FINDSTRING to locate the string in the Items property}
          rc := Perform(CB_FINDSTRING, -1, Integer(PChar(Caption)));
          {if its in there then add the new string to the Text and select the portion that wasn't typed in by the user}
          if rc <> CB_ERR then
          begin
            {store the length of the current string}
            len := Length(Text);
            {set the new string}
            ItemIndex := rc;
            {highlight the rest of the text that was added}
            SelStart := len;
            SelLength := Length(Text) - len;
            {return 0 to signify that the message has been handled}
            Message.Result := 0;
          end;
        end;
      end;
  end;
end;

end.

Solve 2:

Performing autocompletion in a combobox:

procedure TForm1.ComboBox1Change(Sender: TObject);
var
  oldpos: Integer;
  item: Integer;
begin
  with Sender as TComboBox do
  begin
    oldpos := selstart;
    item := Perform(CB_FINDSTRING, -1, lparam(Pchar(text)));
    if item >= 0 then
    begin
      onchange := nil;
      text := items[item];
      selstart := oldpos;
      sellength := gettextlen - selstart;
      onchange := combobox1change;
    end;
  end;
end;

procedure TForm1.ComboBox1KeyPress(Sender: TObject; var Key: Char);
var
  oldlen: Integer;
begin
  if key = #8 then
    with sender as TComboBox do
    begin
      oldlen := sellength;
      if selstart > 0 then
      begin
        selstart := selstart - 1;
        sellength := oldlen + 1;
      end;
    end;
end;

Detect the full path and file name of where the DLL is running from?

Problem/Question/Abstract:

How can I detect (from a dynamic link library) the full path and file name of where the DLL is running from?

Answer:

The following example demonstrates a dll function that will detect the full path of where the dll was loaded from.

Example:

uses Windows;

procedure ShowDllPath stdcall;
var
  TheFileName: array[0..MAX_PATH] of char;
begin
  FillChar(TheFileName, sizeof(TheFileName), #0);
  GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName));
  MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok);
end;

Create a SystemDSN with Delphi-5

Problem/Question/Abstract:

How to create a ODBC SystemDSN with Delphi?

Answer:

This example shows one way to load the ODBC Administrator's DLL (ODBCCP32.DLL) to create an Access MDB file and ODBC DSN pointing at it.  Note that it assumes current directory for both the DLL and the MDB, but the DLL will be found if in the WinSys directory which  is where it normally is anyway.

Similar operation applies to most driver types, with some modifications. eg: Access requires the MDB file to exist so you can hook the DSN  to it.

Note also that the "CREATE_DB" call is an Access special (MS Jet Engine) and has other variants like COMPACT_DB and REPAIR_DB. For a full list see either the Jet Engine Programmers Guide or the MSDN and search for "CREATE_DB".

const
  ODBC_ADD_DSN = 1; // Add data source
  ODBC_CONFIG_DSN = 2; // Configure (edit) data source
  ODBC_REMOVE_DSN = 3; // Remove data source
  ODBC_ADD_SYS_DSN = 4; // add a system DSN
  ODBC_CONFIG_SYS_DSN = 5; // Configure a system DSN
  ODBC_REMOVE_SYS_DSN = 6; // remove a system DSN

type
  TSQLConfigDataSource = function(hwndParent: HWND;
    fRequest: WORD;
    lpszDriver: LPCSTR;
    lpszAttributes: LPCSTR): BOOL; stdcall;

procedure Form1.FormCreate(Sender: TObject);
var
  pFn: TSQLConfigDataSource;
  hLib: LongWord;
  strDriver: string;
  strHome: string;
  strAttr: string;
  strFile: string;
  fResult: BOOL;
  ModName: array[0..MAX_PATH] of Char;
  srInfo: TSearchRec;
begin
  Windows.GetModuleFileName(HInstance, ModName, SizeOf(ModName));
  strHome := ModName;
  while (strHome[length(strHome)] <> '\') do
    Delete(strHome, length(strHome), 1);
  strFile := strHome + 'TestData.MDB'; // Test Access Rights (Axes = Access)
  hLib := LoadLibrary('ODBCCP32'); // load from default path
  if (hLib <> NULL) then
  begin
    @pFn := GetProcAddress(hLib, 'SQLConfigDataSource');
    if (@pFn <> nil) then
    begin
      // force (re-)create DSN
      strDriver := 'Microsoft Access Driver (*.mdb)';
      strAttr := Format('DSN=TestDSN' + #0 +
        'DBQ=%s' + #0 +
        'Exclusive=1' + #0 +
        'Description=Test Data' + #0 + #0,
        [strFile]);
      fResult := pFn(0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1]);
      if (fResult = false) then
        ShowMessage('Create DSN (Datasource) failed!');

      // test/create MDB file associated with DSN
      if (FindFirst(strFile, 0, srInfo) <> 0) then
      begin
        strDriver := 'Microsoft Access Driver (*.mdb)';
        strAttr := Format('DSN=TestDSN' + #0 +
          'DBQ=%s' + #0 +
          'Exclusive=1' + #0 +
          'Description=Test Data' + #0 +
          'CREATE_DB="%s"'#0 + #0,
          [strFile, strFile]);
        fResult := pFn(0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1]);
        if (fResult = false) then
          ShowMessage('Create MDB (Database file) failed!');
      end;
      FindClose(srInfo);

    end;

    FreeLibrary(hLib);
  end
  else
  begin
    ShowMessage('Unable to load ODBCCP32.DLL');
  end;
end;

How to play a beep without consuming system ressources

Problem/Question/Abstract:

How can I play a beep without consuming system ressources? It's easy. Use the code below.

Answer:

procedure SpecialBeep;
asm
  mov al,7
  int 29h
end;

How to play a beep without consuming system ressources

Problem/Question/Abstract:

How can I play a beep without consuming system ressources? It's easy. Use the code below.

Answer:

procedure SpecialBeep;
asm
  mov al,7
  int 29h
end;

How to draw an underline on a Listview Caption

Problem/Question/Abstract:

Can you underline the caption of a ListView Item?

Answer:

To draw an Underline on a Listview Caption the same like the HotTrack function in Delphi 6 in Delphi 3 you must call an API function.

In the Uses Clausse inpelement the CommCtrl unit.

Then you set the following code in the MouseMove property of your ListView.


procedure TfrmMain.lvwMainMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
const
  LVS_EX_UNDERLINEHOT = $00000800;
  LVS_EX_INFOTIP = $00000400;
var
  AItem: TListItem;
  Styles: DWord;
begin
  //This line is a VCL Bugfix for the ListView
  Styles := LVS_EX_INFOTIP;
  AItem := lvwMain.GetItemAt(X, Y);
  if not Assigned(AItem) then
  begin
    lvwMain.Cursor := crArrow;
  end
  else
  begin
    lvwMain.Cursor := crHandPoint;
    Styles := Trunc(Styles + LVS_EX_UNDERLINEHOT - LVS_EX_CHECKBOXES -
      LVS_EX_FULLROWSELECT);
    ListView_SetExtendedListViewStyle(lvwMain.Handle, Styles);
  end;
end;


When you goes with your mouse over an ListView Item there will be an underline drawed under the caption of the Item.

Because the value that exists in the Styles variabele allso enables checkboxes and rowselect add the following lines under the Styles lines and above the SetExtendedListViewStyle.

Styles := Styles - LVS_EX_CHECKBOXES;
Styles := Styles - LVS_EX_TRACKSELECT;

This will fix the bug of the Checkboxes and TrackSelecting.

How to determine if a method is of type TNotifyEvent

Problem/Question/Abstract:

If I am given a TPersistent object, and a method name, is there a way to determine if the name is an event of TNotifyEvent type? For example, given a TPersistent lMyObj and an event name, "OnDataChanged", how can I determine if OnDataChanged is a TNotifyEvent?

Answer:

function IsNotifyEvent(Sender: TObject; const Event: string): Boolean;
var
  PropInfo: PPropInfo;
  Method: TNotifyEvent;
begin
  Result := False;
  PropInfo := GetPropInfo(Sender.ClassInfo, Event);
  if not Assigned(PropInfo) then
    Exit;
  if PropInfo.PropType^.Kind <> tkMethod then
    Exit;
  Method := TNotifyEvent(GetMethodProp(Sender, PropInfo));
  Result := Assigned(Method);
end;

Fastest way to search a string in a file

Problem/Question/Abstract:

Fastest way to search a string in a file

Answer:

The function below returns position of substring in file, or -1 if such substring can not be found.


function PosInFile(Str, FileName: string): integer;
var
  Buffer: array[0..1023] of char;
  BufPtr, BufEnd: integer;
  F: file;
  Index: integer;
  Increment: integer;
  c: char;

  function NextChar: char;
  begin
    if BufPtr >= BufEnd then
    begin
      BlockRead(F, Buffer, 1024, BufEnd);
      BufPtr := 0;
      Form1.ProgressBar1.Position := FilePos(F);
      Application.ProcessMessages;
    end;
    Result := Buffer[BufPtr];
    Inc(BufPtr);
  end;

begin
  Result := -1;
  AssignFile(F, FileName);
  Reset(F, 1);
  Form1.ProgressBar1.Max := FileSize(F);
  BufPtr := 0;
  BufEnd := 0;
  Index := 0;
  Increment := 1;
  repeat
    c := NextChar;
    if c = Str[Increment] then
      Inc(Increment)
    else
    begin
      Inc(Index, Increment);
      Increment := 1;
    end;
    if Increment = (Length(Str) + 1) then
    begin
      Result := Index;
      Break;
    end;
  until BufEnd = 0;
  CloseFile(F);
  Form1.ProgressBar1.Position := 0;
end;

Add database aliases to BDE at run time

Problem/Question/Abstract:

Add database aliases to BDE at run time

Answer:

This function that will let you add database aliases to BDE (Borland Database engine) during run time:

uses
  DBIProcs, DBITypes;

procedure AddBDEAlias(sAliasName, sAliasPath, sDBDriver: string);
var
  h: hDBISes;
begin
  DBIInit(nil);
  DBIStartSession('dummy', h, '');
  DBIAddAlias(nil, PChar(sAliasName), PChar(sDBDriver),
    PChar('PATH:' + sAliasPath), True);
  DBICloseSession(h);
  DBIExit;
end;

{ Sample call to create an alias called WORK_DATA that }
{ points to the C:\WORK\DATA directory and uses the    }
{ DBASE driver as the default database driver:         }

AddBDEAlias('WORK_DATA', 'C:\WORK\DATA', 'DBASE');