Check if a TForm has already been created

Problem/Question/Abstract:

How to check if a TForm has already been created

Answer:

Solve 1:

You just need to provide a little code to manage the lifetime of the form. Something like this (which assumes there should only ever be one instance of the TForm1 class):

interface

procedure ShowForm;
procedure CloseForm;

implementation

var
  Form: TForm1;

procedure ShowForm;
begin
  if (Form <> nil) then
    Form.Show
  else
  begin
    Form := TForm1.Create(Application);
    Form.Show;
  end;
end;

You can only check for nil the first time, because once you create and free the form it won't be nil again unless you make it nil in code!

procedure CloseForm;
begin
  Form.Free;
  Form := nil;
end;

Then simply call these help functions whenever you want to show or close the form.


Solve 2:

You can use the FindWindow API function, but for checking if a form has been created within an application, this is easier:

function IsFormCreated(Form: TCustomForm): Boolean;
var
  i: Integer;
begin
  Result := False;
  for i := 0 to Screen.FormCount - 1 do
  begin
    if Screen.Forms[i] = Form then
    begin
      Result := True;
      Break;
    end;
  end;
end;


Solve 3:

Know whether a form already exist before I dynamically create it

function IsFormOpen(const FormName: string): Boolean;
var
  i: Integer;
begin
  Result := False;
  for i := Screen.FormCount - 1 downto 0 do
    if (Screen.Forms[i].Name = FormName) then
    begin
      Result := True;
      Break;
    end;
end;

First check, if the Form (here Form2) is open. If not, create it.

procedure TForm1.Button1Click(Sender: TObject);
begin
  if not IsFormOpen('Form2') then
    Form2 := TForm2.Create(Self);

  Form2.Show
end;

{ For MDI Children }

function IsMDIChildOpen(const AFormName: TForm; const AMDIChildName: string): Boolean;
var
  i: Integer;
begin
  Result := False;
  for i := Pred(AFormName.MDIChildCount) downto 0 do
    if (AFormName.MDIChildren[i].Name = AMDIChildName) then
    begin
      Result := True;
      Break;
    end;
end;

First check, if the MDI Child is open. If not, create it.

procedure TForm1.Button2Click(Sender: TObject);
begin
  if not IsMDIChildOpen(Form1, 'MyMDIChild') then
    MyMDIChild := TMyMDIChild.Create(Self);
  MyMDIChild.Show;
  MyMDIChild.BringToFront;
end;

Convert a Unicode string to a normal string

Problem/Question/Abstract:

I have an application that reads data from a server via winsock. The data sent are in Unicode format and I need to parse out the constituent strings and display in a ListView. They are sent as C strings so the data looks like this: array of chars#0array of chars#0array of chars#0#0. Since the 'array of chars' is actually an array of widechars it also contains #0 bytes in the msb of the character. I tried StringReplace(Intext, #0, '', [rfReplaceAll]); but it does not convert, maybe it cannot go past the first #0 in the input string?

Answer:

Yes. What you need to do here is work with PWideChars. It would have helped, of course, to post a bit more specific information, e.g. what the type of Intext is. Anyway, all you need is a way to get the address of the first widechar in the data. Assuming intext is a String (even though it contains widechars) the process would look like this:

procedure SplitServerWidecharList(const intext: string; list: TStrings);
var
  p: PWideChar;
begin
  Assert(Assigned(list));
  list.Clear;
  if intext <> '' then
  begin
    p := PWideChar(@intext[1]); {points to first widechar}
    while p^ <> #0000 do
    begin
      {Convert this widestring to Ansi and store it}
      list.add(WidecharToString(p));
      {Find end of this widestring}
      while p^ <> #0000 do
        Inc(p);
      {Hop to start of the next one  }
      Inc(p);
    end;
  end;
end;

Can you be sure of the byte order of the received Unicode characters? The code above assumes little-endian byte order, if the data comes in in big-endian byte order you would have to swap the bytes in every widechar before you could process it as above.

Find how many (or is) users are connected to Access DB

Problem/Question/Abstract:

How to find how many (or is) users are connected to Access DB

Answer:

You can do it by using ADO components. Put TADOConnection and TADODataSet components on the form and name it ADOConnection1 and ADODataSet1. Information about users will be handle in ADODataSet1 then ADOConnection1 become active. More about ADO schemas you can find in MSDN.

ADOConnection1.OpenSchema(siProviderSpecific, emptyParam,
  '{947bb102-5d43-11d1-bdbf-00c04fb92675}', ADODataSet1);

Simple way to rotate region

Problem/Question/Abstract:

Simple function returning rotated region. Pprocedure doing the same with source region.

Answer:

It's the simple function returning new region rotated to the angle that you want around the source region. Source region doesn't change.

The second procedure does the same with source region without creating new region.

I hope this will be useful.
Comments are provided along the code

function _RotateRgn(ARgn: HRGN; ADegree: Real): HRGN;
var
  wXFORM: XFORM; // transformation structure, see Windows API
  kRgnD: DWord; // count of RGNDATA structures in region
  RgnData: PRgnData; // pointer to region data
  Rt: TRect;
  kX, kY: Integer;
