Drawing a form border

Problem/Question/Abstract:

How to change the appearance of a forms border?

Answer:

Solve 1:

Actually, it is very easy top change the standard frame border, just by capturing the two events of Non-Client-Paint and Non-Client-Activate and calling your own drawing at your own will onto the form.

First, you will have to find the width of your frame border, which can be done by using the GetSystemMetrics method. Now you can do whatever you want within the canvas, however, you should not leave the frame area.

type
  TForm1 = class(TForm)
  private
    procedure FormFrame;
    procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
    procedure WMNCActivate(var Msg: TWMNCActivate); message WM_NCACTIVATE;
  public
  end;

procedure TForm1.FormFrame;
var
  YFrame: Integer;
  Rect: TRect;
begin
  YFrame := GetSystemMetrics(SM_CYFRAME);
  Canvas.Handle := GetWindowDC(Handle);
  with Canvas, Rect do
  begin
    Left := 0;
    Top := 0;
    Right := Width;
    Bottom := Height;
    Pen.Style := psClear;

    // draw background of frame
    Brush.Color := clNavy;
    Brush.Style := bsSolid;
    Rectangle(Left, Top, Right, YFrame);
    Rectangle(Left, Top, YFrame, Bottom);
    Rectangle(Right - YFrame, Top, Right, Bottom);
    Rectangle(Left, Bottom - YFrame, Right, Bottom);

    // draw frame pattern
    Brush.Color := clYellow;
    Brush.Style := bsDiagCross;
    Rectangle(Left, Top, Right, YFrame);
    Rectangle(Left, Top, YFrame, Bottom);
    Rectangle(Right - YFrame, Top, Right, Bottom);
    Rectangle(Left, Bottom - YFrame, Right, Bottom);
  end;
end;

procedure TForm1.WMNCActivate(var Msg: TWMNCActivate);
begin
  inherited;
  FormFrame;
end;

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
begin
  inherited;
  FormFrame;
end;

If you will have problem when maximizing the form, resize if to the right or the Title caption bar will not update properly, you may try to catch the WM_SIZE message.

procedure WMSize(var Msg: TWMSize); message WM_SIZE;
...
procedure TForm1.WMSize(var Msg: TWMSize);
begin
  inherited;
  FormFrame;
end;


Solve 2:

This will paint a one pixel red border around the entire window.

type
  TForm1 = class(TForm)
  private
    { Private declarations }
    procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
  dc: hDc;
  Pen: hPen;
  OldPen: hPen;
  OldBrush: hBrush;
begin
  inherited;
  dc := GetWindowDC(Handle);
  msg.Result := 1;
  Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0));
  OldPen := SelectObject(dc, Pen);
  OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
  Rectangle(dc, 0, 0, Form1.Width, Form1.Height);
  SelectObject(dc, OldBrush);
  SelectObject(dc, OldPen);
  DeleteObject(Pen);
  ReleaseDC(Handle, Canvas.Handle);
end;

Keep other forms visible while minimizing the main form

Problem/Question/Abstract:

How to keep other forms visible while minimizing the main form

Answer:

Solve 1:

You need to disable Delphi's default minimization behaviour and take over yourself.

In the main forms FormCreate do this:


{ ... }
ShowWindow(Application.handle, SW_HIDE);
SetWindowLong(Application.handle, GWL_EXSTYLE, GetWindowLong(application.handle,
  GWL_EXSTYLE) and not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW);
ShowWindow(Application.handle, SW_SHOW);
{ ... }

That removes the application button from the taskbar.

The main form gets a handler for the WM_SYSCOMMAND message:

{ ... }
private {form declaration}

procedure WMSyscommand(var msg: TWmSysCommand); message WM_SYSCOMMAND;

procedure TForm1.WMSyscommand(var msg: TWmSysCommand);
begin
  case (msg.cmdtype and $FFF0) of
    SC_MINIMIZE:
      begin
        ShowWindow(handle, SW_MINIMIZE);
        msg.result := 0;
      end;
    SC_RESTORE:
      begin
        ShowWindow(handle, SW_RESTORE)
          msg.result := 0;
      end;
  else
    inherited;
  end;
end;

This disables the default minimization behaviour.

To get a taskbar button for the form and have it minimize to the taskbar instead of to the desktop, override the CreateParams method of the main form and also of all the secondary forms:

{ in form declaration }

procedure CreateParams(var params: TCreateParams); override;

procedure TForm1.CreateParams(var params: TCreateParams);
begin
  inherited CreateParams(params);
  params.ExStyle := params.ExStyle or WS_EX_APPWINDOW;
end;


Solve 2:

You must override the CreateParams() method and add the following code:

procedure TForm2.CreateParams(var params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := params.ExStyle or WS_EX_APPWINDOW
end;

Something to keep in mind is that when you restore a minimized form, the entire application will be brought to the front If you don't want that to happen, do this:

procedure TForm3.CreateParams(var params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := params.ExStyle or WS_EX_APPWINDOW;
  Params.WndParent := GetDesktopWindow; {add this line}
end;

Now the forms will brought to the front independently. If you're launching forms from other form, you'll have to handle the paranting issues accordingly so that modal forms don't appear behind your other forms.

Print url/html file using IE browser

Problem/Question/Abstract:

How can I print url/html file using IE browser?

Answer:

Solve 1:

I want to show how you can activate printing of any url and/or html file using installed IE.

I solved this task yesterday and solution is very useful and have a small size:-)

uses ComObj;

procedure PrintHTMLByIE(const url: string);
const
  OLECMDID_PRINT = $00000006;
  OLECMDEXECOPT_DONTPROMPTUSER = $00000002;
var
  ie, vaIn, vaOut: Variant;
begin
  ie := CreateOleObject('InternetExplorer.Application');
  ie.Navigate(url);
  ie.Visible := True;
  ie.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;

Sample:

PrintHTMLByIE('file:\\c:\misha\webpage\index.htm');

or

PrintHTMLByIE('http:\\www.scalabium.com\sme\index.htm');

I get "Trying to revoke drop target that has not been registered" error all the time. The only way the function works is if you step over the code with F8. Any ideas why?

there is a bugfix for that on the community site !

just do this...

const
  OLECMDF_SUPPORTED = 1;
  OLECMDF_ENABLED = 2;
var
  ie, vaIn, vaOut: Variant;
begin
  ie := CreateOleObject('InternetExplorer.Application');
  ie.Navigate(url);
  ie.Visible := True;
  while ie.QueryStatusWB(OLECMDID_PRINT) <> OLECMDF_SUPPORTED + OLECMDF_ENABLED do
    Forms.Application.ProcessMessages;
  sleep(2000);
  ie.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;


Solve 2:

I had to use OleVariant for the type (instead of Variant) but I'm using the TWebBrowser control like this:

procedure TForm1.btnPrintClick(Sender: TObject);
const
  OLECMDID_PRINT = 6;
  OLECMDEXECOPT_DONTPROMPTUSER = 2;
var
  vaIn, vaOut: OleVariant;
begin
  WebBrowser1.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;

Time Out an application

Problem/Question/Abstract:

How to apply a time out to prevent user inactivity.

Answer:

Here a sample code that will allow you to close an application if the user is getting asleep while working / if he go afk for too long.
This can be useful for program like MIRC where they use such Time-Out value. Some online games work like that also to prevent user to take server bandwitch, also coming to my mind are screensaver application or CPU cooler program.

First declare a global constant called MaxTimeOutDelay. Affect it to some integer value that will represent the maximum number of seconds where your program is allowed to record user inactivity before taking action.

Second, declare a variable called TimeElapsed as integer. This will keep track of the time elapsed since user last activity recorded.

Third put a timer on the form.

On the FormCreate event set the TimeElapsed to 0.

Now declare a simple Procedure that will Reset the TimeElapsed.

It should look like:

procedure TForm1.ResetTimeElapsed;
begin
  TimeElapsed := 0;
end;

Two event can resume in a sufficient manner the gloabl user activity.

OnKeyDown Event
OnMouseMove

When the user do something the TimeElapsed is reset so for the two event the code will look like this.

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

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  ResetTimeElapsed;
end;

Here the last bit of code. On timer event the TimeElapsed is incremented. In short, the Timer Transfer a value to the TimeElapsed variable every second (If you default value for timer wasn't changed).
Than it's just a simple check to see if the TimeElapsed have reached the MaxTimeOutValue.

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

This program close the application. But actually it's a lot more useful to associate the TimeOut to a more useful routine. For example you can make the computer sleep when the user didn't do anything for 15 minute, make it run in the system tray to save power/pcu usage.

Change the cell of a TStringGrid into a button

Problem/Question/Abstract:

Does anyone know how to make a cell (that has text in it) look like a button with the text written on it?

Answer:

The following example fakes a column of buttons in column 3 of the grid. The buttons are "clickable". Events of the grid handled are OnMouseDown, OnMOuseUp, OnDrawCell, OnSelectCell.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    StatusBar: TStatusBar;
    Button1: TButton;
    Label1: TLabel;
    StringGrid1: TStringGrid;
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect;
      State: TGridDrawState);
    procedure StringGrid1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure StringGrid1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; var
      CanSelect: Boolean);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    FButtonDown: Boolean;
    FDownRow: Integer;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
  ButtonCol = 3;
