Resize a *.jpg image and save the result to a file (2)

Problem/Question/Abstract:

Before importing an image (jpg) into a database, I would like to resize it (reduce its size) and generate the corresponding smaller file. How can I do this?

Answer:

Load the JPEG into a bitmap, create a new bitmap of the size that you want and pass them both into SmoothResize then save it again ... there's a neat routine JPEGDimensions that gets the JPEG dimensions without actually loading the JPEG into a bitmap, saves loads of time if you only need to test its size before resizing.

{ ... }
type
  TRGBArray = array[Word] of TRGBTriple;
  pRGBArray = ^TRGBArray;
  { ... }

procedure SmoothResize(Src, Dst: TBitmap);
var
  x, y: integer;
  xP, yP: integer;
  xP2, yP2: integer;
  SrcLine1, SrcLine2: pRGBArray;
  t3: integer;
  z, z2, iz2: integer;
  DstLine: pRGBArray;
  DstGap: integer;
  w1, w2, w3, w4: integer;
begin
  Src.PixelFormat := pf24Bit;
  Dst.PixelFormat := pf24Bit;
  if (Src.Width = Dst.Width) and (Src.Height = Dst.Height) then
    Dst.Assign(Src)
  else
  begin
    DstLine := Dst.ScanLine[0];
    DstGap := Integer(Dst.ScanLine[1]) - Integer(DstLine);
    xP2 := MulDiv(pred(Src.Width), $10000, Dst.Width);
    yP2 := MulDiv(pred(Src.Height), $10000, Dst.Height);
    yP := 0;
    for y := 0 to pred(Dst.Height) do
    begin
      xP := 0;
      SrcLine1 := Src.ScanLine[yP shr 16];
      if (yP shr 16 < pred(Src.Height)) then
        SrcLine2 := Src.ScanLine[succ(yP shr 16)]
      else
        SrcLine2 := Src.ScanLine[yP shr 16];
      z2 := succ(yP and $FFFF);
      iz2 := succ((not yp) and $FFFF);
      for x := 0 to pred(Dst.Width) do
      begin
        t3 := xP shr 16;
        z := xP and $FFFF;
        w2 := MulDiv(z, iz2, $10000);
        w1 := iz2 - w2;
        w4 := MulDiv(z, z2, $10000);
        w3 := z2 - w4;
        DstLine[x].rgbtRed := (SrcLine1[t3].rgbtRed * w1 + SrcLine1[t3 + 1].rgbtRed *
          w2 +
          SrcLine2[t3].rgbtRed * w3 + SrcLine2[t3 + 1].rgbtRed * w4) shr 16;
        DstLine[x].rgbtGreen := (SrcLine1[t3].rgbtGreen * w1 + SrcLine1[t3 +
          1].rgbtGreen * w2 +
          SrcLine2[t3].rgbtGreen * w3 + SrcLine2[t3 + 1].rgbtGreen * w4) shr 16;
        DstLine[x].rgbtBlue := (SrcLine1[t3].rgbtBlue * w1 + SrcLine1[t3 + 1].rgbtBlue
          * w2 +
          SrcLine2[t3].rgbtBlue * w3 + SrcLine2[t3 + 1].rgbtBlue * w4) shr 16;
        inc(xP, xP2);
      end;
      inc(yP, yP2);
      DstLine := pRGBArray(Integer(DstLine) + DstGap);
    end;
  end;
end;

function LoadJPEGPictureFile(Bitmap: TBitmap; FilePath, Filename: string): boolean;
var
  JPEGImage: TJPEGImage;
begin
  if (Filename = '') then
    {No filename so nothing to load - return false ...}
    Result := false
  else
  begin
    try
      JPEGImage := TJPEGImage.Create;
      try
        JPEGImage.LoadFromFile(FilePath + Filename);
        Bitmap.Assign(JPEGImage);
        Result := true;
      finally
        JPEGImage.Free;
      end;
    except
      Result := false;
    end;
  end;
end;

function SaveJPEGPictureFile(Bitmap: TBitmap; FilePath, Filename: string;
  Quality: integer): boolean;
begin
  Result := true;
  try
    if ForceDirectories(FilePath) then
    begin
      with TJPegImage.Create do
      begin
        try
          Assign(Bitmap);
          CompressionQuality := Quality;
          SaveToFile(FilePath + Filename);
        finally
          Free;
        end;
      end;
    end;
  except
    raise;
    Result := false;
  end;
end;

function JPEGDimensions(Filename: string; var X, Y: Word): boolean;
var
  SegmentPos: integer;
  SOIcount: integer;
  b: byte;
begin
  Result := false;
  with TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone) do
  begin
    try
      Position := 0;
      Read(X, 2);
      if (X <> $D8FF) then
        exit;
      SOIcount := 0;
      Position := 0;
      while (Position + 7 < Size) do
      begin
        Read(b, 1);
        if (b = $FF) then
        begin
          Read(b, 1);
          if (b = $D8) then
            inc(SOIcount);
          if (b = $DA) then
            break;
        end;
      end;
      if (b <> $DA) then
        exit;
      SegmentPos := -1;
      Position := 0;
      while (Position + 7 < Size) do
      begin
        Read(b, 1);
        if (b = $FF) then
        begin
          Read(b, 1);
          if (b in [$C0, $C1, $C2]) then
          begin
            SegmentPos := Position;
            dec(SOIcount);
            if (SOIcount = 0) then
              break;
          end;
        end;
      end;
      if (SegmentPos = -1) then
        exit;
      if (Position + 7 > Size) then
        exit;
      Position := SegmentPos + 3;
      Read(Y, 2);
      Read(X, 2);
      X := Swap(X);
      Y := Swap(Y);
      Result := true;
    finally
      Free;
    end;
  end;
end;

Using SetMapMode during printing

Problem/Question/Abstract:

Printing something is relatively easy with Delphi. But there are times, when you need to use the same functions for drawing on screen canvas and on printer. Did you ever try to? And you got the printer image much smaller, than on the screen, right? That's because you have to change coordinates passed to GDI functions or use SetMapMode function. The article is about how to use this function and a bit more.

Answer:

Suppose you need to draw a rectangle with coordinates ((0,0),(300,300)). On the screen such rectangle will be a bit bigger than one inch (at least on 1024*768 resolution on 15' monitor). But when you call Printer.Canvas.FrameRect(Rect(0, 0, 300, 300)), you get a tiny rectangle with side length of .39 inch.
So, you need to perform transformation of coordinate system before printing.
Open MSDN, see SetMapMode, feel happy. You find, that MM_ANISOTROPIC mode is what you need (remember, that printers have different vertical and horizontal resolution and page size, so you need to use MM_ANISOTROPIC parameter).

SetMapMode(TmpDC, MM_ANISOTROPIC);
// we use TmpDC to prepare an image, that will be later copied to printer
// canvas.

But then you need to call a couple of other functions to do the job.
These functions are SetWindowExtEx and SetViewPortExtEx. As described in documentation, these functions let you set logical and "physical" coordinate systems for device context. What parameters do you have to pass to it?
Logical coordinates is the size of the screen part needed to display an image in WYSIWYG mode (to get the same size as on the screen).
Physical coordinates define the size in pixels of the device media (paper in our case).

We will find the real size of the paper in 0.01 mm. It will be used in further calculations:

// find the width of the printer page
MMWidth := MulDiv(GetDeviceCaps(PrinterDC, PHYSICALWIDTH), 2540,
  GetDeviceCaps(PrinterDC, LOGPIXELSX));
// find the height of the printer page
MMHeight := MulDiv(GetDeviceCaps(PrinterDC, PHYSICALHEIGHT), 2540,
  GetDeviceCaps(PrinterDC, LOGPIXELSY));

Now you have to set logical coordinates using SetWindowExtEx and physical dimensions of device context (actually, paper size) using SetViewPortExtEx.

SetWindowExtEx(TmpDC, LogExtX, LogExtY, nil);
SetViewPortExtEx(TmpDC, PhExtX, PhExtY, nil);

How do we calculate LogExt* parameters?

ScreenDC := GetDC(0);
// now find logical width of the screen space, needed to display the image in WYSIWYG mode
// Scale parameter is used to provide scaling during printing.
LogExtX := MulDiv(MMWidth, 100 * GetDeviceCaps(ScreenDC, LOGPIXELSX), 2540 * Scale);
// now find logical height of the screen space, needed to display the image in WYSIWYG mode
// Scale parameter is used to provide scaling during printing.
LogExtY := MulDiv(Printer.PageHeight, 100 * GetDeviceCaps(DC, LOGPIXELSY), 2540 *
  Scale);
ReleaseDC(0, screenDC);

How do we calculate PhExt* parameters?

PhExtX := MulDiv(Printer.PageWidth, GetDeviceCaps(Printer.PrinterDC, LOGPIXELSX),
  2540);
PhExtY := MulDiv(Printer.PageHeight, GetDeviceCaps(Printer.PrinterDC, LOGPIXELSY),
  2540);

That's all, folks :). Now you can safely draw the rectangle.
Remember to restore MapMode after you finished drawing (you can save MapMode using GetMapMode function).

Combine the co-related functions into one single function

Problem/Question/Abstract:

How to make the same function to return the value you want? How to combine the co-related functions into one single function and Still get the values what all the functions returned ?

Answer:

Let us take the example of  the functions which returns the Year, Month, Day, Month name, Day name and the  date in a particular format for eg. Britishformat. We have to write a separate functions for returning the desired values.  For eg.

function Year(Value: Tdatetime): Word;
var
  vY, vM, vD: Word;
begin
  DecodeDate(now, vY, vM, vD);
  Result := vY;
end;

function Month(Value: Tdatetime): Word;
var
  vY, vM, vD: Word;
begin
  DecodeDate(now, vY, vM, vD);
  Result := vM;
end;

function Day(Value: Tdatetime): Word;
var
  vY, vM, vD: Word;
begin
  DecodeDate(now, vY, vM, vD);
  Result := vD;
end;

function Dayname(Value: Tdatetime): Word;
begin
  Result := Formatdatetime('dddd', now);
end;

function Britishformat(Value: Tdatetime): string;
begin
  Result := Formatdatetime('dd/mm/yyyy', now);
end;

Since all these functions are related with  date, we can combine them into a single function and still get all the values by telling the function what value to return.

For this, first of all we have to declare a record constant, under type section of the unit in which the function is going to reside. Name fields properly as you name the function and the field value to the desired value that you want to return. For eg.

TMyDate = record
  Year, Month, Day: Word;
  ShortMonthName, LongMonthName, ShortDay, LongDay,
    BritishFormat, AmericanFormat,
    ItalianFormat, RDBMSFormat: string;
  LeapYear: Boolean;
end;

If you are not worried about the return value, then keep all fieldvalues of the record as variant. This will reduce the work load of convertion.

Next make a function declaration , depending on the scope of visibility,  under the appropriate section . Lets us name the function as ConvertDate which accepts date as a Tdatetime value and returns the record of TmyDate.

function ConvertDate(Value: Tdatetime): TMyDate;

Now under the implementation section the function would be as given below.

function ConvertDate(Value: Tdatetime): TMyDate;
var
  vY, vM, vD: Word;
begin
  DecodeDate(Value, vY, vM, vD);
  Result.Year := vY;
  Result.Month := vM;
  Result.Day := vD;
  Result.LeapYear := IsLeapYear(vY);
  Result.ShortDay := FormatDateTime('ddd', Value);
  Result.LongDay := FormatDateTime('dddd', Value);
  Result.ShortMonthName := FormatDateTime('mmm', Value);
  Result.LongMonthName := FormatDateTime('mmmm', Value);
  Result.AmericanFormat := FormatDateTime('yyyy/mm/dd', Value);
  Result.ItalianFormat := FormatDateTime('mm-dd-yyyy', Value);
  Result.BritishFormat := FormatDateTime('dd/mm/yyyy', Value);
  Result.RDBMSFormat := FormatDateTime('dd-mmm-yyyy', Value);
end;                      

Calling the function.

If you have three variables varYear, varMonth of word and varBritishformat of string into which you want to store the return values of the function. Then

varYear := ConvertDate(now).Year;
varMonth := ConvertDate(now).Month;
varBritishformat := ConvertDate(now).BritishFormat;

Combining the functions will reduce the headace of remembering the different function names, reduce the lines of  coding, and its easy to use.

My Assertion Handler

Problem/Question/Abstract:

How do you implement your own handler for assertion failures?

Answer:

program AssertDemo;
{
  Copyright (c) 2001 by E.J.Molendijk
  Delphi Factory Netherlands BV

  This little program demonstrates the use
  of your own assertion handler.
  Check out the AssertErrorHandler() procedure in SysUtils.pas to
  see how borland has implemented their (far more complex) handler.
}

uses
  Dialogs;

procedure MyAssertErrorHandler(const Message, Filename: string;
  LineNumber: Integer; ErrorAddr: Pointer);
begin
  ShowMessageFmt(
    'This is my own assertion handler for %s line %d: %s',
    [Filename, LineNumber, Message]);
  // you could save the information to a file or something...
end;

begin
  AssertErrorProc := @MyAssertErrorHandler;
  assert(false, 'assertion failure test');
end.

Restore files from the recycle bin and delete files present in the recycle bin

Problem/Question/Abstract:

How to restore files from the recycle bin and delete files present in the recycle bin.

Answer:

To restore as well as delete file from the bin you need to make use of the following functions.

function SHQueryRecycleBin(pszrtootpath: pchar; QUERYRBINFO: pshqueryrbinfo): integer;
  stdcall; external 'shell32' name 'SHQueryRecycleBinA';
  //used to get the number of files in the bin.

function _FindFirstChangeNotification(lpPathName: PChar; bWatchSubtree: TWinBool;
  dwNotifyFilter:
  DWORD): THandle; stdcall; external kernel32 name 'FindFirstChangeNotificationA';
// used to notify the program when user has deleted a file

function SHEmptyRecycleBin(hwnd: thandle; pszRootPath: pchar; dwFlags: integer):
  integer; stdcall; external 'shell32.dll' name 'SHEmptyRecycleBinA';
  //This function empties the recycle bin.

In delphi the function FindFirstChangeNotification is already declared but in Delphi 3 and above it does not work correctly.If the second parameter is true then the function always returns an invalid handle.(visit http://members.aye.net/~bstowers/delphi/bugs/ for more info).

So you need to redeclare the FindFirstChangeNotification function as shown below.

type
  TWinBool = (winFalse, winTrue);

function _FindFirstChangeNotification(lpPathName: PChar; bWatchSubtree: TWinBool;
  dwNotifyFilter:
  DWORD): THandle; stdcall; external kernel32 name 'FindFirstChangeNotificationA';

The above function is used to refresh the list of files in the recyclebin when the user deletes  a file.

To use this function we have to first create a thread.This thread checks continuosly checks whether any file was deleted and then refreshes the list of deleted items.

For more information see delphi tips 'SHQUERYBINFO', 'SHemptyrecycleBin',
'Get the list of files from bin'.

Here is the code of the thread.

unit Unit2;

interface

uses
  Classes, SysUtils, windows;

type
  TFileChangeNotify = class(TThread)
  private

  protected
    procedure Execute; override;
    procedure filenotify; //refreshes the list when user has deleted a file.
  end;
var
  qh1: thandle;
implementation

uses
  unit1;

procedure TFileChangeNotify.filenotify;
begin
  form1.refreshlist;
end;

procedure TFileChangeNotify.Execute;
var
  pdir: pchar;
  st: integer;
  tmp: boolean;
begin
  pdir := 'C:\';
  qh1 := 0;
  qh1 := _FindFirstChangeNotification(pdir, Twinbool(1),
    FILE_NOTIFY_CHANGE_LAST_WRITE);
  while true do
  begin
    st := WaitForSingleObject(qh1, INFINITE);
    if st = WAIT_OBJECT_0 then
    begin
      Synchronize(filenotify);
      SHUpdateRecycleBinIcon;
    end;
    tmp := findnextchangenotification(qh1);
    if tmp = false then
      Terminate;
  end;
end;

end.

You need to add a Tlistview control to your form, and add two columns to it.
Here is the code of main program.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Menus, ComCtrls, unit2; {unit2 is the unit in which the thread resides}

const
  SHERB_NOCONFIRMATION = $1;
const
  SHERB_NOPROGRESSUI = $2;
const
  SHERB_NOSOUND = $4;

type
  TWinBool = (winFalse, winTrue);

type
  Tfbuf = packed record
    data: array[0..255] of char;
    u1: array[0..3] of char;
    recno: smallint;
    u2: array[0..18] of char;
  end;

type
  SHQUERYRBINFO = packed record
    cbSize: integer;
    i64Size: int64;
    i64NumItems: int64;
  end;
  pshqueryrbinfo = ^SHQUERYRBINFO;

function SHQueryRecycleBin(pszrtootpath: pchar; QUERYRBINFO: pshqueryrbinfo): integer;
  stdcall; external 'shell32' name 'SHQueryRecycleBinA';
function _FindFirstChangeNotification(lpPathName: PChar; bWatchSubtree: TWinBool;
  dwNotifyFilter: DWORD): THandle; stdcall; external kernel32 name
  'FindFirstChangeNotificationA';
function SHUpdateRecycleBinIcon: integer; stdcall; external 'shell32.dll';
function SHEmptyRecycleBin(hwnd: thandle; pszRootPath: pchar; dwFlags: integer):
  integer; stdcall; external 'shell32.dll' name 'SHEmptyRecycleBinA';

type
  TForm1 = class(TForm)
    RBinList: TListView;
    MainMenu1: TMainMenu;
    file1: TMenuItem;
    View1: TMenuItem;
    Refresh1: TMenuItem;
    Edit1: TMenuItem;
    SelectAll1: TMenuItem;
    Restore1: TMenuItem;
    N1: TMenuItem;
    Delete1: TMenuItem;
    N2: TMenuItem;
    Close1: TMenuItem;
    InvertSelection1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure Refresh1Click(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure file1Click(Sender: TObject);
    procedure SelectAll1Click(Sender: TObject);
    procedure InvertSelection1Click(Sender: TObject);
    procedure Restore1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Close1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Delete1Click(Sender: TObject);
  private
    { Private declarations }
  public
    qh: thandle;
    procedure refreshlist;
    function updateinfo(fname: string): boolean;
      //Makes appropriate changes to the INFO2 file
    //present in recycled folder.
    procedure Restorefiles; //restores the selected files from the recycle bin.
    procedure deletefiles; //deletes the selected files from the recycle bin.
  end;

var
  Form1: TForm1;
  rbinfo: SHQUERYRBINFO;
  reccount: integer;
  fhandle: integer;
  monitorthread: TFileChangeNotify;

implementation

{$R *.DFM}

procedure tform1.deletefiles;
var
  i: integer;
  sname: string;
  dname: string;
begin
  monitorthread.Suspend;
  for i := 0 to rbinlist.Items.Count - 1 do
  begin
    if rbinlist.Items[i].Selected = true then
    begin
      sname := ExtractFileDrive(rbinlist.Items[i].SubItems[0]) + '\Recycled\DC' +
        rbinlist.Items[i].SubItems[1] + ExtractFileExt(rbinlist.Items[i].caption);
      dname := rbinlist.Items[i].SubItems[0] + rbinlist.Items[i].caption;
      deleteFile(sname);
      updateinfo(dname);
    end;
  end;
  monitorthread.Resume;
end;

function tform1.updateinfo(fname: string): boolean;
var
  rbuff: Tfbuf;
  fread: integer;
  tsize: integer;
  aname: pchar;
  ch: char;
begin
  result := false;
  ch := #0;
  fhandle := fileopen('C:\recycled\info2', fmOpenReadWrite or fmShareDenyNone);
  if fhandle > 0 then
  begin
    tsize := GetFileSize(fhandle, nil);
    setfilepointer(fhandle, 20, nil, FILE_BEGIN);
    fread := 20;
    while (fread
      begin
        fread := fread + fileread(fhandle, rbuff, 280);
        if rbuff.data[0] <> #0 then
        begin
          aname := pchar(@rbuff.data[0]);
          if StrComp(aname, pchar(fname)) = 0 then
          begin
            setfilepointer(fhandle, -280, nil, FILE_CURRENT);
            filewrite(fhandle, ch, 1);
            result := true;
            break;
          end;
        end;
      end;
      fileclose(fhandle);
  end;
end;

procedure tform1.refreshlist;
var
  rbuff: Tfbuf;
  fread: integer;
  tsize: integer;
  aname: pchar;
  fitem: tlistitem;
  dname: pchar;
  iconhandle: thandle;
  tmp: word;
  iconid: integer;
  icon: ticon;
begin
  monitorthread.Suspend;
  zeromemory(@rbuff, sizeof(rbuff));
  rbinlist.Items.Clear;
  fhandle := fileopen('C:\recycled\info2', fmOpenRead);
  if fhandle > 0 then
  begin
    tsize := GetFileSize(fhandle, nil);
    setfilepointer(fhandle, 20, nil, FILE_BEGIN);
    fread := 20;
    while (fread
      begin
        fread := fread + fileread(fhandle, rbuff, 280);
        if rbuff.data[0] <> #0 then
        begin
          aname := pchar(@rbuff.data[0]);
          dname := pchar((ExtractFileDrive(aname) + '\Recycled\DC' + inttostr
            (rbuff.recno) + extractfileext(aname)));
          iconhandle := ExtractAssociatedIcon(HInstance, dname, tmp);
          icon.Handle := iconhandle;
          iconid := largeimagelist.AddIcon(icon);
          fitem := rbinlist.Items.add;
          fitem.ImageIndex := iconid;
          fitem.Caption := ExtractFileName(aname);
          fitem.SubItems.Add(ExtractFilePath(aname));
          fitem.SubItems.add(inttostr(rbuff.recno));
        end;
      end;
      fileclose(fhandle);
  end;
  rbinfo.cbSize := sizeof(rbinfo);
  rbinfo.i64NumItems := 0;
  rbinfo.i64Size := 0;
  SHQueryRecycleBin('C:\', @rbinfo);
  if (rbinlist.items.count = 0) and (rbinfo.i64Size <> 0) then
    SHEmptyRecycleBin(form1.handle, 'C:\', SHERB_NOCONFIRMATION or
      SHERB_NOPROGRESSUI);
  monitorthread.resume;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  monitorthread := TFileChangeNotify.Create(false);
end;

procedure TForm1.Refresh1Click(Sender: TObject);
begin
  refreshlist;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  rbinlist.width := form1.width - 8;
  rbinlist.height := form1.height - 48;
end;

procedure TForm1.file1Click(Sender: TObject);
begin
  if rbinlist.SelCount > 0 then
  begin
    restore1.enabled := true;
    Delete1.enabled := true;
  end
  else
  begin
    restore1.enabled := false;
    Delete1.enabled := false;
  end;
end;

procedure TForm1.SelectAll1Click(Sender: TObject);
var
  i: integer;
begin
  for i := 0 to rbinlist.Items.Count - 1 do
    rbinlist.Items[i].Selected := true;
end;

procedure TForm1.InvertSelection1Click(Sender: TObject);
var
  i: integer;
begin
  for i := 0 to rbinlist.Items.Count - 1 do
    rbinlist.Items[i].Selected := not (rbinlist.Items[i].Selected);
end;

procedure tform1.Restorefiles;
var
  i: integer;
  sname: string;
  dname: string;
begin
  monitorthread.Suspend;
  for i := 0 to rbinlist.Items.Count - 1 do
  begin
    if rbinlist.Items[i].Selected = true then
    begin
      sname := ExtractFileDrive(rbinlist.Items[i].SubItems[0]) + '\Recycled\DC' +
        rbinlist.Items[i].SubItems[1] + ExtractFileExt(rbinlist.Items[i].caption);
      dname := rbinlist.Items[i].SubItems[0] + rbinlist.Items[i].caption;
      MoveFile(pchar(sname), pchar(dname));
      updateinfo(dname);
    end;
  end;
  monitorthread.Resume;
end;

procedure TForm1.Restore1Click(Sender: TObject);
begin
  restorefiles;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if qh <> INVALID_HANDLE_VALUE then
    FindCloseChangeNotification(qh);
  monitorthread.Terminate;
end;

procedure TForm1.Close1Click(Sender: TObject);
begin
  form1.close;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  refreshlist;
end;

procedure TForm1.Delete1Click(Sender: TObject);
begin
  deletefiles;
end;

end.

Save your window size and position

Problem/Question/Abstract:

It's often useful to remember the size and state of your program's window (or sometimes of dialogue boxes) between executions. This article discusses how.

Answer:

The method we're going to use is to save the position in the registry.

First of all, decide where you're going to keep the information. It's customary for apps to place information that varies between users in

HKEY_CURRENT_USER\Software\MyCompany\MyProgram\X.X

(X.X is the version number of the program). We'll use such a key in this article.

You can save the window's current position and size when the program is closing down - the OnDestroy form event handler is a good place for this. The program then restores it's position from the registry (if it's been written yet) when opening - we use the form's OnCreate handler for that code.

There are complications when saving and restoring the window state because of when the window is minimised, Delphi doesn't minimise the form - it hides it and displays the Application window in the taskbar. The method I've used causes a previously minimised window to flash on-screen briefly. I'd welcome ideas on any alternative approaches. (This has now been fixed -- see the component available for download).

Another complication is that when a window is maximised Delphi updates the Width, Height, Left and Top properties of the form to the window's maximised size and position. This means that closing a maximised window stores the maximised size in the registry. When the program is run again it appears maximised, but when the user restores it they expect it to go to the previous normal size and position, but if we reloaded the Left, Top, Height and Width properties, the form won't shrink when restored. We get round this by using the Windows API to get the non-maximised size.

Here's the code - the comments should explain what's happening.

const
  CRegKey = 'Software\Demos\WdwStateDemo\1.0';

  // Helper function to read registry values, and deal with
  // cases where no values exist

function ReadIntFromReg(Reg: TRegistry; Name: string;
  Def: Integer): Integer;
{Reads integer with given name from registry and returns it
If no such value exists, returns Def default value}
begin
  if Reg.ValueExists(Name) then
    Result := Reg.ReadInteger(Name)
  else
    Result := Def;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
  Reg: TRegistry; // the registry
  State: Integer; // state of wdw
  Pl: TWindowPlacement; // used for API call
  R: TRect; // used for wdw pos
begin
  {Calculate window's normal size and position using
  Windows API call - the form's Width, Height, Top and
  Left properties will give maximized window size if
  form is maximised, which is not what we want here}
  Pl.Length := SizeOf(TWindowPlacement);
  GetWindowPlacement(Self.Handle, @Pl);
  R := Pl.rcNormalPosition;
  Reg := TRegistry.Create;
  try
    // Open required key - and create it if it doesn't exist
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKey(CRegKey, True);
    // Write window size and position
    Reg.WriteInteger('Width', R.Right - R.Left);
    Reg.WriteInteger('Height', R.Bottom - R.Top);
    Reg.WriteInteger('Left', R.Left);
    Reg.WriteInteger('Top', R.Top);
    // Write out state of window
    {Record window state (maximised, minimised or normal)
    - special case when minimized since form window is simply
    hidden when minimised, and application window is actually
    the one minimised - so we check to see if application
    window *is* minimized and act accordingly}
    if IsIconic(Application.Handle) then
      {minimized - write that state}
      State := Ord(wsMinimized)
    else
      {not mimimized - we can rely on window state of form}
      State := Ord(Self.WindowState);
    Reg.WriteInteger('State', State);
  finally
    Reg.Free;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  Reg: TRegistry; // the registry
  State: Integer; // state of wdw
begin
  Reg := TRegistry.Create;
  try
    // Open required key - and exit if it doesn't exist
    Reg.RootKey := HKEY_CURRENT_USER;
    if not Reg.OpenKey(CRegKey, False) then
      Exit;
    // Read the window size and position
    // - designed form sizes are defaults
    Self.Width := ReadIntFromReg(Reg, 'Width', Self.Width);
    Self.Height := ReadIntFromReg(Reg, 'Height', Self.Height);
    Self.Left := ReadIntFromReg(Reg, 'Left', Self.Left);
    Self.Top := ReadIntFromReg(Reg, 'Top', Self.Top);
    // Now get window state and restore
    State := ReadIntFromReg(Reg, 'State', Ord(wsNormal));
    {check if window was minimised - we have special
    processing for minimized state since Delphi doesn't
    minimize windows - it uses application window
    instead}
    if State = Ord(wsMinimized) then
    begin
      {we need to set visible true else form won't restore
      properly - but this causes a brief display of form
      any ideas on how to stop this?}
      Self.Visible := True;
      Application.Minimize;
    end
    else
      Self.WindowState := TWindowState(State);
  finally
    Reg.Free;
  end;
end;

A component that wraps up all this functionality on behalf of the form it lives on is available for download. There's also a sister component included that works with ini files rather than the registry.


Component Download: http://www.delphidabbler.com/download.php?file=pjwdwstate.zip

Creating an Insertable ActiveX control for Microsoft Office

Problem/Question/Abstract:

How to create an ActiveX control for Microsoft Office that is "Insertable"

Answer:

There is a nice feature in Microsoft Word that allows you to put ActiveX controls onto a Word document.  To do so you go to the Insert Menu, and click Object&#8230;.  This displays a dialog list a number of "Insertable" controls.

There is one problem with this dialog though; there is no browse button and no obvious method of adding your control to the list.  So how do you do it?

Turns out your ActiveX control is missing one registry entry, and the Type Library editor does not give you the option of inserting it.  The entry is &#8220;Insertable&#8221; (and you&#8217;ve been wondering why I have been using that word so much).  The key goes in the HKEY_CLASSES_ROOT section of the registry under a key that is your ActiveX control&#8217;s class id.

In the end, your registry should look something like this:

HKEY_CLASSES_ROOT->YourControl.TheClass->Insertable

Now, you can either go into RegEdit and enter this manually (a good way to make sure I&#8217;m not lying through my teeth), or you can add this entry automatically when the control is registered.  Ya, I thought so, option number 2 it is:

So, if you want this to be put in the registry automatically...

Go to the unit containing your automation object.
Make sure Registry and Windows are in your uses statement.
Modify your INITIALIZATION section to something like this with a new function:

procedure MoreKeys;
const
  C_KEY: string = 'YourControl.TheClass'; // your controls class ID
var
  oReg: TRegistry;
begin
  oReg := TRegistry.Create;

  try
    oReg.OpenKey(HKEY_CLASSES_ROOT);

    // the true mean create the key if it doesn&#8217;t exist
    oReg.OpenKey(C_Key + '\Insertable', True);
  finally
    oReg.CloseKey;
    oReg.Free;
  end;

end;

initialization
  TActiveFormFactory.Create(
    ComServer,
    TActiveFormControl,
    ...yada, yada, yada);
  MoreKeys;

end.

Towards a more accurate sort order in MSSQL7

Problem/Question/Abstract:

Sorting Addresses is a pain at the best of times, especially when a client supplies bad data (You may define clear fields in your DB, but when the data comes in, does it fit easily??)
This attempts to resolve this issue for MSSQL Server

Answer:

Wherever you keep the addresses, add a field SortOrder (real)
Whenever the Address changes, update the new value using this stored procedure to calculate the value.

Using the server to do the work will cut out network traffic, etc.

It can be called to update using something like this.

---
DECLARE @Addr varchar(100),@SortIndex real

SET @Addr=(SELECT ISNULL(Addr1+' ','')+ISNULL(Addr2+' ','')+ISNULL(Addr3+' ','')+ISNULL(Addr4+' ','')+ISNULL(Addr5+' ','')+ISNULL(PCode,'') FROM Main WHERE ID=@Main_ID)

EXEC spCalcSortIndex @Addr,@Index=@SortIndex OUTPUT

UPDATE Main
SET SortIndex=@SortIndex
WHERE ID=@Main_ID
---

Here is the Complete Stored Procedure to copy and paste in:

---
Create Procedure "spCalcSortIndex" @NumStr varchar(100)='',@Index real OUTPUT
AS

/*This will return a sort index based on the @NumStr passed
Call as: DECLARE @Value_I_Want real
EXEC spCalcSortIndex (SELECT AddressFields FROM Addresses WHERE ID=x),@Index=@Value_I_Want OUTPUT*/

DECLARE @strlen int,@i int,@j int
DECLARE @found bit
DECLARE @numpart real,@strpart real, @divisor real
DECLARE @ChoppedStr varchar(100)

SET @strlen=LEN(@NumStr)

IF @strlen=0
BEGIN
SET @Index=0
RETURN
END

/*Split the string into a 'number' and a 'string' part*/

/*Initialise*/
SELECT @found=0, @ChoppedStr=@NumStr,@numpart=0,@i=1

/*Locate the first digit*/
WHILE @i<=@strlen
BEGIN
IF SUBSTRING(@NumStr,@i,1) IN ('0','1','2','3','4','5','6','7','8','9')
BEGIN
SET @found=1
BREAK
END
SET @i=@i+1
END

IF @found=1
BEGIN
/*now get the remaining digits*/
SELECT @found=0,@j=@i

WHILE @j<=@strlen
BEGIN
IF SUBSTRING(@NumStr,@j,1) NOT IN ('0','1','2','3','4','5','6','7','8','9')
BEGIN
SET @found=1
BREAK
END
SET @j=@j+1
END

/*Separate out the string parts*/
IF @found=1
BEGIN
/*Number was embedded..*/
SELECT @numpart=CONVERT(real,SUBSTRING(@NumStr,@i,@j-@i)),
@ChoppedStr=LEFT(@Numstr,@i-1)+RIGHT(@NumStr,@strlen-@j+1)
END
ELSE
BEGIN
/*Number went to the end of the string*/
SELECT @numpart=CONVERT(real,SUBSTRING(@NumStr,@i,@strlen)),
@ChoppedStr=LEFT(@Numstr,@i-1)
END
END

SET @Choppedstr=UPPER(LTRIM(RTRIM(@ChoppedStr)))
SET @strlen=LEN(@ChoppedStr)

/*Evaluate a Number for the remaining part of the string*/
SELECT @strpart=0,@divisor=1,@i=1

WHILE @i<=@strlen
BEGIN
SET @divisor=@divisor/256
SET @strpart=@strpart+(ASCII(SUBSTRING(@ChoppedStr,@i,1))*@divisor)
SET @i=@i+1
END

/*All done, return the value*/
SET @Index=@numpart+@strpart
---

AlphaBlend your forms with a component

Problem/Question/Abstract:

Do you like the AlphaBlending of Windows 2000/XP menus, panels and other visual components? Use that and you'll implement in your applications.

Answer:

unit uAlphaWindow;

interface

uses
  Windows, Messages, Classes, Controls, Forms;

type
  TAlphaPercent = 0..100;
  TAlphaWindow =
    class(TComponent)
  protected
    User32: HModule;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetTransparentHWND(HWnd: THandle; Percent: TAlphaPercent);
    procedure SetTransparent(Percent: TAlphaPercent);
    procedure SetOpaqueHWND(HWnd: THandle);
    procedure SetOpaque;
  end;

procedure Register;

implementation

const
  LWA_ALPHA = $2;
  GWL_EXSTYLE = -20;
  WS_EX_LAYERED = $80000;
  WS_EX_TRANSPARENT = $20;

var
  SetLayeredWindowAttributes: function(HWnd: LongInt; crKey: Byte; bAlpha: Byte;
    dwFlags: LongInt): LongInt; StdCall;

constructor TAlphaWindow.Create(AOwner: TComponent);
begin
  inherited;
  User32 := LoadLibrary('USER32.DLL');
  if (User32 <> 0) then
    @SetLayeredWindowAttributes := GetProcAddress(User32, 'SetLayeredWindowAttributes')
  else
    SetLayeredWindowAttributes := nil;
end;

destructor TAlphaWindow.Destroy;
begin
  if (User32 <> 0) then
    FreeLibrary(User32);
  inherited;
end;

procedure TAlphaWindow.SetOpaqueHWND(HWnd: THandle);
var
  Old: THandle;
begin
  if (IsWindow(HWnd)) then
  begin
    Old := GetWindowLongA(HWnd, GWL_EXSTYLE);
    SetWindowLongA(HWnd, GWL_EXSTYLE, Old and ((not 0) - WS_EX_LAYERED));
  end;
end;

procedure TAlphaWindow.SetOpaque;
begin
  Self.SetOpaqueHWND((Self.Owner as TWinControl).Handle);
end;

procedure TAlphaWindow.SetTransparentHWND(HWnd: THandle; Percent: TAlphaPercent);
var
  Old: THandle;
begin
  if ((User32 <> 0) and (Assigned(SetLayeredWindowAttributes)) and (IsWindow(HWnd)))
    then
    if (Percent = 0) then
      SetOpaqueHWND(HWnd)
    else
    begin
      Percent := 100 - Percent;
      Old := GetWindowLongA(HWnd, GWL_EXSTYLE);
      SetWindowLongA(HWnd, GWL_EXSTYLE, Old or WS_EX_LAYERED);
      SetLayeredWindowAttributes(HWnd, 0, (255 * Percent) div 100, LWA_ALPHA);
    end;
end;

procedure TAlphaWindow.SetTransparent(Percent: TAlphaPercent);
begin
  Self.SetTransparentHWND((Self.Owner as TForm).Handle, Percent);
end;

procedure Register;
begin
  RegisterComponents('Christian', [TAlphaWindow]);
end;

end.


Example:

tAlphaWindow1.SetTransparent;

or use this:

tAlphaWindow1.SetTransparent(50);

Using the Affinity Mask in multi-CPU environments

Problem/Question/Abstract:

When writing applications that are designated to tun in multi-CPU environments, it is very useful to be able to control which CPU's the application executes on. By optimizing the CPU usage one can dramatically increase the performance of the application

Answer:

Introduction

When writing applications that are designated to tun in multi-CPU environments, it is very useful to be able to control which CPU's the application executes on.

By optimizing the CPU usage one can dramatically increase the performance of the application.

Affinity Masks - Background

When a process is created in windows, an affinity mask is passed to it. This is usually the system affinity mask, since the system is launching the process.

Also by default each thread created by this process is now assigned the current affinity mask for the process. This means that the thread is executed in any of the available CPU's.

If the "Process Affinity Mask" is changed, all threads created after that will only be allowed to execute in any of the available CPU's, also the whole process is limited to the same CPU's.

Getting the Affinity Mask

Windows provides us with an API call that help us get the affinity mask.

The API call is:

GetProcessAffinityMask(hProcess: Cardinal; var procAFMask, sysAFMask);

The hProcess parameter is the current process handle, and the procAFMask and sysAFMask variables are cardinals.

Before we change the affinity mask, we first need to get the current affinity mask for the whole system. This is because we do not want to try to set an affinity mask that is not possible.

When the API call returns it puts the BitMASK for the CPU's in each of the parameters.

The bits are encoded as followes:

BitMask
CPU's
00000001
1st CPU
00000010
2nd CPU
00000100
3rd CPU
00001000
4th CPU
00010000
5th CPU
00100000
6th CPU
01000000
7th CPU
10000000
8th CPU


By combining these BIT values one can determine the CPU count/mask. The BitMask is 32 bits in size, so theoretically the BitMask supports up to 32 CPU's.

Example:  BitMask=00000011 would mean 2 CPU's, number 1 and 2.

Changing the Affinity Mask of a Process

Windows provides us with an API call that help us set the affinity mask.

The API call is:

SetProcessAffinityMask(hprocess: Cardinal; ProcessAffinityMask: Cardinal);

The hProcess parameter is the current process handle, and the ProcessAffinityMask variable is a cardinal.

To obtain the current process handle we need another API call named "GetCurrentProcess()".  This API call returns the handle of the current process.

The ProcessAffinityMask variable contains the BitMASK of the CPU's we want this process to execute on. (see the BitMask table above).

Example:

var
  ProcAFMask,
    SysAFMask: Cardinal;
begin
  { Get the current values }
  GetProcessAffinityMask(GetCurrentProcess, ProcAFMask, SysAFMask);
  { Manipulate }
  SysAFMAsk := $00000001; // Set this process to run on CPU 1 only
  { Set the Process Affinity Mask }
  SetProcessAffinityMask(GetCurrentProcess, SysAFMAsk);
end;

A realworld example

Now that I have shown how to get and set the affinity masks for processes, I'd like to show a real-world example of how to utilize this.

I had a situation where our customer had a 4 CPU server, and used it for some heavy processing about 80% of the time.

The customer wanted us to create an application for them, but they didn't want to invest in the hardware, since they already had a good server running. They where unsure of the total load on the server so we investigated, and found that the server only used the 2 first CPU's when under heavy load. This meant that there were 2 CPU's available for us !

So we implemented the Affinity Mask API calls, and concluded that our application was executing nicely on CPU's number 3 and 4 only, leaving the 2 other CPU's free for the other application on the server.

Our application used alot of Threads, but since the master affinity for the whole process was changed, the threads followed the set parameters without problems.

What about the affinity masks for the Threads?

If you want to read more about the affinity masks for Threads there is an excellent article:

Extending TThread for multiple processor environments

Send compless strings (all 256 ASCII) to an ASP page

Problem/Question/Abstract:

Ever needed to send compless strings, that contains ASCII values that will be truncated from the HTTP protocol, to an ASP page?

I did, but I found a solution and there it's..

Answer:

Just convert the complete string to a hexadecimal value with this function...

function CharsToPrintable(What: string): string;
var
  IdX: Integer;
  tmpStr, outStr: string;
begin
  Result := '';
  outStr := '';
  tmpStr := What;
  for IdX := 1 to Length(tmpStr) do
    outStr := outStr + IntToHex(StrToInt(tmpStr[IdX]), 2);
  Result := outStr;
end;

..and then reconvert it to the original string, taking 2 chars at time and calculating the original ASCII value (byte) with this ASP code (works correctly in Visual Basic, but I have not yet tested with ASP (will try soon)):

Private Function GetFromHexValue(Da As String) As String

    Dim Ai As Integer
    Dim Bi As Integer
    
    If IsNumeric(Left(Da, 1)) Then
        Ai = CInt(Left(Da, 1))
    Else
        Ai = Asc(UCase(Left(Da, 1))) - 65
    End If
    If IsNumeric(Right(Da, 1)) Then
        Bi = CInt(Right(Da, 1))
    Else
        Bi = Asc(UCase(Right(Da, 1))) - 55
    End If
    GetFromHexValue = Chr(Ai * 16 + Bi)

End Function

...and...

Dim X As Integer
Dim A As String
Dim Inputed As String

Inputed = ""
For X = 1 To Len(Request.QueryString("MyString")) Step 2
    If X > Len(Request.QueryString("MyString")) Then Exit For
    A = Mid(Request.QueryString("MyString"), X, 2)
    Inputed = Inputed + GetFromHexValue(A)
Next X

Response.Write Inputed

Add style to your application implementing an easter egg

Problem/Question/Abstract:

Many world class applications implement some easter egg to give its author(s) credit, so why not to use this feature in your own applications?

Answer:

An easter egg is some piece of code that executes only when the user uses some special keystrokes, they are used frequently to give credit to the author(s) of some program.

For example in Delphi�s About box hold Shift + Alt and then type "team", you will expose an easter egg giving credit to Delphi Staff.

To create your own easter egg take this steps:

1.- Start a new Project

2.- Create the following private fields:

private
FEgg: string;
FCount: Integer;

FCount holds a count of Keystrokes.
FEgg holds the Keystrokes string.

3.- Create two constants

const
  EE_CONTROL: TShiftState = [ssCtrl, ssAlt];
  EASTER_EGG = 'SECRET';

EE_CONTROL contains the control keys that must be down when the user types the EASTER_EGG string

4.- In the OnCreate event of the form write

procedure TForm1.FormCreate(Sender: TObject);
begin
  FCount := 1;
  FEgg := EASTER_EGG;
end;

5.- In the OnKeyDown event of the form write

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  //Are the correct control keys down?
  if Shift = EE_CONTROL then
  begin
    //was the proper key pressed?
    if Key = Ord(FEgg[FCount]) then
    begin
      //was this the last keystroke in the sequence?
      if FCount = Length(FEgg) then
      begin
        //Code of the easter egg
        ShowMessage('Add your own code here!');
        //failure - reset the count
        FCount := 1; {}
      end
      else
      begin
        //success - increment the count
        Inc(FCount);
      end;
    end
    else
    begin
      //failure - reset the count
      FCount := 1;
    end;
  end;
end;

6.- Finally set the Form�s KeyPreview property to true.

Now you just have to replace the ShowMessage with Something more creative, use your imagination!

Get the number of files in recycle bin and the size of recycle bin

Problem/Question/Abstract:

How to get the number of files in recycle bin and the size of recycle bin

Answer:

To get the number files in the recycle bin, you have to use the function SHQueryRecycleBin. this function is available in the shell32 module. This function is supported in Win98 or above.

The function declarartion is as shown below

function SHQueryRecycleBin(pszrtootpath: pchar; QUERYRBINFO: pshqueryrbinfo): integer;
  stdcall;
  external 'shell32' name 'SHQueryRecycleBinA';

The SHQUERYBINFO Structure is as follows

type
  SHQUERYRBINFO = packed record
    cbSize: integer; // size of structure
    i64Size: int64; // size of recycle bin
    i64NumItems: int64; // number of items in recycle bin.
  end;

The cbsize must be set before calling the function

The first parameter must be the drive of which the recyclebin must be queried.
If the drive 'C' then the parameter must be'C:\'; if the parameter is empty then the function queries the recyclebin on all the harddisks as a whole.

the second parameter is a pointer to SHQUERYBINFO Structure.

The function returns 0 if successful.

The function can be called as follows

var
  rbinfo: SHQUERYRBINFO;
begin
  SHQueryRecycleBin('C:\', @rbinfo);
end;

Try loading DLL in dynamic mode

Problem/Question/Abstract:

Static DLL loading is hard to handle? Try loading in dynamic mode.

Answer:

If you'll use DLL in a Delphi Program, you can load it in two types:

static loading
dynamic loading

Let me see:

CREATING A SIMPLE DLL LIBRARY

My example library only calculates the bouble of a number: Project file name: c:\example\exdouble\exdouble.dpr

library ExDouble;
// my simple dll

function calc_double(r: real): real; stdcall;
begin
  result := r * 2;
end;

exports
  calc_double index 1;

end;

My simple library is functional. Now we will load it...

STATIC DLL LOADING

In this loading type, its more simple, but you will need put the DLL file in your directory or Windows directory, or Windows\System, Windows\Command. But if it not is on this directory, Windows will display an error message box (DLL not found, more or less this) and you cannot handle this (IN THIS TYPE[LOADING MODE]).

unit untMain;

interface

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

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

var
  Form1: TForm1;

implementation

function calc_double(r: real): real; stdcall; external 'ExDouble.dll';

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  // the message box will shows 21 (oohhhhhh!)
  showMessage(floatToStr(calc_double(10.5)));
end;

end.

DYNAMIC DLL LOADING

In dynamic loading, you will need to type more code, but it's easy to handle the process. Before loading your application, you can do a "find process" to find your functions library.

You can see the code below.

unit untMain;

interface

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

type
  Tcalc_double = function(r: real): real;

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

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  hndDLLHandle: THandle;
  calc_double: Tcalc_double;
begin
  try
    // load dll in dinamic type(mode)
    hndDLLHandle := loadLibrary('ExDouble.dll');

    if hndDLLHandle <> 0 then
    begin

      // get function address
      @calc_double := getProcAddress(hndDLLHandle, 'calc_double');

      // if function address exists
      if addr(calc_double) <> nil then
      begin
        // shows result (it's really 21...)
        showMessage(floatToStr(calc_double(10.5)));
      end
      else
        // DLL not found ("handleable")
        showMessage('Function not exists...');

    end
    else
      // DLL not found ("handleable")
      showMessage('DLL not found...');

  finally
    // free the DLL handle
    freeLibrary(hndDLLHandle);
  end;
end;

end.

Check for exe files and DLLs

Problem/Question/Abstract:

This article looks at how we examine a file to check if it is a DOS or Windows executable and, if so, whether it is a program file or a DLL.

Answer:

Abstract

In article "Getting an exe file type", Lutfi Baran showed us how to find out if a file is a 16 or 32 bit Windows or a DOS executable. But what if we need to know if the file is an application or a DLL?

This articles adds to Lutfi's work by adding the ability to check for DLLs. Since this code was developed independently of the earlier article, any errors are mine!

Thanks to to Flurin Honegger (see comment below) for suggesting some of the "reasonableness" checks on the DOS header to verify a valid MS-DOS file that are included in this revised article.

This is an abbreviated version of the original article, published on my website.

Outline Design

Before we start coding, let's look at how we're going to accomplish this task. Our approach will be to scan through the file, looking for markers to indicate its file type. We use the following information:

All DOS program files (and therefore Windows executables) begin with a header record whose first element is a "magic number"; the word value $5A4D ("MZ" in ASCII).

The DOS header defines the expected length of the file and the offset of a "relocation table". We can check the length of the file being checked is greater than or equal to the expected length and that the offset of the DOS relocation table lies within the file.

Windows executables have a header record whose offset in the file is given by the LongWord at offset $3C.

The Windows header begins with the "magic number" $454E (NE file format - 16bit) or $4550 (PE file format - 32bit).

PE executables have an "image header" immediately following the $4550 magic number. This header structure has a Characteristics field which is a bit mask If the bit mask contains the flag IMAGE_FILE_DLL then the file is a DLL.

NE executables have a byte sized field at offset $0D from the start of the header which is a bit mask that contains the flag $80 when the file is a DLL.


Coding the Function

Our function will return a value that indicates the type of file whose name is passed to it as a parameter. The type of the return value is defined as:

type
  TExeFileKind = (
    fkUnknown, // unknown file kind: not an executable
    fkError, // error file kind: used for files that don't exist
    fkDOS, // DOS executable
    fkExe32, // 32 bit executable
    fkExe16, // 16 bit executable
    fkDLL32, // 32 bit DLL
    fkDLL16 // 16 bit DLL
    );

The implementation of the function requires structures for the PE and DOS file headers. The PE file header (type IMAGE_FILE_HEADER) is defined in the Windows unit. The DOS file header is not defined there, so we need to defined it as follows (copied from the Delphi Resxplor demo program):

type
  IMAGE_DOS_HEADER = packed record // DOS .exe header
    e_magic: Word; // Magic number ("MZ")
    e_cblp: Word; // Bytes on last page of file
    e_cp: Word; // Pages in file
    e_crlc: Word; // Relocations
    e_cparhdr: Word; // Size of header in paragraphs
    e_minalloc: Word; // Minimum extra paragraphs needed
    e_maxalloc: Word; // Maximum extra paragraphs needed
    e_ss: Word; // Initial (relative) SS value
    e_sp: Word; // Initial SP value
    e_csum: Word; // Checksum
    e_ip: Word; // Initial IP value
    e_cs: Word; // Initial (relative) CS value
    e_lfarlc: Word; // Address of relocation table
    e_ovno: Word; // Overlay number
    e_res: packed array[0..3] of Word; // Reserved words
    e_oemid: Word; // OEM identifier (for e_oeminfo)
    e_oeminfo: Word; // OEM info; e_oemid specific
    e_res2: packed array[0..9] of Word; // Reserved words
    e_lfanew: Longint; // File address of new exe header
  end;

We are now ready to code the function:

function ExeType(const FileName: string): TExeFileKind;
{Examines given file and returns a code that indicates the type of executable
file it is (or if it isn't an executable)}
const
  cDOSRelocOffset = $18; // offset of "pointer" to DOS relocation table
  cWinHeaderOffset = $3C; // offset of "pointer" to windows header in file
  cNEAppTypeOffset = $0D; // offset in NE windows header of app type field
  cDOSMagic = $5A4D; // magic number identifying a DOS executable
  cNEMagic = $454E; // magic number identifying a NE executable (Win 16)
  cPEMagic = $4550; // magic nunber identifying a PE executable (Win 32)
  cNEDLLFlag = $80 // flag in NE app type field indicating a DLL
var
  FS: TFileStream; // stream to executable file
  WinMagic: Word; // word that contains PE or NE magic numbers
  HdrOffset: LongInt; // offset of windows header in exec file
  ImgHdrPE: IMAGE_FILE_HEADER; // PE file header record
  DOSHeader: IMAGE_DOS_HEADER; // DOS header
  AppFlagsNE: Byte; // byte defining DLLs in NE format
  DOSFileSize: Integer; // size of DOS file
begin
  try
    // Open stream onto file: raises exception if can't be read
    FS := TFileStream.Create(FileName, fmOpenRead + fmShareDenyNone);
    try
      // Assume unkown file
      Result := fkUnknown;
      // Any exec file is at least size of DOS header long
      if FS.Size < SizeOf(DOSHeader) then
        Exit;
      FS.ReadBuffer(DOSHeader, SizeOf(DOSHeader));
      // DOS files begin with "MZ"
      if DOSHeader.e_magic <> cDOSMagic then
        Exit;
      // DOS files have length >= size indicated at offset $02 and $04
      // (offset $02 indicates length of file mod 512 and offset $04 indicates
      // no. of 512 pages in file)
      if (DOSHeader.e_cblp = 0) then
        DOSFileSize := DOSHeader.e_cp * 512
      else
        DOSFileSize := (DOSHeader.e_cp - 1) * 512 + DOSHeader.e_cblp;
      DOSFileSize := (DOSHeader.e_cp - 1) * 512 + DOSHeader.e_cblp;
      if FS.Size < DOSFileSize then
        Exit;
      // DOS file relocation offset must be within DOS file size.
      if DOSHeader.e_lfarlc > DOSFileSize then
        Exit;
      // We assume we have an executable file: assume its a DOS program
      Result := fkDOS;
      // Try to find offset of Windows program header
      if FS.Size <= cWinHeaderOffset + SizeOf(LongInt) then
        // file too small for windows header "pointer": it's a DOS file
        Exit;
      // read it
      FS.Position := cWinHeaderOffset;
      FS.ReadBuffer(HdrOffset, SizeOf(LongInt));
      // Now try to read first word of Windows program header
      if FS.Size <= HdrOffset + SizeOf(Word) then
        // file too small to contain header: it's a DOS file
        Exit;
      FS.Position := HdrOffset;
      // This word should identify either a NE or PE format file: check which
      FS.ReadBuffer(WinMagic, SizeOf(Word));
      case WinMagic of
        cPEMagic:
          begin
            // 32 bit Windows application: now check whether app or DLL
            if FS.Size < HdrOffset + SizeOf(LongWord) + SizeOf(ImgHdrPE) then
              // file not large enough for image header: assume DOS
              Exit;
            // read Windows image header
            FS.Position := HdrOffset + SizeOf(LongWord);
            FS.ReadBuffer(ImgHdrPE, SizeOf(ImgHdrPE));
            if (ImgHdrPE.Characteristics and IMAGE_FILE_DLL) = IMAGE_FILE_DLL then
              // characteristics indicate a 32 bit DLL
              Result := fkDLL32
            else
              // characteristics indicate a 32 bit application
              Result := fkExe32;
          end;
        cNEMagic:
          begin
            // We have 16 bit Windows executable: check whether app or DLL
            if FS.Size <= HdrOffset + cNEAppTypeOffset + SizeOf(AppFlagsNE) then
              // app flags field would be beyond EOF: assume DOS
              Exit;
            // read app flags byte
            FS.Position := HdrOffset + cNEAppTypeOffset;
            FS.ReadBuffer(AppFlagsNE, SizeOf(AppFlagsNE));
            if (AppFlagsNE and cNEDLLFlag) = cNEDLLFlag then
              // app flags indicate DLL
              Result := fkDLL16
            else
              // app flags indicate program
              Result := fkExe16;
          end;
      else
        // DOS application
        {Do nothing - DOS result already set};
      end;
    finally
      FS.Free;
    end;
  except
    // Exception raised in function => error result
    Result := fkError;
  end;
end;

Conclusion

So there we have it -- a function to return the file type of an executable file. If you have any suggestions then please contact me.

Worked Example

A worked example is available for download from my website. This example includes the ExeType function, along with a Delphi 4 project that exercises it.

When use Interfaces, when use Inheritance ?

Problem/Question/Abstract:

There are two possibilities to define a (same) class hierarchy:
with interfaces
with inheritance
Which one suits your needs

Answer:

You can fulfill the same operations with interfaces or inheritance as the following shows:  

IShape = interface
  procedure paint;
end;

TSquare = class(TInterfacedObject, IShape)
  procedure paint;
end;

TCircle = class(TInterfacedObject, IShape)
  procedure paint;
end;

TShape = class
  procedure paint; virtual; abstract;
  //procedure makeShape(afigure: TShape);
end;

TSquare2 = class(TShape)
  procedure paint; override;
end;

TCircle2 = class(TShape)
  procedure paint; override;
end;

Interfaces are useful when a set of operations, such as rendering or streaming, are used in a broad range of objects. They can reuse code and apply methods to a variety of different applications.
Almost the same could have been accomplished by having TSquare2 and TCircle2 descend from TShape which implemented the virtual method Paint.
So whats the difference from a point of design?

With inheritance you can implement a base behaviour in the base-class like makeShape(), interfaces are pure abstract and dont't allow a real method.
You have garbage collection with interfaces and you can handle objects without having to require the object to descend from a particular base class.

Even if two classes did not share a commen ancestor, they are assignment compatible with a variabel of IShape:

procedure TfrmGen.Button2Click(Sender: TObject);
var
  painter: IShape;
  painter2: TShape;
begin
  // interface
  painter := TSquare.create;
  painter.paint;
  painter := TCircle.create;
  painter.paint;
  // inheritance virtual
  painter2 := TSquare2.create;
  //painter2.paint;
  painter2.makeShape(painter2);
  painter2 := TCircle2.create;
  painter2.makeShape(painter2);
  // virtual alternative
  with painter2.Create do
  begin
    makeShape(TSquare2.create);
    makeShape(TCircle2.create);
  end;

end;

A well designed inheritance can be more stable and maintainable in comparison to much runtime objects that implement the same interface. So inheritance has more advantage in a well established design-time hierarchy, interfaces are best in run-time between components.
For example we improve a method in a base class, inheritance makes it possible. On the other hand interfaces are more flexible to replace or delegate objects at runtime.
For this it's a must do generate a GUID (Globally Unique Identifier) in square brackets. GUID's arent strictly necessary, but if you want to switch between interfaces you'll need them to make QueryInterface work!

Now let's compare the advantages between the two

Inheritance
Interface
big hierarchy
delegation
base behavior
more implemantations of one interface
libraries
run time packages
real time freeing
garbage collection (reference counter)
subclassing
run time flexibility
design time properties
design by contract
fields
properties


The most part is the realisation that you cannot mix object references and interface references. Interfaces are reference counted and objects not, so mixing the two approaches gets an access violation.
See you at EKON7 in Frankfurt or in my new book "Patterns konkret" ;)

// example implementation
{ TShape }

procedure TShape.makeShape(afigure: TShape);
begin
  if afigure <> nil then
    afigure.paint;
end;

{ TSquare2 }

procedure TSquare2.paint;
begin
  frmgen.memo1.lines.add('square virtual painted');
end;

{ TCircle2 }

procedure TCircle2.paint;
begin
  frmgen.memo1.lines.add('circle virtual painted');
end;

end.

Making an application a TCP/IP Client (with sample code)...

Problem/Question/Abstract:

Connecting to a TCP/IP server from a Delphi Client

Answer:

This article is a continuation of my previous article "Making an application a TCP/IP Client" intended to demonstrate how we can use the TclientSocket component in Delphi as a TCP/IP client against any TCP/IP server. The server could be written in Delphi using TserverSocket component or any piece of code that acts as a TCP/IP server. In my case, I&#8217;m interacting with a Java code acts as a TCP/IP server.

In my project, I&#8217;m just sending a bunch of bytes to that Java server and the Java server reads the bytes and doing some tasks sending a different bunch of bytes as response to the Delphi Client.

In my last article (Making an application a TCP/IP Client), I explained the problem I faced and a solution I found for that.

In this article, let me give some sample code I used in that project since some people asked me to send the source code for this socket communication by sending separate e-mails. I appreciate them for their interest. Here U Go!! Enjoy!!!

My project uses nearly nine forms and all the forms need to interact with the Java server at least once. So I added a DataModule and put a TClientSocket Component there:

The following is the code for that:

unit DataMod;

interface

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

type
  TdmDataModule = class(TDataModule)
    csClientSocket: TClientSocket;
    procedure csClientSocketError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure csClientSocketRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure DataModuleDestroy(Sender: TObject);
  private
    { Private declarations }
    pub
      lic
      FWaiting: boolean;
    { Public declarations }
  end;

var
  dmDataModule: TdmDataModule;

implementation

{$R *.DFM}

procedure TdmDataModule.csClientSocketRead(Sender: TObject;
  Socket: TCustomWinSocket);
//Reading data back from server thro socket
var
  Buffer: array[0..4095] of char;
  BytesReceived: integer;
  MemoryStream: TMemoryStream;
begin
  while FWaiting do
  begin
    MemoryStream := TMemoryStream.Create;
    try
      //This time delay depends on the network traffic and also you can put the
                        //time delay between reads
      //I've just put some 200 milliseconds for my application before it
                        //starts reading from the server.
      Sleep(200);
      while True do
      begin
        BytesReceived := Socket.ReceiveBuf(Buffer, SizeOf(Buffer));
        if (BytesReceived <= 0) then
          Break
        else
        begin
          MemoryStream.Write(Buffer, BytesReceived);
        end;
      end;

      FWaiting := False;

      MemoryStream.Position := 0;

      //XMLResponse is a global stringlist i'm using in my application to convert
                        //the bytes received into string
      //You can use other ways to get the contents of a memorystream
      XMLResponse.LoadFromStream(MemoryStream);
    finally
      MemoryStream.Free;
    end;
  end;
end;

procedure TdmDataModule.csClientSocketError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
{Whenever you get a specific type of error while running the client you will be given a messagedlg showing that the error has occured; at that time you have to check whether the server is running correctly or not and if needed make the server run properly and then say OK.
Then csClientSocket.Open will try to reconnect to the server. So at this time if some transaction is in the middle you have to send the same stuff again after reconnecting.}
begin
  case ErrorEvent of
    eeGeneral:
      begin
        if MessageDlg('Error Connecting to Java server! ' + #13 +
          'Check the server status and try again!!', mtInformation, [mbOk], 0) = mrOk
          then
          csClientSocket.Open
      end;
    eeConnect:
      begin
        if MessageDlg('Error Connecting to Java server? ' + #13 +
          'Check the server status and try again!!', mtInformation, [mbOk], 0) = mrOk
          then
          csClientSocket.Open
      end;
    eeSend:
      begin
        if MessageDlg('Error Connecting to Java server? ' + #13 +
          'Check the server status and try again!!', mtInformation, [mbOk], 0) = mrOk
          then
          csClientSocket.Open
      end;
    eeReceive:
      begin
        if MessageDlg('Error Connecting to Java server? ' + #13 +
          'Check the server status and try again!!', mtInformation, [mbOk], 0) = mrOk
          then
          csClientSocket.Open
      end;
    eeAccept:
      begin
        if MessageDlg('Error Connecting to Java server? ' + #13 +
          'Check the server status and try again!!', mtInformation, [mbOk], 0) = mrOk
          then
          csClientSocket.Open
      end;
  end;
end;

procedure TdmDataModule.DataModuleDestroy(Sender: TObject);
begin
  //Closing the socket connection
  csClientSocket.Close;
end;

end.

Once you are done with the datamodule, you can include this datamodule in units wherever you need to interact with the server thereby you can avoid writing code to read data back from the server in various places of the project.

You can set the Host/Address and Port Number of the server to communicate at runtime through the runtime parameters.(I assume Delphi people aware of that runtime parameters)

Then in the project's main form's formcreate event; write the following code to connect to the server. i.e setting the IP address and Port Number of the server in the TClientSocket component and set Active to true.

//Connecting to the Java server on a particular port
try
  with dmDataModule.csClientSocket do
  begin
    if Active then
      Active := False;

    //Getting the Address or Host Name of the server through the runtime parameters
    Host := ParamStr(1);
    //Getting the Port Number of the server at which the server listens through the runtime parameters
    Port := StrToInt(ParamStr(2));
    //Making the connection active
    Active := True;
  end;
except on ESocketError do
  begin
    MessageDlg('Unable to Connect to Java Server ' + #13 + 'Please Try Again!',
      mtInformation, [mbOk], 0);
    exit;
  end;
end;

Once you are connected to the server, you can use either the TClientSocket's sendtext or sendstream method to send the data to the server.

for example:

procedure Send;
begin
  //Checking whether the socket connection is ready or not
//If not , the error handling part of the TClientSocket will be activated
  if csClientSocket.Active then
  begin
    //Sending the text through the socket connection
    csClientSocket.Socket.SendText('The string to send');

    //Setting a flag to wait until the server sends the response back
    dmDataModule.FWaiting := True;
    while dmDataModule.FWaiting then
      Application.ProcessMessages;
  end;
end;

Notifying applications that the registry has changed

Problem/Question/Abstract:

When I make a change to the registry, some applications do not seem to acknowledge the changes until they are restarted. How can I get the applications to respond to the changes?

Answer:

Broadcast a WM_WININICHANGE message to the system, sending a null terminated string detailing the registry section that changed. Most well written applications should respond to the WM_WININICHANGE message.

Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendMessage(HWND_BROADCAST,
    WM_WININICHANGE,
    0,
    LongInt(PChar('RegistrySection')));
end;

Implement drag scrolling in a TTreeView

Problem/Question/Abstract:

Can someone tell me where I can look to get some help implementing scrolling while a drag operation is in effect.

Answer:

procedure TfrmajNewsEditor.ajNewsTreeViewDragOver(Sender, Source: TObject;
  X, Y: Integer; State: TDragState; var Accept: boolean);
const
  cScrollOffset = 5;
var
  Node: TTreeNode;
begin
  Accept := true; {Always accept}
  Node := fajNewsTreeView.TopItem; {Get the top node as a reference}
  if (y < cScrollOffset) then {Are we dragging at the top of the treeview?}
    SendMessage(fajNewsTreeView.Handle, WM_VSCROLL, SB_LINEUP, 0)
      {We'll scroll the treeview}
  else if (y > fajNewsTreeView.Height - cScrollOffset) then {Dragging at the bottom?}
    SendMessage(fajNewsTreeView.Handle, WM_VSCROLL, SB_LINEDOWN, 0); {Do a scroll}
  if (Node <> fajNewsTreeView.TopItem) then {Did we scroll? We'll need to redraw.}
    fajNewsTreeView.Refresh; {The treeview gets in a mess if we don't.}
end;

What does WM_USER+0xB901 mean?

Problem/Question/Abstract:

What does WM_USER+0xB901 mean?

Answer:

WM_USER+0xB901 is a user defined Message parameter. Windows passes messages about as part of its operation. For example: OnMousemove, OnMousedown, OnExit, OnClose, OnActivate, etc.. These are all messages. The above messages are called a name (like OnMouseMove, etc) but they actually have a message NUMBER associated with them.

Assume you want to define your own message that you want to pass around the system, (such as pass to another window). You should NOT use an existing message number (such as the number equivalent to OnMouseDown) or it will cause undersirable effects. So you need to use messsage numbers beyond what is 'used' by windows. Windows effectively tells us what numbers are 'safe' to use by the WM_USER (Windows Message User) constant. All numbers from WM_USER are available for the user to define for there own message signalling. So messages like WM_USER+1, WM_USER+2, WM_USER+20, WM_USER+100, etc. can be used.

The 0xB901 just represents a Hexadecimal number (0x -> Hex) B901 == 47,361 in decimal.

Plot a huge number of points per second on a TBitmap without flicker

Problem/Question/Abstract:

I need to visualize 50K points of SmallInt each second, so what are my options to accomplish that?

Answer:

This project was able to handle the 50K points you specified. An 800x600 bitmap was populated with these points 10 times a second without flicker. The points are chosen at random.

unit Unit1;

interface

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

const
  MAX_POINTS = 50000;

type
  PRGBTriad = ^TRGBTriad;
  TRGBTriad = record
    B, G, R: byte;
  end;

  TForm1 = class(TForm)
    Image1: TImage;
    Timer1: TTimer;
    procedure Timer1Timer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FPoints: array of TPoint;
    procedure DrawBatch(ycoord: integer; var points: array of TPoint);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure Sorty(var A: array of TPoint);

  procedure QuickSort(var A: array of TPoint; iLo, iHi: Integer);
  var
    Lo, Hi, Mid: Integer;
    T: TPoint;
  begin
    Lo := iLo;
    Hi := iHi;
    Mid := A[(Lo + Hi) div 2].y;
    repeat
      while A[Lo].y < Mid do
        Inc(Lo);
      while A[Hi].y > Mid do
        Dec(Hi);
      if Lo <= Hi then
      begin
        T := A[Lo];
        A[Lo] := A[Hi];
        A[Hi] := T;
        Inc(Lo);
        Dec(Hi);
      end;
    until
      Lo > Hi;
    if Hi > iLo then
      QuickSort(A, iLo, Hi);
    if Lo < iHi then
      QuickSort(A, Lo, iHi);
  end;

begin
  QuickSort(A, Low(A), High(A));
end;

procedure Sortx(var A: array of TPoint);

  procedure QuickSort(var A: array of TPoint; iLo, iHi: Integer);
  var
    Lo, Hi, Mid: Integer;
    T: TPoint;
  begin
    Lo := iLo;
    Hi := iHi;
    Mid := A[(Lo + Hi) div 2].x;
    repeat
      while A[Lo].x < Mid do
        Inc(Lo);
      while A[Hi].x > Mid do
        Dec(Hi);
      if Lo <= Hi then
      begin
        T := A[Lo];
        A[Lo] := A[Hi];
        A[Hi] := T;
        Inc(Lo);
        Dec(Hi);
      end;
    until
      Lo > Hi;
    if Hi > iLo then
      QuickSort(A, iLo, Hi);
    if Lo < iHi then
      QuickSort(A, Lo, iHi);
  end;

begin
  QuickSort(A, Low(A), High(A));
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  i: integer;
  lastY: integer;
  batch: array of TPoint;
  batchLength: integer;
begin
  for i := Low(FPoints) to High(FPoints) do
  begin
    FPoints[i].x := Random(800);
    FPoints[i].y := Random(600);
  end;
  Sorty(FPoints); {Quicksort by y}
  lastY := -1;
  i := Low(FPoints);
  batchLength := 0;
  Image1.Picture.Bitmap.Canvas.TryLock;
  while i <= High(FPoints) do
  begin
    if lastY = FPoints[i].y then
    begin
      Inc(batchLength);
      SetLength(batch, batchLength);
      batch[batchLength] := FPoints[i];
    end
    else
    begin
      DrawBatch(lastY, batch);
      batchLength := 0;
      lastY := FPoints[i].y;
      Inc(batchLength);
      SetLength(batch, batchLength);
      batch[batchLength - 1] := FPoints[i];
    end;
    Inc(i);
  end;
  Image1.Picture.Bitmap.Canvas.Unlock;
  Image1.Invalidate;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  SetLength(FPoints, MAX_POINTS);
  Randomize;
  Image1.Picture.Bitmap.PixelFormat := pf24bit;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FPoints := nil;
end;

procedure TForm1.DrawBatch(ycoord: integer; var points: array of TPoint);
var
  yScanLine: PRGBTriad;
  pixelpos: PRGBTriad;
  i: integer;
begin
  if Length(points) = 0 then
    exit;
  Sortx(points);
  yScanLine := Image1.Picture.Bitmap.ScanLine[ycoord];
  FillChar(yScanLine^, 3 * 800, 255);
  for i := Low(points) to High(points) do
  begin
    pixelpos := yScanLine;
    Inc(pixelPos, points[i].x);
    PixelPos^.R := 255;
    PixelPos^.G := 0;
    PixelPos^.B := 0;
  end;
end;

end.

Introduction to SSL

Problem/Question/Abstract:

Adding security to internet connections becomes more important each days. How would one strenghten his n-tier or Internet-related communications?

Answer:

The problem

Everybody uses network to transfer data, this is obvious. Less obvious is the fact, that the data has value (and cost), and so it is a subject to theft.

Types of information that are stolen include personal user's information, commercial or technical data (including commercial secrets and intellectual property), or even security and military information. Leaking of such information can stay undiscovered for months, if not year, doing damage to people that sent information and also to third parties.

Information theft is possible in two places:

On the remote side itself

In the middle of network conversation, i.e. on the way from the user's computer to remote side.

If the remote side is supposed to be a secure place (i.e. e-commerce merchant which has good reputation), theft on the remote side is still possible. How is this possible? Suppose you are calling somebody using the phone and the person on other side answers you. If the voice of the respondent sounds similar to the one you expect, it is possible that you will not perform other authentication and can possibly tell him some secrets. Sounds strange? However this is quote a common situation in the real life.

Situation regarding network servers is not better. When the user expects to see often-used web page, it is relatively easy to create a similarly looking page on the other ("fraudulent") server and attempt to direct the user to that server. Chances are that the user will share his login/password information or even credit card info with the unknown thief. So, the first problem with network security is remote side identification.

Even when the remote side can be identified for sure, we are still not in safety. As we know, information doesn't reach the remote side directly. Instead it travels through 5-20 (in average) network nodes to get to the server. Each of these nodes is technically capable to capture, record or even modify the information being sent. Of course, this is a serious threat to data security. The second problem is tolerance to so-called man-in-the-middle attacks.

There are many types of man-in-the-middle attacks; they differ in the goal of their initiator and in the way they are carried.

So two main tasks of any network security solution is to

Provide correct identification of the remote side in network conversation

Prevent third parties that have possibility to access the network, over which the data is transmitted, from accessing the data being sent.

The most obvious way is to encrypt the data in the way that is known to both sides of network communication session, but is not known to other parties. Strong encryption algorithm would work fine&#8230; but only if both sides know the password (some data sequence), which is used during encryption. Such approach can be used in some cases, but certainly it is not usable in Internet, where thousands of client devices connect to servers for information and services. Of course, the server could transfer the password to the client during conversation, but the obvious drawback is that the third party in the middle can get the password too, effectively making such "security" useless.

So it is necessary to utilize some more advanced scheme, which lets the client and the server securely exchange the passwords and still minimize the chance for attack.

Protocols

Nowadays there are several widely used schemes available. They are SSH (Secure Shell) and SSL (Secure Socket Layer/Transport Level Security). Both protocols work on transport network level ("above" TCP protocol) and utilize similar schemes. SSL is more widely used because of it's adoption for secure WWW data transfer.

Both protocols provide transparent security; this allows use of standard Internet protocols over SSL or SSH.

Certificates

As mentioned, only properly authenticated server (and in some cases client) can be treated as secure. SSL utilizes certificates to authenticate the parties and also to encrypt the data being transferred. You will find more information about certificates on SecureBlackbox site.

Briefly talking, the certificate is a secure replacement for common username/password pair, with enhanced functionality and strengthened security. By utilizing asynchronous algorithms certificate approach provides more features than other authentication systems; for example certificates have predefined lifetime and range of use.

Also there exist standard approaches to centralized certificate management, backup and recovery.

Applications

The most well known application for SSL protocol is securing commercial Internet communications. Most of commercial web sites offer an option (or even force) for use of SSL, which is used for HTTPS protocol. This is however not the only protocol to use SSL. Actually most TCP-based protocols (like POP3 and IMAP for mail, NNTP for news etc.) can work over SSL. SSH is also used to provide security for FTP and shell protocols.

SSL is useful in public operations; due to its perfect authentication capabilities, SSL is indispensable in distributed and n-tier applications, in providing authorization in heterogeneous environments and in securing data transactions and remote operation control.

For example, certificates and SSL are the optimal way of controlling access of multiple people to the database. Certificates in this scenario provide the following features:

Authenticate the user

Check whether the user is authorized to access the resource

Apply the necessary access restrictions

Encrypt private user's information

Ease logging and security audits

Unify security management procedures


How SSL works

SSL provides identification of the server, optional identification of the client, and also provides encryption and compression to the data being transferred.

SSL description uses the following terms:

Cipher suite - set of encryption and digest (hash) algorithms, which are used together during SSL session.

Asymmetric encryption algorithm - encryption algorithm, based on a pair of keys, one of which is private (secret) and another one is public (known to everybody)

Symmetric encryption algorithm - encryption algorithm that uses one secret key.

Random data - (here) some data that is used to create common secret values used during SSL session.

Certificates - blocks of data, used for identification of the parties and for encryption information. There's a separate article about certificates, their creation, use and validation, in the article about Certificates.

When the socket connection is established, SSL handshake should be carried. Handshake lets the parties to define the version of SSL protocol they use, select cipher suites and (optionally) compression methods, (optionally) authenticate each other and use asymmetric encryption algorithms to exchange random data.

1.                The handshake is started by the client, which sends SSL greeting packet to the server. The client's greeting packet contains

Client version - the highest version of SSL/TLS protocol supported by the client
Random data, which consists of date/time stamp and some random bytes
Session ID (can be omitted if new session is started). SecureBlackbox supports session management.
Supported cipher suites that define, which encryption algorithms are supported by the client
Supported compression. Current protocol implementations don't use this field

2.                The server sends either a greeting packet or error message. Handshake packet sent by the server contains

Server version - the version of SSL/TLS that was selected for use by the server
Random data block, independent from client random data
Session ID. If the client specified session ID and this ID was found by the server (and is valid, i.e. not expired, security was not compromised etc.), the value supplied by the client is put to server greeting packet. Otherwise the server sends the ID of the newly created session.
Cipher suite field - the cipher suite that was selected by the server from the list of supported cipher suites, supplied by the client
Compression method - the ID of compression type selected by the server from the list of supported compression types, supplied by the client

3.                Right after the server greeting message the server sends a certificate or a sequence of certificates. Certificate is sent to the client always unless anonymous Diffie-Hellman algorithm is used. Among other things certificate contains a public key, which is later used by the client to sign a session key.

4.                If there was no certificate sent or the certificate is used only for signing the data (not for encryption), the server sends to the client a so-called server key exchange packet. The values sent depend on the cipher suite, which was selected by the server.

5.                Depending on the cipher suite, the server may request a certificate from the client.

6.                Server sends the client a greeting completion message and expects the response from the client.

7.                If the client was asked for a certificate, it sends the requested certificate to the server. It can also sent a "no certificate" message, but in this case the server may stop the handshake.

8.                Client sends a client key exchange packet to the server. This packet contains information necessary for encryption of the data with symmetric algorithm.

9.                Certificate validation packet is sent to the server. This packet is used by the server to identify the client.

10.        The client sends algorithm specification change packet followed by completion message. The completion message is encrypted using parameters, which were defined during handshake. After completion message is sent the client can start sending data.

11.        Server sends algorithm specification change packet followed by completion message to the client. Completion message is also encrypted using parameters, which were defined during handshake. After completion message is sent the server can start sending data.

12.        Data transfer follows.

13.        After all data is transferred, one of the sides sends the close_notify message to the other side. Other side replies with it's own close_notify message and closes connection.

SSL sessions

As generation of the keys is quite slow operation, SSL protocol supports sessions. Session is defined as a set of information necessary for re-use of already exchanged information for another SSL-secured data exchange. Session data includes cipher suites and keys used. Support for sessions in your application can increase efficiency of SSL protocol if more than one connection is done from the client to the server.

Only properly closed session can be resumed.

Conclusions

Taking into account the growing value of information in distributed systems each developer must pay special attention to the services, which are provided by SSL and certificates. And SecureBlackbox can be a good assistant in achieving ultimate security in your solutions.

Downloading a URL’s HTML

Problem/Question/Abstract:

Downloading a URL&#8217;s HTML

Answer:

The objects I present in this article allow you to download data from any URL using the GET method, using only the standard socket components included with Delphi 4+. The object (TabHTTPRequest) is capable of connecting directly to a web server and then requesting a file, the object can also pass a query string; as of this writing it can only get a file using the GET method and using a query string. If there is sufficient interest I can expand the object to also handle POST and cookies, as well as interpreting the result so the return header can be used, so let me know what you guys think!

TInternetURI &#8211; This object takes a URI (uniform resource indicator) and splits it into it&#8217;s various components to allow the GET object to accept a URL such as http://www.borland.com/delphi/ as a parameter. You do not need to use this object directly.  This object however, follows the complete RFC standard for HTTP addresses and can be used to interpret any URL into its various components.

TabHTTPRequest &#8211; This object is designed to connect to a web server and download the HTML, which can then be used in your application.

A couple examples:

URL:

http://www.borland.com/delphi/

CODE:

with TabHTTPRequest.Create do
begin
Get('http://www.borland.com/delphi/');
// Work with result (ex. mmURL.Text := ResultData.DataString);
Free;
end; // with

URL:

http://www.borland.com/rad/delandcppletter.html

CODE:

with TabHTTPRequest.Create do
begin
Get('http://www.borland.com/rad/delandcppletter.html&#8217;);
// Work with result (ex. mmURL.Text := ResultData.DataString);
Free;
end; // with

URL: (This is an actual search on yahoo)

http://google.yahoo.com/bin/query?p=delphi+3000&hc=0&hs=0

CODE:

with TabHTTPRequest.Create do
begin
Get('http://google.yahoo.com/bin/query?p=delphi+3000&hc=0&hs=0');
// Work with result (ex. mmURL.Text := ResultData.DataString);
Free;
end; // with

Once get has been called you can access the HTML through the ResultData property:

mmHTML.Lines.Text := URLObject.ResultData.DataString;

I hope you found this article and function to be useful; I&#8217;d love to hear your comments, suggestions, etc.

The following is the source code for the functions described above, feel free to use the code in your own programs, but please leave my name and address intact!

I also have a complete test program available by request via e-mail.

// ---------------------------ooo------------------------------ \\
// &copy;2000 David Lederman
// dlederman@ssccompany.com
// ---------------------------ooo------------------------------ \\
unit abHTTPGet;

interface

uses
Classes, Sysutils, ScktComp;

// ---------------------------ooo------------------------------ \\
// This type will crack a Uniform Resource Indicator
// ---------------------------ooo------------------------------ \\
type
TInternetURI = class(TObject)
private
function CrackScheme(var URIData: string): string;
function CrackLocation(var URIData: string): string;
function CrackQuery(var URIData: string): string;
function CrackParams(var URIData: string): string;
public
Scheme: string;
NetLocation: string;
Path: string;
Query: string;
Fragment: string;
Params: string;
constructor Create(URIData: string);
destructor Destroy; override;
end;

type
TabHTTPRequest = class
private
iBuffer: string;
Socket: TClientSocket;
public
ResultData: TStringStream;
HostToConnect: string;
PortToConnect: Integer;
FileToGet: string;
TimeOut: Integer;
function Get: Boolean; overload;
function Get(URL: string): Boolean; overload;
constructor Create;
destructor Destroy; override;
end;

// ---------------------------ooo------------------------------ \\
// Global HTTP Routines
// ---------------------------ooo------------------------------ \\
function TrimToToken(Token: Char; var DataToParse: string; CopyToken: Boolean = True;
MaxCount: Integer = 1): string;
function TrimPastToken(Token: Char; var DataToParse: string; CopyToken: Boolean =
True; MaxCount: Integer = 1): string;

implementation

{ TabHTTPRequest }

constructor TabHTTPRequest.Create;
begin
// Simply Set Defaults
HostToConnect := 'www.InternetToolsCorp.com';
PortToConnect := 80;
FileToGet := '/';
TimeOut := 5000;
// Create the socket object
Socket := TClientSocket.Create(nil);
Socket.ClientType := ctBlocking;
// Create the result stream
ResultData := TStringStream.Create('');
end;

destructor TabHTTPRequest.Destroy;
begin
// Free the helper objects
Socket.Free;
ResultData.Free;
inherited;
end;

function TabHTTPRequest.Get: Boolean;
var
Waiter: TWinSocketStream;
BufferData: array[0..4028] of char;
DataRead: Integer;
BufferString: string;
begin
// Setup the Request
Waiter := nil;
iBuffer := '';
Socket.Host := HostToConnect;
Socket.Port := PortToConnect;
// Reset the data stream
ResultData.Size := 0;
try
// Do the request
// Open the connection
//  Socket.Open;
Socket.Open;
// Create the waiter
Waiter := TWinSocketStream.Create(Socket.Socket, TimeOut);
// Prepare the request
BufferString := 'GET ' + FileToGet + ' HTTP/1.1' + #13#10 + 'Host: ' +
HostToConnect + #13#10 + #13#10;
// Write the Request
Waiter.Write(BufferString[1], Length(BufferString));
Waiter.Free;
Waiter := nil;
// Now process the result of the request
while Socket.Socket.Connected do
begin
try
// Create the waiter
Waiter := TWinSocketStream.Create(Socket.Socket, TimeOut);
// Wait for data
if Waiter.WaitForData(TimeOut) then
begin
// Try to read a chunck of data
DataRead := Waiter.Read(BufferData, SizeOf(BufferData));
// Check if we got data
if DataRead = 0 then
begin
// Get out
Socket.Close;
end
else
begin
// Save the data to the stream
ResultData.Write(BufferData, DataRead);
end;
end
else
begin
Socket.Close;
end;
finally
Waiter.Free;
Waiter := nil;
end;
end;
// close the socket
if Socket.Active then
Socket.Close;
Result := True;
// Clean up
if Waiter <> nil then
Waiter.Free;
except
// Free the waiter object
if Waiter <> nil then
Waiter.Free;
// Close the socket if it's open
if Socket.Active then
Socket.Close;
// reraise the exception
raise;
end;
end;

function TabHTTPRequest.Get(URL: string): Boolean;
begin
// Crack the URL
try
// Make sure than a scheme is in place
if Pos('://', URL) = 0 then
begin
// Simply Prepend the HTTP
URL := 'http://' + URL;
end;
// Make sure that a / is in the URL
if Pos('/', Copy(URL, 8, Length(URL))) = 0 then
begin
// Simply Append the trailing /
URL := URL + '/';
end;

with TInternetURI.Create(URL) do
begin
// Check if there is a port in the net location
if Pos(':', NetLocation) <> 0 then
begin
// Copy the host name
HostToConnect := Copy(NetLocation, 1, Pos(':', NetLocation) - 1);
// Copy the port
PortToConnect := StrToInt(Copy(NetLocation, Pos(':', NetLocation) + 1,
Length(NetLocation)));
end
else
begin
HostToConnect := NetLocation;
PortToConnect := 80;
end;
FileToGet := '';
// Set the File to get
if Query <> '' then
FileToGet := Path + '?' + Query;
if FileToGet = '' then
FileToGet := '/';
Free
end; // with
// Now simply call get
Result := Get;
except
raise;
end;
end;

{ TInternetURI }

function TInternetURI.CrackLocation(var URIData: string): string;
var
StartPos, EndPos: Integer;
begin
// Step 1. - See if the network ID is here
StartPos := Pos('//', URIData);
// If the starting // is not found then there is no network location
if StartPos = 0 then
Exit;
// Delete the first //
Delete(URIData, StartPos, 2);
// Now look for the trailing slash
EndPos := Pos('/', URIData);
if (EndPos = 0) or (EndPos = 1) then
Exit;
// Now Copy the String Upto the /
Result := Copy(URIData, 1, EndPos - 1);
// Now Delete the network location
Delete(URIData, 1, EndPos - 1);
end;

function TInternetURI.CrackParams(var URIData: string): string;
var
StartPos: Integer;
begin
// Step 1. - See if the query is here
StartPos := Pos(';', URIData);
// If the starting ; is not found then there are no params
if StartPos = 0 then
Exit;
// Copy the Params String
Result := Copy(URIData, StartPos + 1, Length(URIData));
Delete(URIData, StartPos, Length(URIData));
end;

function TInternetURI.CrackQuery(var URIData: string): string;
var
StartPos: Integer;
begin
// Step 1. - See if the query is here
StartPos := Pos('?', URIData);
// If the starting ? is not found then there is no query
if StartPos = 0 then
Exit;
// Copy the Query String
Result := Copy(URIData, StartPos + 1, Length(URIData));
Delete(URIData, StartPos, Length(URIData));
end;

function TInternetURI.CrackScheme(var URIData: string): string;
const
AllowedChars = ['A'..'Z', 'a'..'z', '0'..'9', '+', '-', '.'];
var
tString, WorkData: string;
i: Integer;
StringLength: Integer;
InValidScheme: Boolean;
begin
// Step 1. - Get To The First
WorkData := TrimToToken(':', URIData, False);
if WorkData = '' then
begin
Result := '';
Exit;
end;
// Get The String Length
StringLength := Length(WorkData);
// See if any invalid characters are in the system
InValidScheme := False;
for i := 1 to StringLength do
begin
// Check if the char is valid
InValidScheme := (WorkData[i] in AllowedChars) = False;
if InValidScheme then
Break;
end;
if InValidScheme then
begin
// we need to return the data back to the string
URIData := WorkData + ':' + URIData;
end
else
begin
Result := WorkData;
end;
end;

constructor TInternetURI.Create(URIData: string);
begin
// Step 1. - Copy The Fragment
Fragment := TrimPastToken('#', URIData, False);
// Step 2. - Crack the Scheme
Scheme := CrackScheme(URIData);
// Step 3. - Crack the Network Location
NetLocation := CrackLocation(URIData);
// Step 4. - Crack the Query
Query := CrackQuery(URIData);
// Step 5. - Crack the Parameters
Params := CrackParams(URIData);
// Finally !! Copy the Path (which should be all that is remaining)
Path := URIData;
end;

destructor TInternetURI.Destroy;
begin
inherited;

end;

// ---------------------------ooo------------------------------ \\
// Global routines for HTTP Processing
// ---------------------------ooo------------------------------ \\
// ---------------------------ooo------------------------------ \\
// This function will take the DataToParse and create a string
// list seperating the data using the user-defined tokens.
// ---------------------------ooo------------------------------ \\

function TokenizeString(Tokens: TSysCharSet; DataToParse: string): TStringList;
var
StringLength: Integer;
i, CurPos, StartPos: Integer;
tempString: string;
begin
try
// Create the result set
Result := TStringList.Create;
// Get The String Length
StringLength := Length(DataToParse);
// Setup the search
CurPos := 1;
StartPos := 1;
// Look for the tokens
for i := 1 to StringLength do
begin
// Increment the current position
Inc(CurPos);
// See if the char is in the token list
if DataToParse[i] in Tokens then
begin
// copy the string to current
tempString := Copy(DataToParse, StartPos, (CurPos - 1) - StartPos);
Result.Add(tempstring);
StartPos := i + 1;
end;
end;
// Copy the final string (if neccesary)
if (StartPos - 1) <> StringLength then
begin
tempString := Copy(DataToParse, StartPos, StringLength);
Result.Add(tempString);
end;
except
Result.Free;
Result := nil;
end;
end;

// ---------------------------ooo------------------------------ \\
// This function will use the TokenizeString routine to get
// all the occurences of Token then return all the string to
// the right of MaxCount occurences.
// ---------------------------ooo------------------------------ \\

function TrimToToken(Token: Char; var DataToParse: string; CopyToken: Boolean = True;
MaxCount: Integer = 1): string;
var
i: Integer;
begin
// First Tokenize the string
with TokenizeString([Token], DataToParse) do
begin
// Check if there were any occurences of Token
if Count = 0 then
begin
// Return blank then free and exit
Result := '';
Free;
Exit;
end;
// reset the final string
DataToParse := '';
for i := 0 to (MaxCount - 1) do
begin
// concat the string
if CopyToken then
Result := Result + Strings[i] + Token
else
Result := Result + Strings[i];
end;
// Copy and remaining data
for i := (MaxCount) to Pred(Count) do
begin
DataToParse := DataToParse + Strings[i];
end;
Free;
end;
end;

// ---------------------------ooo------------------------------ \\
// This function will use the TokenizeString routine to get
// all the occurences of Token then return all the string to
// the left of MaxCount occurences.
// ---------------------------ooo------------------------------ \\

function TrimPastToken(Token: Char; var DataToParse: string; CopyToken: Boolean =
True; MaxCount: Integer = 1): string;
var
i: Integer;
begin
// First Tokenize the string
with TokenizeString([Token], DataToParse) do
begin
// Check if there were any occurences of Token
if Count = 0 then
begin
// Return blank then free and exit
Result := '';
Free;
Exit;
end;
// reset the final string
DataToParse := '';
for i := 0 to (MaxCount - 1) do
begin
// concat the string
DataToParse := DataToParse + Strings[i];
end;
// Copy and remaining data
for i := (MaxCount) to Pred(Count) do
begin
if CopyToken then
Result := Result + Token + Strings[i]
else
Result := Result + Strings[i];
end;
Free;
end;
end;

end.