begin
  if (ARgn = 0) or (ADegree = 0) then
    Exit;

  // Get region's surrounding rectangular
  GetRgnBox(ARgn, Rt);

  // Move source region so that the centre of its surrounding rectangular
  // goes to the left top corner of a window
  kX := Rt.Left + (Rt.Right - Rt.Left) div 2;
  kY := Rt.Top + (Rt.Bottom - Rt.Top) div 2;
  OffsetRgn(ARgn, -kX, -kY);

  // Fill XFORM according to task (rotate region)
  FillChar(wXFORM, SizeOf(wXFORM), #0);
  wXFORM.eM11 := Cos(ADegree / 180 * pi);
  wXFORM.eM12 := -Sin(ADegree / 180 * pi);
  wXFORM.eM21 := -wXFORM.eM12;
  wXFORM.eM22 := wXFORM.eM11;

  // Prepare buffer to store region data
  kRgnD := GetRegionData(ARgn, 0, nil);
  GetMem(RgnData, SizeOf(RGNDATA) * kRgnD);
  // ..and fill the buffer with region's data
  GetRegionData(ARgn, kRgnD, RgnData);
  // ..move source region to its initial position
  OffsetRgn(ARgn, kX, kY);

  // Create output region using data in the buffer and transformation wXFORM
  Result := ExtCreateRegion(@wXFORM, kRgnD, RgnData^);
  // Move output region on a place of source region
  OffsetRgn(Result, kX, kY);
  FreeMem(RgnData);
end;

procedure _RotateRgnEx(var ARgn: HRGN; ADegree: Real);
var
  wXFORM: XFORM; // transformation structure, see Windows API
  kRgnD: DWord; // count of RGNDATA structures in region
  RgnData: PRgnData; // pointer to region data
  Rt: TRect;
  kX, kY: Integer;
begin
  if (ARgn = 0) or (ADegree = 0) then
    Exit;

  // Get region's surrounding rectangular
  GetRgnBox(ARgn, Rt);

  // Move source region so that the centre of its surrounding rectangular
  // goes to the left top corner of a window
  kX := Rt.Left + (Rt.Right - Rt.Left) div 2;
  kY := Rt.Top + (Rt.Bottom - Rt.Top) div 2;
  OffsetRgn(ARgn, -kX, -kY);

  // Fill XFORM according to task (rotate region)
  FillChar(wXFORM, SizeOf(wXFORM), #0);
  wXFORM.eM11 := Cos(ADegree / 180 * pi);
  wXFORM.eM12 := -Sin(ADegree / 180 * pi);
  wXFORM.eM21 := -wXFORM.eM12;
  wXFORM.eM22 := wXFORM.eM11;

  // Prepare buffer to store region data
  kRgnD := GetRegionData(ARgn, 0, nil);
  GetMem(RgnData, SizeOf(RGNDATA) * kRgnD);
  // ..and fill the buffer with region's data
  GetRegionData(ARgn, kRgnD, RgnData);
  // ..delete source region
  DeleteObject(ARgn);

  // Create new region using data in the buffer and transformation wXFORM
  ARgn := ExtCreateRegion(@wXFORM, kRgnD, RgnData^);
  // Move output region to the origin place
  OffsetRgn(ARgn, kX, kY);
  FreeMem(RgnData);
end;

CNPJ and CPF Validation

Problem/Question/Abstract:

How to validade CNPJ or CPF

Answer:

In Brazil every people has a ID called CPF(Cadastro de pessoa fisica) and every company has a ID called CNPJ(Cadastro nacional de pessoa juridica). Some times we need to validate those IDs.

//Validade CPF

function ChkCPF(const cCPF: string): boolean;
  function LimpaString(const StrNumerica: string): string;
  var
    i: integer;
    valor: string;
  begin
    valor := StrNumerica;
    for i := 1 to length(valor) do
      if not (valor[i] in ['0'..'9']) then
        Delete(valor, i, 1);
    LimpaString := valor;
  end;

  function CharToInt(cNum: char): integer;
  begin
    CharToInt := Ord(cNum) - 48;
  end;

  function DigiSum(N: integer): integer;
  var
    value: integer;
  begin
    value := N mod 10 + N div 10;
    if value >= 10 then
      value := DigiSum(value);
    DigiSum := value;
  end;
var
  i, soma, multiplo: integer;
  CPF: string;
begin
  ChkCPF := false;
  CPF := LimpaString(cCPF);
  if Length(CPF) <> 11 then
    exit;
  soma := 0;
  for i := 9 downto 1 do
  begin
    soma := soma + CharToInt(CPF[i]) * (11 - i);
  end;
  multiplo := soma mod 11;
  if multiplo <= 1 then
    multiplo := 0
  else
    multiplo := 11 - multiplo;
  if (multiplo <> CharToInt(CPF[10])) then
    exit;
  soma := 0;
  for i := 10 downto 1 do
  begin
    soma := soma + CharToInt(CPF[i]) * (12 - i);
  end;
  multiplo := soma mod 11;
  if multiplo <= 1 then
    multiplo := 11;
  ChkCPF := CharToInt(CPF[11]) = (11 - multiplo);
end;

//Validade CNPJ

function ChkCNPJ(const cCNPJ: string): boolean;
  function LimpaString(const StrNumerica: string): string;
  var
    i: integer;
    valor: string;
  begin
    valor := StrNumerica;
    for i := 1 to length(valor) do
      if not (valor[i] in ['0'..'9']) then
        Delete(valor, i, 1);
    LimpaString := valor;
  end;

  function CharToInt(cNum: char): integer;
  begin
    CharToInt := Ord(cNum) - 48;
  end;

  function DigiSum(N: integer): integer;
  var
    value: integer;
  begin
    value := N mod 10 + N div 10;
    if value >= 10 then
      value := DigiSum(value);
    DigiSum := value;
  end;
var
  i, soma, mult: integer;
  CGC: string;
begin
  ChkCNPJ := false;
  CGC := LimpaString(cCNPJ);
  if Length(CGC) <> 14 then
    exit;
  soma := 0;
  mult := 2;
  for i := 12 downto 1 do
  begin
    soma := soma + CharToInt(CGC[i]) * mult;
    mult := mult + 1;
    if mult > 9 then
      mult := 2;
  end;
  mult := soma mod 11;
  if mult <= 1 then
    mult := 0
  else
    mult := 11 - mult;
  if mult <> CharToInt(CGC[13]) then
    exit;
  soma := 0;
  mult := 2;
  for i := 13 downto 1 do
  begin
    soma := soma + CharToInt(CGC[i]) * mult;
    mult := mult + 1;
    if mult > 9 then
      mult := 2;
  end;
  mult := soma mod 11;
  if mult <= 1 then
    mult := 0
  else
    mult := 11 - mult;
  ChkCNPJ := mult = CharToInt(CGC[14]);
end;

Check if the mouse pointer is over or close to a line on a TCanvas

Problem/Question/Abstract:

I am painting a line on a canvas with LineTo. How can I determine if the mouse pointer is over that line or not.

Answer:

This will give you the distance to the line and you can decide in your code how close (in pixels) you want the user to be to the line before selecting it. It takes into account the end points as well, so when the user is past the end points on the extension of the line it is not triggered.

MinDistPointLine calculates the minimum distance of a point to a line. P is the point, the line is between points A and B. It is based on the distance of P to the parametrised point Q = (1 - q) A + qB where 0 <= q <= 1. The distance PQ is sqrt(((1 - q) Ax + qBx - Px)^2 + (... Y term) ). Differentiating gives dPQ / dq = 2((Bx - Ax) q + (Ax - Px))(Bx - Ax) + (... Y term). dPQ / dq must be zero for minimum so q = (Px - Ax)(Bx - Ax) + (Py - Ay)(By - Ay) / ((Bx - Ax)^2 + (By - Ay)^2)

function MinDistPointLine(Px, Py, Ax, Ay, Bx, By: double): double;

implementation

function PointToPointDist(Ax, Ay, Bx, By: double): double;
begin
  Result := sqrt(sqr(Bx - Ax) + sqr(By - Ay));
end;

function MinDistPointLine(Px, Py, Ax, Ay, Bx, By: double): double;
var
  q: double;
begin
  if (Ax = Bx) and (Ay = By) then
  begin
    {Point to point}
    Result := PointToPointDist(Px, Py, Ax, Ay);
  end
  else
  begin
    {Minimum}
    q := ((Px - Ax) * (Bx - Ax) + (Py - Ay) * (By - Ay)) / (sqr(Bx - Ax) + sqr(By - Ay));
    {Limit q to 0 <= q <= 1}
    if q < 0 then
      q := 0;
    if q > 1 then
      q := 1;
    {Distance}
    Result := PointToPointDist(Px, Py, (1 - q) * Ax + q * Bx, (1 - q) * Ay + q * By);
  end;
end;

How to connect or disconnect all tables in a datamodule

Problem/Question/Abstract:

How to connect or disconnect all tables in a datamodule

Answer:

This should work:

for i := 0 to pred(components.count) do
  if (components[i] is TDataSet) then
    (components[i] as TDataSet).Active := not (components[i] as TDataSet).Active;

Disable hints in a TTreeView

Problem/Question/Abstract:

How to disable hints in a TTreeView

Answer:

Solve 1:

If you have installed the Internet Explorer 4.0 or high, in TTreeView component always displaying a hint for cutted items. It's useful but sometimes prevents and irritates (at least, me).

But there is a simple way to switch off this feature:

const
  TVS_NOTOOLTIPS = $0080;
begin
  SetWindowLong(yourTreeView.Handle, GWL_STYLE,
    GetWindowLong(yourTreeView.Handle, GWL_STYLE) xor TVS_NOTOOLTIPS);
end;


Solve 2:

const
  {Treeview has no standard way of disabling tooltips}
  TVS_NOTOOLTIPS = $00000080;
  TVS_UNDERLINE = $00000200;

{Disable the hint window of the treeview, Underline items}
SetWindowLong(tvApplications.Handle, GWL_STYLE, GetWindowLong(tvApplications.Handle,
  GWL_STYLE) or TVS_NOTOOLTIPS or TVS_UNDERLINE);

How to Backup and Restore the content of a TreeView

Problem/Question/Abstract:

How can I backup (save) and the restore (load) the content of my TreeView to a file?

Answer:

Use the following two procedures to Backup and Restore the content of your TreeView:

procedure TForm1.BackupTreeView(MyTree: TTReeView; ToFile: string);
begin
  with TFileStream.Create(ToFile, fmCreate) do
  try
    WriteComponent(MyTree);
  finally
    Free;
  end;
end;

procedure TForm1.RestoreTreeView(MyTree: TTReeView; FromFile: string);
begin
  with TFileStream.Create(FromFile, fmOpenRead) do
  try
    MyTree.Clear;
    ReadComponent(MyTree);
  finally
    Free;
  end;

end;

This approach will not keep any data associated with the nodes, you need take care about that separately. The only thing it will do is preserve the tree structure and node names. You also will not be able to restore the treeview to any other component than original one (say to the other form) without risking to screw up everything.

How to determine the size of an executable from its exe header

Problem/Question/Abstract:

How to determine the size of an executable from its exe header

Answer:

This code does not work with 16 bit executables. It assumes that the application is trying to find the size of itself, but could easily be modified to find the size of any 32bit exe loaded into a stream.

{$IFDEF VER100}

{TImageDosHeader isn't defined in Delphi 3 so here's an an abbreviated structure definition}
type
  PImageDosHeader = ^TImageDosHeader;
  TImageDosHeader = packed record
    e_ignore: packed array[0..29] of WORD;
    _lfanew: Longint;
  end;

{$ENDIF}

function GetExeSize: cardinal;
var
  p: PChar;
  i, NumSections: integer;
begin
  result := 0;
  {hInstance is actually a pointer to the exe's image base in memory}
  p := pointer(hinstance);
  inc(p, PImageDosHeader(p)._lfanew);
  inc(p, sizeof(dword));
  NumSections := PImageFileHeader(p).NumberOfSections;
  inc(p, sizeof(TImageFileHeader) + sizeof(TImageOptionalHeader));
  for i := 1 to NumSections do
  begin
    with PImageSectionHeader(p)^ do
      if PointerToRawData + SizeOfRawData > result then
        result := PointerToRawData + SizeOfRawData;
    inc(p, sizeof(TImageSectionHeader));
  end;
end;

How to remove a menu or submenu at runtime

Problem/Question/Abstract:

How to remove a menu or submenu at runtime

Answer:

Try these two procedures, i.e. RemoveMenu(form1.handle, 0) to remove the first menu:


procedure RemoveMenu(hwndMain: THandle; MenuIndex: Integer);
var
  h: HMenu;
begin
  h := GetMenu(hwndMain);
  if h > 0 then
    DeleteMenu(h, MenuIndex, MF_BYPOSITION);
end;

procedure RemoveSubmenu(hwndMain: THandle; MenuIndex, SubmenuIndex: Integer);
var
  h: HMenu;
begin
  h := GetMenu(hwndMain);
  if h > 0 then
    DeleteMenu(GetSubmenu(h, MenuIndex), SubmenuIndex, MF_BYPOSITION);
end;

How to allow only one instance of an application

Problem/Question/Abstract:

I use Delphi 6 to make an application. Everytime I run the executable, an instance of my application starts up (of course). Is there any way to detect at runtime if another instance of the same application is running and switch control to the original window instead of making a new one?

Answer:

Solve 1:

Include the following unit in your code:

unit MultInst;

interface

const
  MI_QUERYWINDOWHANDLE = 1;
  MI_RESPONDWINDOWHANDLE = 2;
  MI_ERROR_NONE = 0;
  MI_ERROR_FAILSUBCLASS = 1;
  MI_ERROR_CREATINGMUTEX = 2;

  {Call this function to determine if error occurred in startup. Value will be one or
  more of the MI_ERROR_* error flags.}

function GetMIError: Integer;

implementation

uses
  Forms, Windows, SysUtils;

const
  UniqueAppStr = 'DDG.I_am_the_Eggman!';

var
  MessageId: Integer;
  WProc: TFNWndProc;
  MutHandle: THandle;
  MIError: Integer;

function GetMIError: Integer;
begin
  Result := MIError;
end;

function NewWndProc(Handle: HWND; Msg: Integer; wParam, lParam: Longint): Longint;
  stdcall;
begin
  Result := 0;
  {If this is the registered message...}
  if Msg = MessageID then
  begin
    case wParam of
      MI_QUERYWINDOWHANDLE:
        {A new instance is asking for main window handle in order to focus the
                                main window, so normalize app and send back message with main window handle.}
        begin
          if IsIconic(Application.Handle) then
          begin
            Application.MainForm.WindowState := wsNormal;
            Application.Restore;
          end;
          PostMessage(HWND(lParam), MessageID, MI_RESPONDWINDOWHANDLE,
            Application.MainForm.Handle);
        end;
      MI_RESPONDWINDOWHANDLE:
        {The running instance has returned its main window handle, so we need to
                          focus it and go away.}
        begin
          SetForegroundWindow(HWND(lParam));
          Application.Terminate;
        end;
    end;
  end
    {Otherwise, pass message on to old window procedure}
  else
    Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam);
end;

procedure SubClassApplication;
begin
  {We subclass Application window procedure so that Application.OnMessage
  remains available for user.}
  WProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC,
    Longint(@NewWndProc)));
  {Set appropriate error flag if error condition occurred}
  if WProc = nil then
    MIError := MIError or MI_ERROR_FAILSUBCLASS;