type
  TGridCracker = class(TStringGrid);
  {gives access to protected methods of grid}

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  grid: TStringGrid;
begin
  grid := Sender as TStringGrid;
  if (aCol = ButtonCol) and (aRow >= grid.FixedRows) then
  begin
    {draw a button in Rect}
    DrawFrameControl(grid.Canvas.handle, Rect, DFC_BUTTON, DFCS_BUTTONPUSH or
      DFCS_ADJUSTRECT or DFCS_PUSHED * Ord(FButtonDown and (Arow = FDOwnrow)));
    grid.Canvas.Brush.Style := bsClear;
    grid.Canvas.Font.Color := clBlack;
    grid.Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top + 2, grid.Cells[aCol, aRow]);
    grid.Canvas.Brush := grid.Brush;
  end;
end;

procedure TForm1.StringGrid1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  r: TPoint;
  grid: TGridCracker;
begin
  if (Button = mbLeft) and ((Shift - [ssLeft]) = []) then
  begin
    grid := TGridCracker(Sender as TStringGrid);
    grid.MouseToCell(X, Y, r.x, r.y);
    if (r.x = ButtonCol) and (r.y >= grid.FixedRows) then
    begin
      FDownRow := r.Y;
      FButtonDown := true;
      grid.InvalidateCell(r.x, r.y);
      grid.MouseCapture := true;
      grid.Options := grid.Options - [goRangeSelect];
    end;
  end;
end;

procedure TForm1.StringGrid1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  grid: TGridCracker;
begin
  if FButtonDown then
  begin
    grid := TGridCracker(Sender as TStringGrid);
    grid.MouseCapture := false;
    FButtonDown := False;
    grid.InvalidateCell(ButtonCol, FDownRow);
    grid.Options := grid.Options + [goRangeSelect];
    { ... might do some click action here}
  end;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
  var CanSelect: Boolean);
begin
  CanSelect := aCol <> ButtonCol;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  for i := 1 to StringGrid1.rowcount - 1 do
    StringGrid1.cells[ButtonCol, i] := format('Button %d', [i]);
end;

end.

Adding Explorer Bar

Problem/Question/Abstract:

Creating Custom Explorer Bars , Band Object

Answer:

function AddExplorerBar(BarTitle, Url: string; BarSize: Int64; Horizontal:
  Boolean): string;
const
  EXPLORERBAR_ID = '{4D5C8C2A-D075-11d0-B416-00C04FB90376}';
  VERTICAL_BAR = '{00021493-0000-0000-C000-000000000046}';
  HORIZONTAL_BAR = '{00021494-0000-0000-C000-000000000046}';
var
  GUID: TGUID;
  SysDir, ID: string;
  Reg: TRegistry;