end;

procedure DoFirstInstance;
{This is called only for the first instance of the application}
begin
  {Create the mutex with the (hopefully) unique string}
  MutHandle := CreateMutex(nil, False, UniqueAppStr);
  if MutHandle = 0 then
    MIError := MIError or MI_ERROR_CREATINGMUTEX;
end;

procedure BroadcastFocusMessage;
{This is called when there is already an instance running.}
var
  BSMRecipients: DWORD;
begin
  {Prevent main form from flashing}
  Application.ShowMainForm := False;
  {Post message to try to establish a dialogue with previous instance}
  BSMRecipients := BSM_APPLICATIONS;
  BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE,
    @BSMRecipients, MessageID, MI_QUERYWINDOWHANDLE, Application.Handle);
end;

procedure InitInstance;
begin
  SubClassApplication; {hook application message loop}
  MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);
  if MutHandle = 0 then
    {Mutex object has not yet been created, meaning that no previous instance
                has been created.}
    DoFirstInstance
  else
    BroadcastFocusMessage;
end;

initialization
  MessageID := RegisterWindowMessage(UniqueAppStr);
  InitInstance;
finalization
  {Restore old application window procedure}
  if WProc <> nil then
    SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc));
  if MutHandle <> 0 then
    CloseHandle(MutHandle); {Free mutex}
end.


Solve 2:

The simplest way to do this is to make the following changes to your dpr where TForm1 is the name of your main form.

program Project1;

uses
  Forms, Windows, Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

begin
  if FindWindow('TForm1', nil) <> 0 then
  begin
    SetForegroundWindow(FindWindow('TForm1', nil));
    Exit;
  end;
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Making Secondary Forms Independent of the Main Form

Problem/Question/Abstract:

In my application, I want to be able to iconize the main form and still leave the secondary forms displaying on the desktop. Likewise, I want to be able to select secondary forms without the main form popping up. How can I do this?

Answer:

Recently a user asked me about this, and I had to do a bit of experimentation before I finally figured it out. And the solution to this problem is actually so simple, you'll scream (actually, I did all the screaming myself). But it's not something that's necessarily easy to find out nor intuitive (maybe it is for some, but it wasn't for me). But before I give you the solution, let's discuss the concept that's behind it.

All windowed controls have a parent of some sort; that is, some control that maintains visual control (ie. display) over it. Main forms of an application all point to the Application as their parent. Likewise, by default, secondary forms point to the main form of the application for parentage. But the neat thing about creating windowed objects in Delphi (though you need to be careful with some controls) is that you can change the parentage of a control to isolate its visual control, essentially giving it independence from its default parent. Okay, so how do you do it? You might think that you can reset parentage at FormCreate, but that's not the right place to do it. The only way to do this is before the window gets created in the first place, and that place is in the CreateParams procedure.

I've discussed CreateParams in previous articles, so I won't go into details about it, though I will brush over what it does. CreateParams is an inherited procedure that wraps the WinAPI functions CreateWindow and CreateWindowEx that are responsible for a window's initial appearance. It's a convenient way to set display parameters. With it, we can change the a variable parameter called Params that is a TCreateParams structure (you should look this structure up in the online help) to affect a number of different things about a form. One of the fields in the TCreateParams structure is WndParent. This parameter specifies the handle of the window that controls the display of the window being created. By changing this parameter to point another window handle (hint, hint), we can change the default parentage.

So now it's a matter of deciding what window is going to be the secondary form's new parent. In this case, whenever we want to make a secondary form independent of the main form, we're essentially turning it into its own mini-application without creating a new EXE. So it's best to choose a parent that's at the highest order in the system. That window is Windows' Desktop Window. Fortunately we have a way of getting its handle by using the WinAPI call GetDesktopWindow, which returns the handle of the Desktop.

Okay, we've covered all the bases. Now you're going to kill me for belaboring the point. Here's the code:

unit Unit2;

interface

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

type
  TForm2 = class(TForm)
  private
    { Private declarations }
    //override the CreateParams procedure for any child forms you want to
    //make independent of the main form
    procedure CreateParams(var Params: TCreateParams); override;
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

implementation

{$R *.DFM}

//Here's the implementation of CreateParams

procedure TForm2.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params); //Don't ever forget to do this!!!
  Params.WndParent := GetDesktopWindow;
end;

end.

Insanely simple, huh? Sorry I took so long to lead up to it, but while the solution was simple, I just couldn't get away from explaining at least a bit of background information to help those who aren't familiar with the internal workings of the WinAPI. In any case, HAVE AT IT!!!

Shutdown, Reboot, Logoff, Monitor Off and Suspend mode functions

Problem/Question/Abstract:

The way to make your computer to sleep, reboot or shutdown. It also have the code to force shutdown and force reboot. To try this example you need seven buttons. The Suspend Mode is a magic sendkey that I triped over and it force the computer in to suspend mode.

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    btnShutDown: TButton;
    btnReboot: TButton;
    btnLogOff: TButton;
    btnForceDown: TButton;
    btnForceReboot: TButton;
    btnMonitorOff: TButton;
    btnSuspend: TButton;
    procedure btnLogOffClick(Sender: TObject);
    procedure btnShutDownClick(Sender: TObject);
    procedure btnRebootClick(Sender: TObject);
    procedure btnForceDownClick(Sender: TObject);
    procedure btnForceRebootClick(Sender: TObject);
    procedure TimerEx1Timer(Sender: TObject);
    procedure btnMonitorOffClick(Sender: TObject);
    procedure btnSuspendClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.btnLogOffClick(Sender: TObject);
begin
  if ExitWindowsEx(EWX_LOGOFF, 1) = False then
    ShowMessage('Uable to comply !');
end;

procedure TForm1.btnShutDownClick(Sender: TObject);
begin
  if ExitWindowsEx(EWX_SHUTDOWN, 1) = False then
    ShowMessage('Uable to comply !');
end;

procedure TForm1.btnRebootClick(Sender: TObject);
begin
  if ExitWindowsEx(EWX_REBOOT, 1) = False then
    ShowMessage('Uable to comply !');
end;

procedure TForm1.btnForceDownClick(Sender: TObject);
begin
  if ExitWindowsEx(EWX_SHUTDOWN + EWX_FORCE, 1) = False then
    ShowMessage('Uable to comply !');
end;

procedure TForm1.btnForceRebootClick(Sender: TObject);
begin
  if ExitWindowsEx(EWX_REBOOT + EWX_FORCE, 1) = False then
    ShowMessage('Uable to comply !');
end;

procedure TForm1.TimerEx1Timer(Sender: TObject);
begin
  if ExitWindowsEx(EWX_SHUTDOWN + EWX_FORCE, 1) = False then
    ShowMessage('Uable to comply !');
end;

procedure TForm1.btnMonitorOffClick(Sender: TObject);
begin
  SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);
end;

procedure TForm1.btnSuspendClick(Sender: TObject);
begin
  Keybd_event(8, 0, 0, 0); //I don't remember what I was doing when I found this.
  Keybd_event(95, 0, 0, 0);
end;

end.

How to place a TComboBox on the Windows Taskbar

Problem/Question/Abstract:

How to place a TComboBox on the Windows Taskbar

Answer:

FindWindow('Shell_TrayWnd', nil) will get you the handle of the taskbar, you can then use this handle to manipulate the taskbar. For example, to move a combobox1 to the taskbar do:

{ ... }
Combobox1.Left := 0;
Windows.SetParent(Combobox1.Handle, FindWindow('Shell_TrayWnd', nil));
{ ... }