begin
  CreateGuid(GUID);
  ID := GuidToString(GUID);
  Reg := TRegistry.Create;
  with Reg do
  try
    RootKey := HKEY_CLASSES_ROOT;
    OpenKey('\CLSID\' + ID, True);
    WriteString('', 'BarTitle');
    CloseKey;
    CreateKey('\CLSID\' + ID + '\Implemented Categories');
    if HORIZONTAL then
      CreateKey('\CLSID\' + ID + '\Implemented Categories\' +
        HORIZONTAL_BAR)
    else
      CreateKey('\CLSID\' + ID + '\Implemented Categories\' +
        VERTICAL_BAR);
    SetLength(SysDir, 255);
    GetSysDirectory(PChar(SysDir), 255);
    SysDir := PChar(SysDir) + '\SHDOCVW.DLL';
    OpenKey('\CLSID\' + ID + '\InProcServer32', True);
    Writestring('', SysDir);
    WriteString('Threadingmodel', 'Apartment');
    CloseKey;
    OpenKey('\CLSID\' + ID + '\Instance', True);
    WriteString('CLSID', EXPLORERBAR_ID);
    CloseKey;
    OpenKey('\CLSID\' + ID + '\Instance\InitPropertyBag', True);
    WriteString('Url', URL);
    CloseKey;
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('Software\Microsoft\Internet Explorer\Explorer Bars\'
      + ID, True);
    WriteBinaryData('BarSize', BarSize, SizeOf(BarSize));
    CloseKey;
    OpenKey('\Software\IE5Tools\Explorer Bars\', True);
    WriteString(BarTitle, ID);
    CloseKey;
    OpenKey('\Software\Microsoft\Internet Explorer\Toolbar', True)
      WriteString(ID, '');
    CloseKey;
  finally
    Free;
  end;
  result := ID;
end;

A collection of TPoint related functions

Problem/Question/Abstract:

A collection of TPoint related functions

Answer:

function CCW(p0, p1, p2: TPoint): Integer;

{Purpose:
Determines, given three points, if when travelling from the first to the second
to the third, we travel in a counterclockwise direction.
Return Value:
(int) 1 if the movement is in a counterclockwise direction, -1 if not.}

var
  dx1, dx2: LongInt;
  dy1, dy2: LongInt;
begin
  dx1 := p1.x - p0.x;
  dx2 := p2.x - p0.x;
  dy1 := p1.y - p0.y;
  dy2 := p2.y - p0.y;
  {This is basically a slope comparison: we don't do divisions because
   of divide by zero possibilities with pure horizontal and pure vertical lines.}
  if ((dx1 * dy2) > (dy1 * dx2)) then
    Result := 1
  else
    Result := -1;
end;

function Intersect(p1, p2, p3, p4: TPoint): Boolean;

{Purpose: Given two line segments, determine if they intersect.
Return Value: TRUE if they intersect, FALSE if not.}

begin
  Result := (((CCW(p1, p2, p3) * CCW(p1, p2, p4)) <= 0) and
    ((CCW(p3, p4, p1) * CCW(p3, p4, p2) <= 0)));
end;

function G_PtInPolyRect(PolyPoints: array of TPoint; ptTest: TPoint;
  var prbound: TRect): Boolean;

{Purpose:
This routine determines if a point is within the smallest rectangle that encloses a polygon.
Return Value:
(BOOL) True or False depending on whether the point is in the rect or not.}

var
  xmin, xmax, ymin, ymax: Integer;
  pt: TPoint;
  i: Word;
begin
  xmin := MaxInt;
  ymin := MaxInt;
  xmax := -MaxInt;
  ymax := -MaxInt;
  for i := 0 to High(PolyPoints) do
  begin
    pt := PolyPoints[i];
    if (pt.x < xmin) then
      xmin := pt.x;
    if (pt.x > xmax) then
      xmax := pt.x;
    if (pt.y < ymin) then
      ymin := pt.y;
    if (pt.y > ymax) then
      ymax := pt.y;
  end;
  prbound := Rect(xmin, ymin, xmax, ymax);
  Result := PtInRect(prbound, ptTest);
end;

function G_PtInPolygon(PolyPoints: array of TPoint; ptTest: TPoint): Boolean;

{Purpose:
This routine determines if the point passed is in the polygon. It uses the classical polygon hit-testing algorithm: A horizontal ray starting at the point is extended infinitely rightwards and the number of polygon edges that intersect the ray are counted. If the number is odd, the point is inside the polygon.
Return Value:
(BOOL) True if the point is inside the polygon, False if not.}

var
  i: Integer;
  pt1, pt2: TPoint;
  wnumintsct: Word;
  prbound: TRect;
begin
  wnumintsct := 0;
  Result := False;
  if (not G_PtInPolyRect(PolyPoints, ptTest, prbound)) then
    Exit;
  pt1 := ptTest;
  pt2 := ptTest;
  pt2.x := prbound.Right + 50;
  {Now go through each of the lines in the polygon and see if it intersects}
  for i := 0 to High(PolyPoints) - 1 do
    if (Intersect(ptTest, pt2, PolyPoints[i], PolyPoints[i + 1])) then
      Inc(wnumintsct);
  {And the last line}
  if (Intersect(ptTest, pt2, PolyPoints[High(PolyPoints)], PolyPoints[0])) then
    Inc(wnumintsct);
  {If wnumintsct is odd then the point is inside the polygon}
  Result := Odd(wnumintsct);
end;

How to compute the centroid of a polygon

Problem/Question/Abstract:

How to compute the centroid of a polygon

Answer:

The centroid (a.k.a. the center of mass, or center of gravity) of a polygon can be computed as the weighted sum of the centroids of a partition of the polygon into triangles. The centroid of a triangle is simply the average of its three vertices, i.e., it has coordinates (x1 + x2 + x3)/3 and (y1 + y2 + y3)/3. This suggests first triangulating the polygon, then forming a sum of the centroids of each triangle, weighted by the area of each triangle, the whole sum normalized by the total polygon area. This indeed works, but there is a simpler method: the triangulation need not be a partition, but rather can use positively and negatively oriented triangles (with positive and negative areas), as is used when computing the area of a polygon. This leads to a very simple algorithm for computing the centroid, based on a sum of triangle centroids weighted with their signed area. The triangles can be taken to be those formed by any fixed point, e.g., the vertex v0 of the polygon, and the two endpoints of consecutive edges of the polygon: (v1,v2), (v2,v3), etc. The area of a triangle with vertices a, b, c is half of this expression:


(b[X] - a[X]) * (c[Y] - a[Y]) - (c[X] - a[X]) * (b[Y] - a[Y])

Batch build multiple projects

Problem/Question/Abstract:

Batch build multiple projects

Answer:

Delphi's integrated development environment (IDE) is great, but, don't forget about Delphi command line compiler -- specially if you ever need to batch build  multiple projects.

For example, if you have three projects called proj1, proj2, and proj3, you can easily build all three at once by typing the following at the DOS/command prompt:

DCC32 proj1.dpr proj2.dpr proj3.dpr

If you're using Delphi 1.0, use DCC instead of DCC32:

DCC proj1.dpr proj2.dpr proj3.dpr

How to create fixed columns in a TDBGrid

Problem/Question/Abstract:

How do I freeze Column 1 in place on a DBGrid? I found a FixedCols property for a TCustomGrid, but there doesn't seem to be anything for a DBGrid.

Answer:

If you put ...


TFixColDBGrid = class(TDBGrid)
protected
  property FixedCols;
end;


... in your interface type section. And this ...


TFixColDBGrid(DBGrid1).FixedCols := 2;


... in your FormCreate procedure, it will fix the first two columns (ie the indicator column and the first data column - if you have no indicator column, set it to 1).

This is quite a good trick for simply exposing an ancestors property, particularly for complicated visual descendants with many properties which are set at design time.

How to get the amount of installed RAM

Problem/Question/Abstract:

How do I get the amount of RAM installed on a system and display it in megabytes? So 130,476 KB (as displayed in calculator about box) would display as '128 MB RAM' in my caption?

Answer:

Solve 1:

uses
  Windows, SysUtils;

function DisplayRam: string;
var
  Info: TMemoryStatus;
begin
  Info.dwLength := SizeOf(TMemoryStatus);
  GlobalMemoryStatus(Info);
  Result := Format('%d MB RAM', [(Info.dwTotalPhys shr 20) + 1]);
end;


Solve 2:

function Physmem: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwTotalPhys div 1024);
end;

function PhysmemFree: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwAvailPhys div 1024);
end;

function MemLoad: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwMemoryLoad);
end;

function TotalPageFile: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwTotalPageFile div 1024);
end;

function AvailPageFile: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwAvailPageFile div 1024);
end;

function VirTotPageFile: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwTotalVirtual div 1024);
end;

function AvailVir: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwAvailVirtual div 1024);
end;


Solve 3:

uses
  Windows;

function TMyApp.GlobalMemoryStatus(Index: Integer): Integer;
var
  MemoryStatus: TMemoryStatus
begin
  with MemoryStatus do
  begin
    dwLength := SizeOf(TMemoryStatus);
    Windows.GlobalMemoryStatus(MemoryStatus);
    case Index of
      1: Result := dwMemoryLoad;
      2: Result := dwTotalPhys div 1024;
      3: Result := dwAvailPhys div 1024;
      4: Result := dwTotalPageFile div 1024;
      5: Result := dwAvailPageFile div 1024;
      6: Result := dwTotalVirtual div 1024;
      7: Result := dwAvailVirtual div 1024;
    else
      Result := 0;
    end;
  end;
end;