Opening and Closing a CD Tray

Problem/Question/Abstract:

How can I open and close the tray on a CD-ROM drive?

Answer:

Most of you are probably familiar with the TMediaPlayer component. It's a nice multi-purpose component for multimedia. But it has one failing and that is its inability to close a CD-ROM drive tray if it's open. And unfortunately for us, there's no way to manipulate methods or properties of TMediaPlayer to enable this functionality. So what we have to do is use the Windows API; in particular, we'll be using the MMSystem.pas file.

One thing to note: We can use Windows API function calls solely, but TMediaPlayer does some internal handling that we don't need to worry about if we employ the component. So this example makes use of the TMediaPlayer.

Just follow these steps:

Start a new project and drop a TMediaPlayer and a TButton on it.
Add a "MMSystem" declaration to the uses statement of your form.
Set AutoOpen to True on the TMediaPlayer. Set the DeviceType property to dtCDAudio. You might want to consider disabling the btEject option from EnabledButtons property since we'll be handling that functionality in code.
One thing I use this for is for data CD's in some applications, so I also set the Visible property to False and just let my button do the opening and closing of the tray.
Finally, add the following code to the button's OnClick event:

procedure TForm1.Button2Click(Sender: TObject);
begin
  with MediaPlayer1 do
    if (MediaPlayer1.Mode = mpOpen) then
      mciSendCommand(MediaPlayer1.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0)
    else
      mciSendCommand(MediaPlayer1.DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);
end;

Notice we use the function mciSendCommand. This is the "Swiss Army Knife" of the MMSystem unit. In Windows, everything's controlled by messages. With respect to device control, mciSendCommand is very similar to a window's WndProc in that it acts as a message dipatcher. Just supply the device, the message type, message flags, and message parameters, and you're on your way. For more detailed information, I suggest you look in the help file.

How to check which control previously had focus

Problem/Question/Abstract:

Is there any way to tell within the OnEnter handler of Control2, which other control just passed the focus to Control2?

Answer:

type
  TForm1 = class(TForm)
    { ... }
  public
    LastControl: TComponent;
  end;

procedure TForm1.Edit1OnEnter(Sender: TObject);
begin
  if Assigned(LastControl) then
    { do whatever you want with the previous control }
    LastControl := Sender as TComponent;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  LastControl := nil;
end;

Printing a TForm

Problem/Question/Abstract:

Printing a TForm

Answer:

If you try to print a Delphi form with the Print() method, it will print but the page is blank.
Instead use the following method.

  
procedure TForm1.PrintForm;
var
  DC: HDC;
  isDcPalDevice: Bool;
  MemDC: HDC;
  MemBitmap: HBITMAP;
  OldMemBitmap: HBITMAP;
  hDibHeader: THandle;
  pDibHeader: Pointer;
  hBits: THandle;
  pBits: Pointer;
  ScaleX: Double;
  ScaleY: Double;
  pPal: PLOGPALETTE;
  pal: HPALETTE;
  OldPal: HPALETTE;
  i: Integer;
begin
  {Get the screen dc}
  DC := GetDC(0);
  {Create a compatible dc}
  MemDC := CreateCompatibleDC(DC);
  {create a bitmap}
  MemBitmap := CreateCompatibleBitmap(DC, Self.Width, Self.Height);
  {select the bitmap into the dc}
  OldMemBitmap := SelectObject(MemDC, MemBitmap);

  {Lets prepare to try a fixup for broken video drivers}
  isDcPalDevice := False;
  if GetDeviceCaps(DC, RASTERCAPS) and RC_PALETTE = RC_PALETTE then
  begin
    GetMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
    FillChar(pPal^, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)),
      #0);
    pPal^.palVersion := $300;
    pPal^.palNumEntries := GetSystemPaletteEntries(DC, 0, 256, pPal^.palPalEntry);
    if pPal^.palNumEntries <> 0 then
    begin
      pal := CreatePalette(pPal^);
      OldPal := SelectPalette(MemDC, pal, False);
      isDcPalDevice := True
    end
    else
      FreeMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
  end;
  {copy from the screen to the memdc/bitmap}
  BitBlt(MemDC, 0, 0, Self.Width, Self.Height, DC, Self.Left, Self.Top, SRCCOPY);

  if isDcPalDevice = True then
  begin
    SelectPalette(MemDC, OldPal, False);
    DeleteObject(pal);
  end;
  {unselect the bitmap}
  SelectObject(MemDC, OldMemBitmap);
  {delete the memory dc}
  DeleteDC(MemDC);
  {Allocate memory for a DIB structure}
  hDibHeader := GlobalAlloc(GHND, SizeOf(TBITMAPINFO) + (SizeOf(TRGBQUAD) *
    256));
  {get a pointer to the alloced memory}
  pDibHeader := GlobalLock(hDibHeader);

  {fill in the dib structure with info on the way we want the DIB}
  FillChar(pDibHeader^, SizeOf(TBITMAPINFO) + (SizeOf(TRGBQUAD) *
    256), #0);
  PBITMAPINFOHEADER(pDibHeader)^.biSize := SizeOf(TBITMAPINFOHEADER);
  PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
  PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
  PBITMAPINFOHEADER(pDibHeader)^.biWidth := Self.Width;
  PBITMAPINFOHEADER(pDibHeader)^.biHeight := Self.Height;
  PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;

  {find out how much memory for the bits}
  GetDIBits(DC, MemBitmap, 0, Self.Height, nil, TBITMAPINFO(pDibHeader^),
    DIB_RGB_COLORS);

  {Alloc memory for the bits}
  hBits := GlobalAlloc(GHND, PBITMAPINFOHEADER(pDibHeader)^.BiSizeImage);

  {Get a pointer to the bits}
  pBits := GlobalLock(hBits);

  {Call fn again, but this time give us the bits!}
  GetDIBits(DC, MemBitmap, 0, Self.Height, pBits, PBitmapInfo(pDibHeader)^,
    DIB_RGB_COLORS);

  {Lets try a fixup for broken video drivers}
  if isDcPalDevice = True then
  begin
    for i := 0 to (pPal^.palNumEntries - 1) do
    begin
      PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed := pPal^.palPalEntry[i].peRed;
      PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen := pPal^.palPalEntry[i].peGreen;
      PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue := pPal^.palPalEntry[i].peBlue;
    end;
    FreeMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
  end;
  {Release the screen dc}
  ReleaseDC(0, DC);
  {Delete the bitmap}
  DeleteObject(MemBitmap);

  {Start print job}
  Printer.BeginDoc;

  {Scale print size }
  ScaleX := Self.Width * 3;
  ScaleY := Self.Height * 3;

  {
  if Printer.PageWidth < Printer.PageHeight then
  begin
    ScaleX := Printer.PageWidth;
    ScaleY := Self.Height*(Printer.PageWidth/Self.Width);
  end
  else
  begin
    ScaleX := Self.Width*(Printer.PageHeight/Self.Height);
    ScaleY := Printer.PageHeight;
  end;
  }

  {Just incase the printer drver is a palette device}
  isDcPalDevice := False;
  if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and RC_PALETTE = RC_PALETTE then
  begin
    {Create palette from dib}
    GetMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
    FillChar(pPal^, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)),
      #0);
    pPal^.palVersion := $300;
    pPal^.palNumEntries := 256;
    for i := 0 to (pPal^.palNumEntries - 1) do
    begin
      pPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
      pPal^.palPalEntry[i].peGreen := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
      pPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
    end;
    pal := CreatePalette(pPal^);
    FreeMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
    OldPal := SelectPalette(Printer.Canvas.Handle, pal, False);
    isDcPalDevice := True
  end;
  {send the bits to the printer}
  StretchDiBits(Printer.Canvas.Handle, 0, 0, Round(ScaleX), Round(ScaleY),
    0, 0, Self.Width, Self.Height, pBits, PBitmapInfo(pDibHeader)^,
    DIB_RGB_COLORS, SRCCOPY);

  {Just incase you printer drver is a palette device}
  if isDcPalDevice = True then
  begin
    SelectPalette(Printer.Canvas.Handle, OldPal, False);
    DeleteObject(pal);
  end;
  {Clean up allocated memory}
  GlobalUnlock(hBits);
  GlobalFree(hBits);
  GlobalUnlock(hDibHeader);
  GlobalFree(hDibHeader);

  {end the print job}
  Printer.EndDoc;
end;

How to iterate through both a master and a detail table

Problem/Question/Abstract:

My tables need to have master-detail relationship, but I still want to iterate through all the records in a table (detail...). My tables are:

Associate- employee name, leads, supervisor, etc...
Quality Score- associate name, etc...
Productivity Score- associate name, etc...

Obviously, these will be linked via the associate name. However, I cannot programmatically iterate through all the records after being linked. What I want to do is get the average quality score, productivity score, etc... for the team lead and supervisor. Any ideas?

Answer:

You can do something like:

{ ... }
MasterTable.First;
while not MasterTable.EOF do
begin
  while not DetailTable.EOF do
  begin
    { do your stuff }
    DetailTable.Next;
  end;
  MasterTable.Next;
end;

Detect an HTTP proxy

Problem/Question/Abstract:

Detect an HTTP proxy

Answer:

If you write a core http client, e.g. from socket level, you may need to detect whether there is an http proxy used. This includes the name of the proxy server and the port number it operates on. Such proxy servers are often used where a firewall is installed.

Luckily IE is installed on many Windows systems, and IE puts this information in the registry under

\Software\Microsoft\Windows\CurrentVersion\Internet Settings

The following procedure GetProxy retrieves the host name, port number and whether the proxy is enabled. You can use it as shown in the FormCreate() event handler.

Note: The value ProxyEnable should be a DWord, but sometimes it may be stored as binary or as a string, depending on the version of IE that the user has installed. The code below evaluates the type and reads it appropriately.


unit fProxy;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function GetProxy(var Host: string; var Port: integer; var ProxyEnabled: boolean): boolean;
var
  s: string;
  p: integer;
begin
  with TRegistry.Create do
  begin
    RootKey := HKEY_CURRENT_USER;
    ProxyEnabled := false;
    s := '';
    OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet Settings', True);
    if ValueExists('ProxyServer') then
      s := ReadString('ProxyServer');

    if s <> '' then
    begin
      p := pos(':', s);
      if p = 0 then
        p := length(s) + 1;
      Host := copy(s, 1, p - 1);
      try
        Port := StrToInt(copy(s, p + 1, 999));
      except
        Port := 80;
      end;

      ProxyEnabled := true;
    end;

    if ValueExists('ProxyEnable') then
    begin
      case GetDataType(sProxyEnable) of
        rdString,
          rdExpandString:
          begin
            sPortTmp := AnsiLowerCase(ReadString(sProxyEnable));
            ProxyEnabled := true;
            if pos(' ' + sPortTmp + ' ', ' yes true t enabled 1 ') > 0 then
              ProxyEnabled := true
            else if pos(' ' + sPortTmp + ' ', ' no false f none disabled 0 ') > 0 then
              ProxyEnabled := false
          end;
        rdInteger:
          begin
            ProxyEnabled := ReadBool(sProxyEnable);
          end;
        rdBinary:
          begin
            ProxyEnabled := true;
            ReadBinaryData(sProxyEnable, ProxyEnabled, 1);
          end;
      end;
    end;

    Free;
  end;

  Result := s <> '';
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  Host: string;
  Port: integer;
  ProxyEnabled: boolean;
const
  YesNo: array[false..true] of string = (' not ', '');
begin
  // get proxy information
  if GetProxy(Host, Port, ProxyEnabled) then
    ShowMessage(Format('Your proxy is %s on port %d, it is%s enabled.', [Host, Port, YesNo[ProxyEnabled]]))
  else
    ShowMessage('No proxy detected');
end;

end.

Read the content of Internet Explorer's "Favourites" folder

Problem/Question/Abstract:

I would like to read the Properties of all entries in 'My Favorites' folder which contains all the web sites (URLs) addresses used by Internet Explorer. I would like to read the addresses and save them in a database. It's easier to do in Netscape because Netscape uses an HTML file that can be parsed easily.

Answer:

Solve 1:

The favourites folder is not very special. It just has some additions to the visibility. This function gets the location of it (no final backslash):

uses
  ShlObj;

function FavouritesPath: string;
var
  FilePath: array[0..MAX_PATH] of char;
begin
  SHGetSpecialFolderPath(0, FilePath, CSIDL_FAVORITES, false);
  Result := FilePath;
end;

Then you can traverse this folder and search for all *.url files. This is done by FindFirst/ FindNext. Use a recursive procedure if you want the subfolders, too.

To get the shortcut from these files, you can use this function (BTW: This is how TIniFile reads a string):

function GetInternetShortCut(const Filename: string): string;
var
  Buffer: array[0..2047] of Char;
begin
  SetString(Result, Buffer, GetPrivateProfileString('InternetShortcut',
    PChar('URL'), nil, Buffer, SizeOf(Buffer), PChar(Filename)));
end;

Example:

GetInternetShortcut(FavouritesPath + '\OneOfMyFavourites.url')


Solve 2:

I'm not sure if SHGetSpecialFolderPath is available on all Win32 platforms. Alternatively, you can use:

function FavoritesPath: string;
var
  FilePath: array[0..MAX_PATH] of Char;
  IDL: PItemIDList;
begin
  Result := '';
  if Succeeded(SHGetSpecialFolderLocation(0, CSIDL_FAVORITES, IDL)) then
    if SHGetPathFromIDList(IDL, FilePath) then
      Result := FilePath;
end;

How to jump directly to the WinHelp search dialog

Problem/Question/Abstract:

How to jump directly to the WinHelp search dialog

Answer:

procedure TForm1.HelpSearch(Sender: TObject);
var
  HelpMacro: pchar;
begin
  HelpMacro := 'Search()';
  with Application do
  begin
    Application.HelpContext(1);
    HelpCommand(HELP_COMMAND, longint(HelpMacro));
  end;