Delphi DLL`s for Excel

Problem/Question/Abstract:

How do I make delphi functions available to Excel users?

I have seen many articles telling how to control Excel from within Delphi. However, it is also appealing to give Excel users (which tend to be far less programming oriented guys) the power of tools built with Dephi, its flexibility and velocity.

Answer:

The idea is very simple and is based upon the variable types that are common to Excel's VBA and to Delphi. Those include 32 bit integer, double precision floating point and, mainly, Excel ranges.

I found that Excel sometimes interprets incorrectly simple types when passed by reference and thus I limmited their usage to value parameters.
On the other hand, ranges can only be passed by reference and can be read from but not written to. This means that, within Delphi, you must use the reserved word CONST instead of VAR.

First, I defined within a simple unit a set of functions that convert simple Variant types to simple types and viceversa. Those are IntToVar,Double and VarTodouble (the real unit also includes a StrToVar function but not a VarToStr since this one is already included in the System unit), and are used within the procedures that do the real work (RangeToMatrix, RangeToVector,VectorToMatrix and VectortoRange).
All these functions (along with some others that you might find useful) are put together in a unit called "_Variants" whose source code is copied here (with some slight modifications).

In the real unit you will find that there fucntions that provide conversion between Excel ranges and SDL delphi component suite which I have found to be quite useful (refer to www.lohninger.com).

I shall restrict the examples, however to standard types.

Lets take first a simple function:
This function, called gamma_alfa, takes as input the mean and the variance of a population and returns the alfa parameter of a gamma distribution.

In Excel's VBA it is declared as
Declare Function gamma_alfa Lib "c:\archivos\del_files\f_auxiliares_delphi" Alias "gamma_alfa_XL" (ByVal media As Double, ByVal varianza As Double) As Double

note the lib statement that refers to name that the DLL actually has.
note also the ByVal modifiers used for declaring the variables as well as the "as double" statements.
These mean that both the input and the output will be simple types of type double.

In Delphi, the function is declared as
function gamma_alfa(media, varianza : double) : Double;stdcall;

Note the stdcall at the end of the declaration. This is to ensure that Delphi will use the Microsoft calling convention

Also note the inconsistency between the delphi function's name and the "alias" statement in VBA.
This is set in the export clause of the DLL:

exports ...,
        gamma_alfa     name 'gamma_alfa_XL',
        ...;

Although irrelevant, the implementation of the function follows:

implementation

function gamma_alfa(media, varianza: double): Double; stdcall;
begin
  gamma_alfa := media * media / varianza;
end;

Now, let's go to the tough stuff: sending Excel ranges as parameters.
Now, I will make use of a function that gets and returns excel ranges as parameters:
This function is called gamma_parametros and takes as input an histogram (with frequencies and class markers) and returns the alfa and beta parameters for a gamma. Here is its VBA declaration:

Declare Function gamma_parametros Lib "c:\archivos\del_files\f_auxiliares_delphi" Alias "gamma_parametros_XL" (ByRef marcas_de_clase As Variant, ByRef frecuencias As Variant) As Variant

Now note hte "Byref" and the as "Variant" types.

In Delphi, the function is declared as follows:

function gamma_parametros_XL(const _marcas_de_clase, _frecuencias: Variant): Variant;
  stdcall;

and is implemented as:

function gamma_parametros_XL(const _marcas_de_clase, _frecuencias: Variant): Variant;
  stdcall;
var
  marcas_de_clase, frecuencias, pars: TVector_;
  pars_: Variant;
begin
  RangeToVector(_marcas_de_clase, marcas_de_clase);
  RangeToVector(_frecuencias, frecuencias);
  pars := gamma_parametros(marcas_de_clase, frecuencias);
  VectorToRange(pars, pars_);
  gamma_parametros_XL := pars_;
end;

Note that the functions that does the real work is not gamma_parametros_XL but gamma_parametros. The former only does the job of converting Excel ranges to TVector_ and viceversa.

the exports clause exports gamma_parametros_XL, since it's the one that is replicated in the VBA definition, and thus it does not need a 'name' clause.

Here is the implementation of the gamma_parametros function:

function gamma_parametros(const marcas_de_clase, frecuencias: TVector_): TVector_;
var
  pars: TVector_;
  mu, sigmac: double;
begin
  SetLength(pars, 2);
  mu := media_ponderada(marcas_de_clase, frecuencias);
  sigmac := varianza_ponderada(marcas_de_clase, frecuencias);
  pars[0] := gamma_alfa(mu, sigmac);
  pars[1] := gamma_beta(mu, sigmac);
  gamma_parametros := pars;
end;

Here is the listing of the _Variants unit:

interface
uses SysUtils,
  excel97,
  vector,
  matrix,
  Classes,
  Dialogs,
  registry,
  windows;

type

  tmatriz = array of array of double;
  tvector_ = array of double;

function IntToVar(dato: longint): variant;
function DoubleToVar(dato: double): variant;

function VarToDouble(const dato: variant): double;

procedure RangeToMatrix(const rango: variant; var matriz: tmatriz);
procedure RangeToVector(const rango: variant; var matriz: tvector_);
procedure MatrixToRange(const matriz: tmatriz; var rango: variant);
procedure VectorToRange(const matriz: tvector_; var rango: variant);

procedure transpose(var matriz: tmatriz);

implementation

function IntToVar(dato: longint): variant;
var
  temp: variant;
begin
  tvardata(temp).vtype := VarInteger;
  tvardata(temp).Vinteger := dato;
  IntToVar := temp;
end;

function DoubleToVar(dato: double): variant;
var
  temp: variant;
begin
  tvardata(temp).vtype := VarDouble;
  tvardata(temp).VDouble := dato;
  DoubleToVar := temp;
end;

function VarToDouble(const dato: variant): double;
var
  temp: variant;
begin
  try
    temp := varastype(dato, vardouble);
  except
    on EVariantError do
    begin
      tvardata(temp).vtype := vardouble;
      tvardata(temp).vdouble := 0.0;
    end;
  end;
  VarToDouble := tvardata(temp).vdouble;
end;

procedure RangeToMatrix(const rango: variant; var matriz: tmatriz);
var
  Rows, Columns: longint;
  i, j: longint;
begin
  if ((tvardata(rango).vtype and vararray) = 0) and
    ((tvardata(rango).vtype and vartypemask) = vardispatch) then
  begin
    Rows := Rango.rows.count;
    Columns := Rango.columns.count;
    SetLength(matriz, Rows);
    for i := 0 to Rows - 1 do
      SetLength(matriz[i], Columns);
    for i := 0 to Rows - 1 do
      for J := 0 to Columns - 1 do
        matriz[i, j] := VarToDouble(Rango.cells[i + 1, j + 1]);
  end
  else if ((tvardata(rango).vtype and vararray) <> 0) then
  begin
    rows := vararrayhighbound(rango, 1) - vararraylowbound(rango, 1) + 1;
    if VarArrayDimCount(rango) = 2 then
    begin
      columns := vararrayhighbound(rango, 2) - vararraylowbound(rango, 2) + 1;
      setLength(matriz, rows);
      for i := 0 to Rows - 1 do
        SetLength(matriz[i], Columns);
      for i := 0 to Rows - 1 do
        for J := 0 to Columns - 1 do
          matriz[i, j] := vartodouble(rango[i + 1, j + 1]);
    end
    else
    begin
      setlength(matriz, 1);
      setlength(matriz[0], rows);
      for i := 0 to rows - 1 do
        matriz[0, i] := vartodouble(rango[i + 1]);
    end;
  end
  else
  begin
    rows := 1;
    columns := 1;
    setLength(matriz, rows);
    setLength(matriz[0], columns);
    matriz[0, 0] := vartodouble(rango);
  end
end;

procedure RangeToVector(const rango: variant; var matriz: tvector_);
var
  Rows, columns: longint;
  i, j: longint;
begin
  if ((tvardata(rango).vtype and vararray) = 0) and
    ((tvardata(rango).vtype and vartypemask) = vardispatch) then
  begin
    Rows := Rango.count;
    SetLength(matriz, Rows);
    for i := 0 to Rows - 1 do
      matriz[i] := VarToDouble(Rango.cells[i + 1]);
  end
  else if ((tvardata(rango).vtype and vararray) <> 0) then
  begin
    rows := vararrayhighbound(rango, 1) - vararraylowbound(rango, 1) + 1;
    if VarArrayDimCount(rango) = 1 then
    begin
      setLength(matriz, rows);
      for i := 0 to rows - 1 do
        matriz[i] := vartodouble(rango[i + 1]);
    end
    else
    begin
      columns := vararrayhighbound(rango, 2) - vararraylowbound(rango, 2) + 1;
      setlength(Matriz, Columns * Rows);
      for i := 1 to rows do
        for j := 1 to columns do
        try
          matriz[(i - 1) * columns + j] := VarToDouble(rango[i, j]);
        except
          on EVariantError do
            matriz[(i - 1) * columns + j] := 0;
        end;
    end
  end
  else
  begin
    rows := 1;
    setLength(matriz, rows);
    matriz[0] := vartodouble(rango);
  end;
end;

procedure MatrixToRange(const matriz: tmatriz; var rango: variant);
var
  Rows, Columns: longint;
  i, j: longint;
begin
  Rows := high(matriz) - low(matriz) + 1;
  Columns := high(matriz[0]) - low(matriz[0]) + 1;
  rango := VarArrayCreate([1, Rows, 1, Columns], varDouble);
  for i := 1 to Rows do
    for j := 1 to Columns do
      rango[i, j] := matriz[i - 1, j - 1];
end;

procedure VectorToRange(const matriz: tvector_; var rango: variant);
var
  Rows: longint;
  i: longint;
begin
  Rows := high(matriz) - low(matriz) + 1;
  rango := VarArrayCreate([1, Rows], varDouble);
  for i := 1 to Rows do
    rango[i] := matriz[i - 1];
end;

procedure transpose(var matriz: tmatriz);
var
  Rows, Columns,
    i, j: longint;
  temp: double;
begin
  Rows := high(matriz) - low(matriz) + 1;
  Columns := high(matriz[0]) - low(matriz[0]) + 1;
  for i := 0 to rows - 1 do
    for j := i to columns - 1 do
    begin
      temp := matriz[i, j];
      matriz[i, j] := matriz[j, i];
      matriz[j, i] := temp;
    end;
end;

end.

One final warning note:

Notice that the types' names in VBA are NOT the same as in Delphi.
The two must obvious are BOOLEAN (which in VBA is a 2 byte type whereas in Delphi is a one byte type). Thus you MUST use WORDBOOL in Delphi.
The other obvious type is INTEGER (in DElphi is a 4-byte type and in VBA a 2-byte type). To avoid confussion use LONGINT in Delphi and LONG in VBA

I will be more than glad to send you the full source code of the _Variant unit

Change the position of a list item in a TListView (3)

Problem/Question/Abstract:

I have a TListView object, and two buttons on a form. The ListView is populated with items all in one column, and I need to able to push one button to move the items up and the other button to move them down.

Answer:

Set ListView.HideSelection to false.

procedure MoveItems(AListView: TListView; Up: Boolean = True);
var
  OldItem, NewItem: TListItem;
  AIndex: Integer;
begin
  Assert(Assigned(AListView));
  with AListView do
  begin
    Items.BeginUpdate;
    try
      OldItem := TListItem.Create(Items);
      try
        OldItem.Assign(Selected);
        if Up then
          AIndex := Selected.Index - 1
        else
          AIndex := Selected.Index + 1;
        if not AIndex in [0..Items.Count - 1] then
          Exit;
        Selected.Delete;
        NewItem := Items.Insert(AIndex);
        NewItem.Assign(OldItem);
        Selected := NewItem;
      finally
        OldItem.Free;
      end;
    finally
      AListView.Checkboxes := False;
      Items.EndUpdate;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  MoveItems(ListView1, False);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  MoveItems(ListView1);
end;

Validate email address

Problem/Question/Abstract:

How to validate an email address

Answer:

function IsValidEmail(const Value: string): boolean;
  function CheckAllowed(const s: string): boolean;
  var
    i: integer;
  begin
    Result := false;
    for i := 1 to Length(s) do
    begin
      // illegal char in s -> no valid address
      if not (s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '-', '.']) then
        Exit;
    end;
    Result := true;
  end;
var
  i: integer;
  namePart, serverPart: string;
begin // of IsValidEmail
  Result := false;
  i := Pos('@', Value);
  if (i = 0) or (pos('..', Value) > 0) then
    Exit;
  namePart := Copy(Value, 1, i - 1);
  serverPart := Copy(Value, i + 1, Length(Value));
  if (Length(namePart) = 0) // @ or name missing
  or ((Length(serverPart) < 4)) {// name or server missing or } then
    Exit; // too short
  i := Pos('.', serverPart);
  // must have dot and at least 3 places from end
  if (i < 2) or (i > (Length(serverPart) - 2)) then
    Exit;
  Result := CheckAllowed(namePart) and CheckAllowed(serverPart);
end;

Create an interfaced TStringList

Problem/Question/Abstract:

How to create an interfaced TStringList

Answer:

unit InterfacedStrings;

interface

uses
  Classes;

type
  IudStrings = interface
    ['{3F36AFFE-8D71-4C24-AAE4-620A6D58E4D1}']
    function Strings: TStrings;
  end;

  TInterfacedStringList = class(TStringList, IudStrings)
  private
    FRefCount: Integer;
  protected
    { IudStrings }
    function Strings: TStrings;
    { IInterface }
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  public
    procedure AfterConstruction; override;
    class function NewInstance: TObject; override;
  end;

implementation

{ TInterfacedStringList }

function TInterfacedStringList.Strings: TStrings;
begin
  Result := Self;
end;

function TInterfacedStringList._AddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount);
end;

function TInterfacedStringList._Release: Integer;
begin
  Result := InterlockedDecrement(FRefCount);
  if Result = 0 then
    Destroy;
end;

function TInterfacedStringList.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := E_NOINTERFACE;
end;

procedure TInterfacedStringList.AfterConstruction;
begin
  inherited;
  InterlockedDecrement(FRefCount);
end;

class function TInterfacedStringList.NewInstance: TObject;
begin
  Result := inherited NewInstance;
  TInterfacedStringList(Result).FRefCount := 1;
end;

end.

Find items in a TTreeView

Problem/Question/Abstract:

How can I find a TTreeView item by string parameter? I mean like TreeNode := indexOf(Item: String);

Answer:

If you want to track the HTREEITEM ItemID's then you could use GetNode. To search by text you'll need to go through the list. Here is a quick option, depends on what you are looking to do.

{ ... }
Form1.TreeView.Items.BeginUpdate;
for count := 1 to Form1.TreeView.Items.Count do
  if (Form1.TreeView.Items.Item[count - 1].Text = 'Text') then
  begin
    {your code here;}
    {Break;}
  end;
finally
  Form1.TreeView.Items.EndUpdate;
end;

How to get the file name (and directory) of a file in the clipboard

Problem/Question/Abstract:

I need to have the filename and directory of the file which is in the clipboard. For example: In the Explorer I select a file, press ctrl+c and in my application I would like copy or do anything with it.

Answer:

procedure TMainForm.Button1Click(Sender: TObject);
var
  hDrop: THandle;
  cnt, i: Integer;
  filename: array[0..MAX_PATH - 1] of Char;
begin
  if ClipBoard.HasFormat(CF_HDROP) then
  begin
    hDrop := ClipBoard.GetAsHandle(CF_HDROP);
    cnt := DragQueryFile(hDrop, $FFFFFFFF, nil, 0);
    Memo.Clear;
    Memo.Lines.Add(Format('Found %d files:', [cnt]));
    for i := 0 to cnt - 1 do
    begin
      DragQueryFile(hDrop, i, @filename, MAX_PATH);
      Memo.lines.Add(Format('%2d: %s', [i + 1, filename]));
    end;
  end
  else
    MessageDlg(' No filename in clipboard!', mtInformation, [mbOk], 0);
end;

Accessing HotMail from Delphi

Problem/Question/Abstract:

Is it possible to access a HotMail account through the POP3 and SMTP? I know its a web front end but I'd like to write a automated application which can send and receive mail using a HotMail account.

Answer:

HotMail is not accessible through POP/SMTP. you must use their web interface.

There is no possible shortcut to read mail but you can open the default HotMail account in new message mode using this ShellExecute call:


program dummy;

var
  ToAddress: string;
  EightSpaces: string;

begin
  ToAddress := 'john@pacbell.net';
  // Don't know why but this is required to get the
  // correct compose address...
  EightSpaces := '        ';
  ShellExecute(Handle, PChar('open'), PChar('rundll32.exe'),
    PChar('C:\PROGRA~1\INTERN~1\HMMAPI.DLL,MailToProtocolHandler'
    + EightSpaces + ToAddress), nil, SW_NORMAL)
end.

How to get the system's colour palette

Problem/Question/Abstract:

I would like to automatically select colours for painting. At program start I want to use the 16 colour palette. Should the user need more colours, I would like to switch to the 256 colour palette. How can I do this?

Answer:

You can retrieve the system palette. Palettes are normally used in 16 and 256 colour mode, but the Highcolor mode also uses a system palette, which defines a range of standard colours. The following example shows how to retrieve the system palette in 256c mode:


procedure TForm1.Button1Click(Sender: TObject);
type
  TPal = array[0..255] of TPaletteEntry;
var
  pPal: ^TPal;
  i, numEntries: Integer;
begin
  pPal := nil;
  numEntries := GetSystemPaletteEntries(Canvas.handle, 0, 8, pPal^);
  if numEntries > 256 then
    numEntries := 256;
  pPal := AllocMem(numEntries * Sizeof(TPaletteEntry));
  GetSystemPaletteEntries(Canvas.Handle, 0, numEntries, pPal^);
  memo1.clear;
  for i := 0 to numEntries - 1 do
    with pPal^[i] do
      memo1.lines.add(Format('Color %d: R= %d, G= %d, B= %d', [i, pered, pegreen, peblue]));
end;

Get the local charset of a system

Problem/Question/Abstract:

How to get the local charset of a system

Answer:

function TranslateCharsetInfoEx(lpSrc: PDWORD; var lpCs: TCharsetInfo;
  dwFlags: DWORD): BOOL; stdcall; external 'gdi32.dll' name 'TranslateCharsetInfo';

procedure SetLocaleCharset;
var
  LCID, CP: Cardinal;
  Buf: array[0..6] of Char;
  CSI: TCharsetInfo;
begin
  LCID := GetThreadLocale;
  GetLocaleInfo(LCID, LOCALE_IDefaultAnsiCodePage, Buf, 6);
  CP := StrToIntDef(Buf, GetACP);
  TranslateCharsetInfoEx(Pointer(CP), CSI, TCI_SRCCODEPAGE);
  LocaleCharSet := CSI.ciCharset;
end;

Solving some problems of the TRichEdit component

Problem/Question/Abstract:

Solving some problems of the TRichEdit component.

Answer:

Problem 1
========
If you work with a TRichEdit, you'll find out that it has some problems.
In the Delphi help files you'll find a FindText and a ReplaceText
procedure as an example. Those procedures work fine on most operating
systems, but NOT on Windows 2000! If you set RichEdit1.SelStart and
RichEdit1.SelLength, under most operating systems the RichEdit scrolls
to the selected text. But not on Windows 2000. There you'll have to add
a: SendMessage(EM_SCROLLCARET,0,0); after you made the selection with
SelStart and SelLength. Only then the RichEdit under Windows 2000 will
scroll to the position of the cursor!

Problem 2
========
If you drop a RichEdit on a form, Delphi (5) doesn't add the richedit.dcu
unit to your uses clause. However, if you have included the richedit.dcu
unit yourself (manually) to your uses clause, then the following problem
occures:

In the unit "messages.dcu": EM_SCROLLCARET is defined as:
   EM_SCROLLCARET = $00B7;
  
In the unit "richedit.dcu": EM_SCROLLCARET is defined as:
   EM_SCROLLCARET = WM_USER + 49;
  
Because WM_USER is defined as $0400 (in messages.dcu) the value of
EM_SCROLLCARET becomes: $400 + 49 (decimal) = 1073 (decimal) after you
have added "richedit" to your uses clause. And that is the reason why
EM_SCROLLCARET will not work anymore... (At least under W2000. I didn't
test it on other operating systems.)

A workaround for this problem is to globally add:

Const
   EM_SCROLLCARET = $00B7;
  
to your unit.            

How to use non-standard colors in Windows

Problem/Question/Abstract:

My client wants to preserve a unique look and feel that does not depend upon the Windows color settings. For example, no matter what color the user has selected for his button color, my client wants to define the color for his application. A specific example involves SpinEdits. I'd like to define the color of the edit and the spin buttons. The easiest way for me to do this is to be able to redefine Windows colors internal to my application.

Answer:

The problem is more complicated as it seems at first glance. If your application stays on top long enough and you are pretty sure that the users aren't switching between apps at runtime, you can change the colors system wide. The sample below (quite simple, but enough to give you an idea how to do it) will help you to have the same colors on all machines, independent of the user choice. The advantage of this approach is, that you are able to use standard controls (which works fine most of the time).

In this sample I am changing 11 options. Have a look in the help files for all available options.

unit Unit1;

interface

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

type
  tarr = array[1..11] of integer;
  TForm1 = class(TForm)
    Button2: TButton;
    procedure Button2Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure FormDeactivate(Sender: TObject);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  ind: tarr;

implementation

{$R *.DFM}

procedure TForm1.Button2Click(Sender: TObject);
var
  p1, p2: tarr;
begin
  p1[1] := COLOR_ACTIVEBORDER;
  p1[2] := COLOR_APPWORKSPACE;
  p1[3] := COLOR_BTNFACE;
  p1[4] := COLOR_BTNHILIGHT;
  p1[5] := COLOR_BTNSHADOW;
  p1[6] := COLOR_BTNTEXT;
  p1[7] := COLOR_GRAYTEXT;
  p1[8] := COLOR_INACTIVEBORDER;
  p1[9] := COLOR_INACTIVECAPTION;
  {p1[9] := COLOR_INACTIVECAPTIONTEXT;}
  p1[10] := COLOR_MENU;
  p1[11] := COLOR_SCROLLBAR;
  p2[1] := 128 * 16 * 16 * 16 * 16 + 111 * 16 * 16 + 150;
  p2[2] := 84 * 16 * 16 * 16 * 16 + 72 * 16 * 16 + 100;
  p2[3] := 128 * 16 * 16 * 16 * 16 + 111 * 16 * 16 + 150;
  p2[4] := 192 * 16 * 16 * 16 * 16 + 184 * 16 * 16 + 203;
  p2[5] := 84 * 16 * 16 * 16 * 16 + 72 * 16 * 16 + 100;
  p2[6] := 0;
  p2[7] := 84 * 16 * 16 * 16 * 16 + 72 * 16 * 16 + 100;
  p2[8] := 128 * 16 * 16 * 16 * 16 + 111 * 16 * 16 + 150;
  p2[9] := 84 * 16 * 16 * 16 * 16 + 72 * 16 * 16 + 100;
  p2[10] := 128 * 16 * 16 * 16 * 16 + 111 * 16 * 16 + 150;
  p2[11] := 192 * 16 * 16 * 16 * 16 + 184 * 16 * 16 + 203;
  setsyscolors(11, p1, p2);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  p1: tarr;
begin
  p1[1] := COLOR_ACTIVEBORDER;
  p1[2] := COLOR_APPWORKSPACE;
  p1[3] := COLOR_BTNFACE;
  p1[4] := COLOR_BTNHILIGHT;
  p1[5] := COLOR_BTNSHADOW;
  p1[6] := COLOR_BTNTEXT;
  p1[7] := COLOR_GRAYTEXT;
  p1[8] := COLOR_INACTIVEBORDER;
  p1[9] := COLOR_INACTIVECAPTION;
  {p1[9] := COLOR_INACTIVECAPTIONTEXT;}
  p1[10] := COLOR_MENU;
  p1[11] := COLOR_SCROLLBAR;
  setsyscolors(11, p1, ind);
end;

procedure TForm1.FormDeactivate(Sender: TObject);
var
  p1: tarr;
begin
  p1[1] := COLOR_ACTIVEBORDER;
  p1[2] := COLOR_APPWORKSPACE;
  p1[3] := COLOR_BTNFACE;
  p1[4] := COLOR_BTNHILIGHT;
  p1[5] := COLOR_BTNSHADOW;
  p1[6] := COLOR_BTNTEXT;
  p1[7] := COLOR_GRAYTEXT;
  p1[8] := COLOR_INACTIVEBORDER;
  p1[9] := COLOR_INACTIVECAPTION;
  {p1[9] := COLOR_INACTIVECAPTIONTEXT;}
  p1[10] := COLOR_MENU;
  p1[11] := COLOR_SCROLLBAR;
  setsyscolors(11, p1, ind);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ind[1] := getsyscolor(COLOR_ACTIVEBORDER);
  ind[2] := getsyscolor(COLOR_APPWORKSPACE);
  ind[3] := getsyscolor(COLOR_BTNFACE);
  ind[4] := getsyscolor(COLOR_BTNHILIGHT);
  ind[5] := getsyscolor(COLOR_BTNSHADOW);
  ind[6] := getsyscolor(COLOR_BTNTEXT);
  ind[7] := getsyscolor(COLOR_GRAYTEXT);
  ind[8] := getsyscolor(COLOR_INACTIVEBORDER);
  ind[9] := getsyscolor(COLOR_INACTIVECAPTION);
  {ind[9] := getsyscolor(COLOR_INACTIVECAPTIONTEXT);}
  ind[10] := getsyscolor(COLOR_MENU);
  ind[11] := getsyscolor(COLOR_SCROLLBAR);
  application.OnDeactivate := formdeactivate;
  application.OnActivate := button2click;
end;

end.

How to get a list of all network adapters of a PC

Problem/Question/Abstract:

How to get a list of all network adapters of a PC

Answer:

Example which can be used for all other hardware, too. Doesn't seem to work for Win 2000 though.

uses
  Registry;

procedure GetNetworkAdapters(const List: TStrings);
var
  R: TRegistry;
  i: Integer;
begin
  List.BeginUpdate;
  try
    R := TRegistry.Create;
    try
      R.RootKey := HKEY_DYN_DATA;
      if R.OpenKeyReadOnly('\Config Manager\Enum') then
      try
        R.GetKeyNames(List);
      finally
        R.CloseKey;
      end;
      for i := List.Count - 1 downto 0 do
        if (List[i] = '') or
                                        not R.OpenKeyReadOnly('\Config Manager\Enum\' + List[i]) then
          List.Delete(i)
        else
        try
          List[i] := R.ReadString('HardwareKey');
        finally
          R.CloseKey;
        end;
      R.RootKey := HKEY_LOCAL_MACHINE;
      for i := List.Count - 1 downto 0 do
        if (List[i] = '') or not R.OpenKeyReadOnly('\Enum\' + List[i]) then
          List.Delete(i)
        else
        try
          if CompareText(R.ReadString('Class'), 'net') = 0 then
            List[i] := R.ReadString('DeviceDesc')
          else
            List.Delete(i);
        finally
          R.CloseKey;
        end;
    finally
      R.Free;
    end;
  finally
    List.EndUpdate;
  end;
end;

How to disable the CD autorun feature through code

Problem/Question/Abstract:

How to disable the CD autorun feature through code

Answer:

Solve 1:

uses
  Registry;

function IsCdAutoRunOn: bool;
var
  reg: TRegistry;
  AutoRunSetting: integer;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_CURRENT_USER;
  reg.OpenKey('Software\Microsoft\Windows\' + 'CurrentVersion\Policies\Explorer',
    false);
  reg.ReadBinaryData('NoDriveTypeAutoRun', +AutoRunSetting, sizeof(AutoRunSetting));
  reg.CloseKey;
  reg.free;
  result := not ((AutoRunSetting and (1 shl 5)) <> 0);
end;

procedure SetCdAutoRun(bOn: bool);
var
  reg: TRegistry;
  AutoRunSetting: integer;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_CURRENT_USER;
  reg.LazyWrite := false;
  reg.OpenKey('Software\Microsoft\Windows\' + 'CurrentVersion\Policies\Explorer',
    false);
  reg.ReadBinaryData('NoDriveTypeAutoRun', +AutoRunSetting, sizeof(AutoRunSetting));
  if bOn then
    AutoRunSetting := AutoRunSetting and not (1 shl 5)
  else
    AutoRunSetting := AutoRunSetting or (1 shl 5);
  reg.WriteBinaryData('NoDriveTypeAutoRun', +AutoRunSetting, sizeof(AutoRunSetting));
  reg.CloseKey;
  reg.free;
end;


Solve 2:

After an hour of tinkering with some samples on the Internet I came up with the proper registry setting to turn on/off the CDROM AutoRun feature. The first thing wrong with all the samples was the type of value we need to store in the registry, I found that binary is what works. The next thing most samples neglected to say, besides being just wrong, was that you need to reboot your system after making the change. This tip was tested on Windows98, so this registry setting may differ a little for other operating systems. We will be using the TRegistry object using TRegistry.KeyExists, TRegistry.OpenKey, and TRegistry.WriteBinaryData

First we will need to add Registry to our unit's uses clause
Next we will need a TButton and a TButton.OnClick event. You can easily create this event through the Object Inspector Events tab
We will then declare a new procedure that will make the settings according to the boolean parameter sent in
In our routine we will first create our TRegistry object, then we will set the TRegistry.RootKey. Next we will check to see if the CDROM registry key exists before trying to open it. After opening the CDROM registry key we will add AutoRun to it according to the boolean parameter sent into the procedure
TRegistry.KeyExists returns TRUE is the specified registry key exists. The only parameter is a string to the key in the registry. If we set TRegistry.RootKey then we do not have to specify it within the string parameter
TRegistry.OpenKey returns TRUE if the specified registry key opens successfully. The first parameter is a string to the key in the registry. As mentioned above, if we set TRegistry.RootKey then we do not have to specify it within the string parameter. The second parameter is a boolean value telling Windows whether or not to create the key if it does not exist, we will set this to FALSE
TRegistry.WriteBinaryData stores binary data to the registry. The first parameter is the name to stoe under the open registry key. The second parameter is the value to store. The last parameter is the size of the binary value we are storing


{...}

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

  {...}

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

procedure TForm1.SetCDAutoRun(AAutoRun: Boolean);
const
  DoAutoRun: array[Boolean] of Integer = (0, 1);
var
  Reg: TRegistry;
begin
  try
    { create our registry object }
    Reg := TRegistry.Create;
    { set our registry root key }
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    { verify that our CDROM class key exists }
    if Reg.KeyExists('System\CurrentControlSet\Services\Class\CDROM') then
      { try to open our CDROM class key }
      if Reg.OpenKey('System\CurrentControlSet\Services\Class\CDROM', FALSE) then
        { add AutoRun to our CDROM class key }
        Reg.WriteBinaryData('AutoRun', DoAutoRun[AAutoRun], 1);
  finally
    { free our registry object }
    Reg.Free;
  end;
  { showmessage that the changes will happen on reboot }
  ShowMessage('Your settings will take effect on the next reboot of Windows.');
end;

{...}

How to minimize and restore all open applications

Problem/Question/Abstract:

How to minimize and restore all open applications

Answer:

procedure MinimizeAll;
begin
  { [Window key] + 'M' minimizes all windows, [Win][Shift] + 'M' restores them }
  keybd_event(VK_LWIN, MapvirtualKey(VK_LWIN, 0), 0, 0);
  keybd_event(Ord('M'), MapvirtualKey(Ord('M'), 0), 0, 0);
  keybd_event(Ord('M'), MapvirtualKey(Ord('M'), 0), KEYEVENTF_KEYUP, 0);
  keybd_event(VK_LWIN, MapvirtualKey(VK_LWIN, 0), KEYEVENTF_KEYUP, 0);
end;

procedure UnMinimizeAll;
begin
  { [Window key] + 'M' minimizes all windows, [Win][Shift] + 'M' restores them }
  keybd_event(VK_LWIN, MapvirtualKey(VK_LWIN, 0), 0, 0);
  keybd_event(VK_SHIFT, MapvirtualKey(VK_SHIFT, 0), 0, 0);
  keybd_event(Ord('M'), MapvirtualKey(Ord('M'), 0), 0, 0);
  keybd_event(Ord('M'), MapvirtualKey(Ord('M'), 0), KEYEVENTF_KEYUP, 0);
  keybd_event(VK_SHIFT, MapvirtualKey(VK_SHIFT, 0), KEYEVENTF_KEYUP, 0);
  keybd_event(VK_LWIN, MapvirtualKey(VK_LWIN, 0), KEYEVENTF_KEYUP, 0);
end;

"ntdll.DbgUserBreakPoint" during debug startup

Problem/Question/Abstract:

Whenever I start a program from the IDE with debugging enabled, the CPU window pops up and it reports something like ntdll.DbgUserBreakPoint - but I do not have any breakpoints set in my project.

Answer:

This is debug code in NTDLL.DLL itself. It gets executed if you have more than 16 colors for the application icon. You can help yourself by changing the number of colors for icons (Control Panel, Display Properties).

Microsoft must have hard-coded a debug breakpoint (int 3) in ntdll.dll to trace a bug and then they forgot to take it out for final build of Windows NT.

Insert a row in a TStringGrid at a certain position

Problem/Question/Abstract:

Is there a method to insert a row into a StringGrid or do I have to shuffle all higher rows up 1?

Answer:

TCustomGrid has a very useful but unfortunately protected method named MoveRow. You can get at it using the cracker class strategy:

type
  TGridCracker = class(TCustomGrid);

{insert a line at row 5}
stringgrid1.rowcount := stringgrid1.rowcount + 1;
TGridCracker(stringgrid1).Moverow(stringgrid1.rowcount - 1, 5);

You first add a new empty line, then move it to the required position. This automatically moves all following lines one position down.

Several color rows in TStringGrid

Problem/Question/Abstract:

Show several color in the rows of a TStringGrid.

Answer:

Using the OnDrawCell event...

Put this code in the event OnDrawCell of the StringGrid:

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
begin
  with (Sender as TStringGrid) do begin
    if (Arow And 1)=1 then Canvas.Font.Color := clRed   { En rojo / in red }
                      else Canvas.Font.Color := clBlue; { En Azul / in Blue }

    Canvas.TextRect( Rect,
                     Rect.Left + 2,
                     Rect.Top + 2,
                     Cells[Acol,Arow]);
  end;
end;

This example shows the even lines with a color and the odd with other...

How to convert a word wrap in a TMemo to a CR/LF

Problem/Question/Abstract:

Using a TMemo, is it possible to convert each wrap to a CR/LF, or even at a specific column (like 67 or 80)?

Answer:

const
  limit = 67;
var
  S: string;
  i: Integer;
begin
  S := Memo1.Text;
  Memo1.Clear;
  repeat
    i := limit;
    while S[i] <> ' ' do
      Dec(i);
    Memo1.Lines.Add(Trim(Copy(S, 1, i)));
    Delete(S, 1, i);
  until
    Length(S) = 0;
end;

AdjustTokenPrivileges function to enable a privilege (NT)

Problem/Question/Abstract:

For some functions you need to get the right privileges on a Windows NT machine. (e.g: To shut down or restart windows with ExitWindowsEx or to change the system time)

Answer:

The following code provides a procedure to adjust the privileges. The AdjustTokenPrivileges() function enables or disables privileges in the specified access token.

// NT Defined Privileges from winnt.h

const
  SE_CREATE_TOKEN_NAME = 'SeCreateTokenPrivilege';
  SE_ASSIGNPRIMARYTOKEN_NAME = 'SeAssignPrimaryTokenPrivilege';
  SE_LOCK_MEMORY_NAME = 'SeLockMemoryPrivilege';
  SE_INCREASE_QUOTA_NAME = 'SeIncreaseQuotaPrivilege';
  SE_UNSOLICITED_INPUT_NAME = 'SeUnsolicitedInputPrivilege';
  SE_MACHINE_ACCOUNT_NAME = 'SeMachineAccountPrivilege';
  SE_TCB_NAME = 'SeTcbPrivilege';
  SE_SECURITY_NAME = 'SeSecurityPrivilege';
  SE_TAKE_OWNERSHIP_NAME = 'SeTakeOwnershipPrivilege';
  SE_LOAD_DRIVER_NAME = 'SeLoadDriverPrivilege';
  SE_SYSTEM_PROFILE_NAME = 'SeSystemProfilePrivilege';
  SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege';
  SE_PROF_SINGLE_PROCESS_NAME = 'SeProfileSingleProcessPrivilege';
  SE_INC_BASE_PRIORITY_NAME = 'SeIncreaseBasePriorityPrivilege';
  SE_CREATE_PAGEFILE_NAME = 'SeCreatePagefilePrivilege';
  SE_CREATE_PERMANENT_NAME = 'SeCreatePermanentPrivilege';
  SE_BACKUP_NAME = 'SeBackupPrivilege';
  SE_RESTORE_NAME = 'SeRestorePrivilege';
  SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
  SE_DEBUG_NAME = 'SeDebugPrivilege';
  SE_AUDIT_NAME = 'SeAuditPrivilege';
  SE_SYSTEM_ENVIRONMENT_NAME = 'SeSystemEnvironmentPrivilege';
  SE_CHANGE_NOTIFY_NAME = 'SeChangeNotifyPrivilege';
  SE_REMOTE_SHUTDOWN_NAME = 'SeRemoteShutdownPrivilege';
  SE_UNDOCK_NAME = 'SeUndockPrivilege';
  SE_SYNC_AGENT_NAME = 'SeSyncAgentPrivilege';
  SE_ENABLE_DELEGATION_NAME = 'SeEnableDelegationPrivilege';
  SE_MANAGE_VOLUME_NAME = 'SeManageVolumePrivilege';

  // Enables or disables privileges depending on the bEnabled value

function NTSetPrivilege(sPrivilege: string; bEnabled: Boolean): Boolean;
var
  hToken: THandle;
  TokenPriv: TOKEN_PRIVILEGES;
  PrevTokenPriv: TOKEN_PRIVILEGES;
  ReturnLength: Cardinal;
begin
  Result := True;
  // Only for Windows NT/2000/XP and later.
  if not (Win32Platform = VER_PLATFORM_WIN32_NT) then
    Exit;
  Result := False;

  // obtain the processes token
  if OpenProcessToken(GetCurrentProcess(),
    TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
  begin
    try
      // Get the locally unique identifier (LUID) .
      if LookupPrivilegeValue(nil, PChar(sPrivilege),
        TokenPriv.Privileges[0].Luid) then
      begin
        TokenPriv.PrivilegeCount := 1; // one privilege to set

        case bEnabled of
          True: TokenPriv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
          False: TokenPriv.Privileges[0].Attributes := 0;
        end;

        ReturnLength := 0; // replaces a var parameter
        PrevTokenPriv := TokenPriv;

        // enable or disable the privilege

        AdjustTokenPrivileges(hToken, False, TokenPriv, SizeOf(PrevTokenPriv),
          PrevTokenPriv, ReturnLength);
      end;
    finally
      CloseHandle(hToken);
    end;
  end;
  // test the return value of AdjustTokenPrivileges.
  Result := GetLastError = ERROR_SUCCESS;
  if not Result then
    raise Exception.Create(SysErrorMessage(GetLastError));
end;