end;

Get the published properties of an persistent object

Problem/Question/Abstract:

How to get the published properties of an persistent object / Using the pPropInfo-Pointer and the RTTI of Delphi

Answer:

The TypeInfo unit of Delphi declares several types and functions that gives you easy access to the puplished properties of an object and other informations.
You can obtain a list of the published properties of a class and get the name an type of each property.

The TypeInfo funtion returns a pointer to a type information record. The TypInfo unit declares a real type, that is, a pointer to a TTypeInfo record :

PTypeInfo = ^TTypeInfo;
TTypeInfo = record
  Kind: TTypeKind;
  Name: ShortString;
end;

The TTypeKind datatype describes the Datatype , returned by the GetTypeData function.

TTypeKind = (tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
  tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString,
  tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray);
TTypeKinds = set of TTypeKind;

Well ... for our first step to access the objects published properties we need to use the PPropInfo-pointer.

PPropInfo = ^TPropInfo;
TPropInfo = packed record
  PropType: PPTypeInfo;
  GetProc: Pointer;
  SetProc: Pointer;
  StoredProc: Pointer;
  Index: Integer;
  Default: Longint;
  NameIndex: SmallInt;
  Name: ShortString;
end;

To clarify it, please take a look at this example :

function GetFontSize(Obj: TPersistent): Integer;
{
in this Procedure we want to get the pPropInfo-pointer - pointing
on the Font-Property from an arbitrary TPersistent-Class.
The return-value in this instance will be the font-size ( if the font
property exists , if not -> the return value will be -1 )
}
var
  PropInfo: PPropInfo;
begin
  RESULT := -1;
  // Get the PPropInfo-Pointer for Font of the TPersistent obj
  PropInfo := GetPropInfo(Obj, 'Font');
  // At first we will find out if the property FONT exists
  if PropInfo = nil then
    EXIT; // The Property doesn't exists
  {
    TFont is not an ordinal-Type - therefore will have to control if
    Typekind of the TypeInfo-Class is set to tkClass
  }
  if PropInfo.PropType^.Kind <> tkClass then
    EXIT; // property isn't a tkClass type
  {
    now, we now that the TypeKind of die PropInfo-pointer is a class .
    last but not least we will use the GetObjectProp, the return-value
    of this function is a TObject. Subsequently, we will use this object as
    a TFont to get the Size value.
  }
  RESULT := ((GetObjectProp(Obj, PropInfo)) as TFont).Size;
end;

But to get the complete list of all properties of a TPersistent-Class we will need the pPropList-Type . This type is a simple pointer-array and the magic key to all Property-Informations and their structures.

Take a look at this :

procedure TForm1.Button1Click(Sender: TObject);

const
  tkOrdinal = [tkEnumeration, tkInteger, tkChar, tkSet, tkWChar]; //Filter

begin
  {
    in this method of the mainform-class we are seeking for all ordinal-type
    properties of the edit1-component. The from the GetPropertyList method
    returned list of all properties will be written into the Listbox1. You can
    replace the obj parameter with an arbitrary TObject ( but usually TPersistent
    objects ).
    For another filter please take a look at the TTypeKinds-set.
  }
  GetPropertyList(Edit1, ListBox1.Items, tkOrdinal);
end;

procedure GetPropertyList(Obj: TObject; List: TStrings; Filter: TTypeKinds);
var
  PropList: pPropList;
  count, i: Integer;
begin
  List.Clear;
  // Here we'll get the count of the given properties, ...
  Count := GetPropList(Obj.ClassInfo, Filter, nil);
  // ...and create room for the PropList,...
  GetMem(PropList, Count * SizeOf(PPropInfo));
  // ...get the Proplist-Data,...
  GetPropList(Obj.ClassInfo, Filter, PropList);
  // ...and write the property-names into the StringList
  for i := 0 to Count - 1 do
    List.Add(Proplist[i].Name);
end;

Get the CRC

Problem/Question/Abstract:

How to get the CRC value

Answer:

implementation
const
  Table: array[0..255] of LongInt = ($00000000, $77073096, $EE0E612C, $990951BA,
    $076DC419, $706AF48F, $E963A535, $9E6495A3, $0EDB8832, $79DCB8A4, $E0D5E91E,
    $97D2D988, $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91, $1DB71064, $6AB020F2,
    $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7, $136C9856,
    $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
    $3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD,
    $A50AB56B, $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75,
    $DCD60DCF, $ABD13D59, $26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5,
    $56B3C423, $CFBA9599, $B8BDA50F, $2802B89E, $5F058808, $C60CD9B2, $B10BE924,
    $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D, $76DC4190, $01DB7106, $98D220BC,
    $EFD5102A, $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433, $7807C9A2, $0F00F934,
    $9609A88E, $E10E9818, $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01, $6B6B51F4,
    $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
    $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3,
    $FBD44C65, $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7,
    $A4D1C46D, $D3D6F4FB, $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73,
    $33031DE5, $AA0A4C5F, $DD0D7CC9, $5005713C, $270241AA, $BE0B1010, $C90C2086,
    $5768B525, $206F85B3, $B966D409, $CE61E49F, $5EDEF90E, $29D9C998, $B0D09822,
    $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD, $EDB88320, $9ABFB3B6,
    $03B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $04DB2615, $73DC1683, $E3630B12,
    $94643B84, $0D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
    $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671,
    $6E6B06E7, $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9,
    $17B7BE43, $60B08ED5, $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1,
    $A6BC5767, $3FB506DD, $48B2364B, $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60,
    $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79, $CB61B38C, $BC66831A, $256FD2A0,
    $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F, $C5BA3BBE, $B2BD0B28,
    $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D, $9B64C2B0,
    $EC63F226, $756AA39C, $026D930A, $9C0906A9, $EB0E363F, $72076785, $05005713,
    $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7,
    $0BDBDF21, $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B,
    $6FB077E1, $18B74777, $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF,
    $F862AE69, $616BFFD3, $166CCF45, $A00AE278, $D70DD2EE, $4E048354, $3903B3C2,
    $A7672661, $D06016F7, $4969474D, $3E6E77DB, $AED16A4A, $D9D65ADC, $40DF0B66,
    $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9, $BDBDF21C, $CABAC28A,
    $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF, $B3667A2E,
    $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);

type
  buffer = array[1..65521] of byte; {largest buffer that can be
  allocated on heap }
var
  i: WORD;
  q: ^buffer;

procedure CalcCRC32(p: pointer; nbyte: Word; var CRCvalue: LongInt);
{The following is a little cryptic (but executes very quickly). The algorithm is as follows:
1. exclusive-or the input byte with the low-order portion of the CRC register to get an INDEX
2. shift the CRC register eight bits to the right
3. exclusive-or the CRC register with the contents of Table[INDEX]
4. repeat steps 1 through 3 for all bytes}

var
  i: Word;
begin
  q := p;
  for i := 1 to nBYTE do
    CRCvalue := (CRCvalue shr 8) xor
      Table[q^[i] xor (CRCvalue and $000000FF)]
end {CalcCRC32};

procedure CalcFileCRC32(FromName: string; var CRCvalue: LongInt; var IOBuffer:
  pointer; BufferSize: Word; var TotalBytes: LongInt; var error: WORD);
var
  BytesRead: integer;
  FromFile: file;

begin
  FileMode := 0; {Turbo default is 2 for R/W; 0 is for R/O}
  CRCValue := $FFFFFFFF;
  Assign(FromFile, FromName);
{$I-}Reset(FromFile, 1);
{$I+}Error := IOResult;
  if error = 0 then
  begin
    TotalBytes := 0;
    repeat BlockRead(FromFile, IOBuffer^, BufferSize, BytesRead);
      CalcCRC32(IOBuffer, BytesRead, CRCvalue);
      Inc(TotalBytes,
        BytesRead)
    until BytesRead = 0;
    Close(FromFile)
  end;
  CRCvalue := not CRCvalue
end {CalcFileCRC32};

Store the HTML source code of a TWebBrowser document into a string

Problem/Question/Abstract:

How can I access the HTML content of a TWebBrowser object? I tried to use OLECMDID_SAVEAS to save it as a file first and then access it afterwards. But it always asks for the directory and file name for this file.

Answer:

Use the following function to store the HTML source code to a string (e.g. a TStringStream):

procedure SaveDocumentSourceToStream(Document: IDispatch; Stream: TStream);
var
  PersistStreamInit: IPersistStreamInit;
  StreamAdapter: IStream;
begin
  {Delete stream content}
  Stream.Size := 0;
  Stream.Position := 0;
  {IPersistStreamInit - get document interface}
  if Document.QueryInterface(IPersistStreamInit, PersistStreamInit) = S_OK then
  begin
    {Use stream adapter to get the IStream Interface to our stream}
    StreamAdapter := TStreamAdapter.Create(Stream, soReference);
    {Save data from document into stream}
    PersistStreamInit.Save(StreamAdapter, False);
    {Destroy stream adapter. Optional, as it would happen anyway}
    StreamAdapter := nil;
  end;
end;

How to load and scale a JPEGImage into a TImage

Problem/Question/Abstract:

How to load and scale a JPEGImage into a TImage

Answer:

{ ... }
Image1.Picture.Graphic := nil;
try
  Image1.Picture.Graphic := nil;
  Image1.Picture.LoadFromFile(jpegfile);
except
  on EInvalidGraphic do
    Image1.Picture.Graphic := nil;
end;
if Image1.Picture.Graphic is TJPEGImage then
begin
  TJPEGImage(Image1.Picture.Graphic).Scale := Self.Scale;
  TJPEGImage(Image1.Picture.Graphic).Performance := jpBestSpeed;
end;

How to open or close all datasets in on the form

Problem/Question/Abstract:

How to open or close all datasets in on the form

Answer:

Open datasets: OpenDataSet(MyForm);

procedure OpenDataSet(FormName: TForm);
var
  I: Integer;
begin
  for I := FormName.ComponentCount - 1 downto 0 do
    if (FormName.Components[I] is TADOTable) then
    begin
      (FormName.Components[I] as TADOTable).Open;
    end;
end;

Close datasets: CloseDataSet(MyForm);

procedure CloseDataSet(FormName: TForm);
var
  I: Integer;
begin
  for I := FormName.ComponentCount - 1 downto 0 do
    if (FormName.Components[I] is TADOTable) then
    begin
      (FormName.Components[I] as TADOTable).Close;
    end;
end;

How to get a list of all windows on the Desktop and their handles

Problem/Question/Abstract:

How to get a list of all windows on the Desktop and their handles

Answer:

unit Unit1;

interface

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

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

var
  Form1: TForm1;
  WindowList: TList;

implementation

{$R *.DFM}

function GetWindows(Handle: HWND; Info: Pointer): BOOL; stdcall;
begin
  Result := True;
  WindowList.Add(Pointer(Handle));
end;

procedure TForm1.GetWins;
var
  TopWindow, CurrentWindow: HWND;
  Dest: array[0..80] of char;
  ClassName: array[0..80] of char;
  i: Integer;
begin
  try
    WindowList := TList.Create;
    TopWindow := Handle;
    EnumWindows(@GetWindows, Longint(@TopWindow));
    CurrentWindow := TopWindow;
    for i := 0 to WindowList.Count - 1 do
    begin
      CurrentWindow := GetNextWindow(CurrentWindow, GW_HWNDNEXT);
      GetWindowText(CurrentWindow, Dest, sizeof(Dest) - 1);
      GetClassName(CurrentWindow, ClassName, sizeof(ClassName) - 1);
      if StrLen(Dest) > 0 then
        Memo1.Lines.Add(Dest + ' = ' + ClassName + ' - ' + IntToStr(CurrentWindow));
    end;
  finally
    WindowList.Free;
  end;
end;

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

end.

How to generate a circle through three points

Problem/Question/Abstract:

How to generate a circle through three points

Answer:

Let the three given points be a, b, c. Use _0 and _1 to represent x and y coordinates. The coordinates of the center p = (p_0,p_1) of the circle determined by a, b, and c are:



A = b_0 - a_0;
B = b_1 - a_1;
C = c_0 - a_0;
D = c_1 - a_1;

E = A * (a_0 + b_0) + B * (a_1 + b_1);
F = C * (a_0 + c_0) + D * (a_1 + c_1);

G = 2.0 * (A * (c_1 - b_1) - B * (c_0 - b_0));

p_0 = (D * E - B * F) / G;
p_1 = (A * F - C * E) / G;



If G is zero then the three points are collinear and no finite-radius circle through them exists. Otherwise, the radius of the circle is:



r^2 = (a_0 - p_0)^2 + (a_1 - p_1)^2

Invert the color of a TEdit

Problem/Question/Abstract:

I have a TEdit control and there are two color properties I wish to set: TEdit.Color and TEdit.Font.Color. I did something like

TEdit.Color := clBlack
TEdit.Font.Color := TEdit.Color xor $7FFFFFFF;

but TEdit.Font.Color doesn't show as contrast of TEdit.Color. Can anybody advise on that. I wish to make the TEdit.Color and TEdit.Font.Color always contrast to each other. My application allows the user to change the TEdit.color at runtime.

Answer:

Try this one:

function InverseColor(color: TColor): TColor;
var
  rgb_: TColorRef;

  function Inv(b: Byte): Byte;
  begin
    if b > 128 then
      result := 0
    else
      result := 255;
  end;

begin
  rgb_ := ColorToRgb(color);
  rgb_ := RGB(Inv(GetRValue(rgb_)), Inv(GetGValue(rgb_)), Inv(GetBValue(rgb_)));
  Result := rgb_;
end;

How to launch the Windows Control Panel

Problem/Question/Abstract:

How to launch the Windows Control Panel

Answer:

This is quite useful if you are writing a shell replacement.


This will launch the control panel:

WinExec('rundll32 shell32.dll, Control_RunDLL', SW_SHOW);

Launch display properties:

WinExec('rundll32 shell32.dll, Control_RunDLL desk.cpl, , 0', SW_SHOW);