Variety of Floating point functions

Problem/Question/Abstract:

Variety of Floating point functions

Answer:

// FloatDecimals

function FloatDecimals(Value, decimals: extended): extended;
var
  Factor: extended;
begin
  Factor := Power(10, Decimals);
  Value := Value * Factor;
  Value := Round(Value);
  Value := Value / Factor;
  Result := Value;
end;

// FloatRound ( Same as FloatDecimals but more aqurate )

function FloatRound(Value, Digits: extended): extended;
var
  Factor: extended;
begin
  Factor := Power(10, Digits);
  Result := (Value * Factor) + 0.5;
  Result := Trunc(Result) / Factor;
end;

// FloatCompare

function FloatCompare(Value1, Value2: Extended): Boolean;
begin
  Result := False;
  if abs(Value1 - Value2) < 0.00001 then
    Result := True;
end;

// FloatLessEqual

function FloatLessEqual(Value1, Value2: extended): Boolean;
begin
  Result := False;
  if (abs(Value1 - Value2) < 0.00001) or (Value1 < Value2) then
    Result := True;
end;

// FloatGreateEqual

function FloatGreaterEqual(Value1, Value2: extended): Boolean;
begin
  Result := False;
  if (abs(Value1 - Value2) < 0.00001) or (Value1 > Value2) then
    Result := True;
end;

// FloatStr (Format a extended value towards a string with 2 decimals )

function FloatStr(Value: extended): string;
begin
  Result := FloatToStrF(Value, ffFixed, 18, 2);
end;

// FloatStr ( Format a extended value towards a string with specified decimals )

function FloatStr(Value: extended; Digits: Byte): string;
begin
  Result := FloatToStrF(Value, ffFixed, 18, Digits);
end;

Add a New Menu Item to the System Menu of an Application

Problem/Question/Abstract:

How can I add my own custom menu item to another application - one I haven't written?

Answer:

This tip is something that I've wanted to do for awhile, but kept on forgetting to write the article for it. It involves adding a menu choice to the system menu of an application. For the most part, you'll never have a need to do this. But there are some things like setting a form style, or some other action that is more system oriented than application oriented that just belong in the system menu. Well, here it is folks, and as usual, it's pretty incredibly easy to implement.

If you've tried to do this before but couldn't, it's because there is no way to add a menu item with standard Delphi calls. You have to trap Windows the windows message WM_SYSCOMMAND and evaluate the wParam message element to see if your added menu item was selected. Really folks, it's not that hard, and a little digging in the API help was all I needed to do find out how to implement this in a program. Basically, what you have to do is this:

Create a new form.
Override the OnMessage event by assigning a new event handler procedure for the OnMessage event.
Create a constant that will be used as the ordinal identifier for your menu choice.
In the FormCreate, make your menu choice with the AppendMenu API call.

Here's the code to show you how to do it:

unit sysmenu;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes,
  Graphics, Controls, Forms, Dialogs, Menus;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    {This declaration is of the type TMessageEvent which
     is a pointer to a procedure that takes two variable
     arguments of type TMsg and Boolean, respectively}

    procedure WinMsgHandler(var Msg: TMsg;
      var Handled: Boolean);
  end;

var
  Form1: TForm1;

const
  MyItem = 100; {Here's the menu identifier.
  It can be any WORD value}

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin

  {First, tell the application that its message
  handler is different from the default}
  Application.OnMessage := WinMsgHandler;

  {Add a separator}
  AppendMenu(GetSystemMenu(Self.Handle, False),
    MF_SEPARATOR, 0, '');

  {Add your menu choice. Since the Item ID is high,
  using the MF_BYPOSITION constant will place
   it last on the system menu}
  AppendMenu(GetSystemMenu(Self.Handle, False),
    MF_BYPOSITION, MyItem, 'My Men&u Choice');

end;

procedure TForm1.WinMsgHandler(var Msg: TMsg;
  var Handled: Boolean);
begin
  {if the message is a system one...}
  if Msg.Message = WM_SYSCOMMAND then
    if Msg.wParam = MyItem then
      {Put handling code here. I've opted for
       a ShowMessage for demonstration purposes}
      ShowMessage('You picked my menu!!!');
end;

end.

As you can see, this is fairly straight-forward. Granted, the tip is not very complicated. However, it does open up many doors to things you can do. In anticipation of some questions you might have later, The AppendMenu command can also be used with minimized apps. For instance, if you minimize your app, the icon represents the application, not your form. Therefore in order to make the system menu with your changes visible when in minimized form you would use Application.Handle instead of Self.Handle to deal with the application's system menu.

Get outlookexpress directory

Problem/Question/Abstract:

Did you ever wonder how to retrieve the outlookexpress directory. Down below the answer ..

Answer:

function GetOutlookExpressDir: string;
var
  Reg: TRegistry;
  ts, userID: string;
begin
  ts := '';
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if Reg.OpenKey('\Software\Microsoft\Outlook Express', False) then
      ts := Reg.ReadString('Store Root');
    if ts = '' then
    begin
      if Reg.OpenKey('\Identities', False) then
      begin
        userID := Reg.ReadString('Default User ID');
        if Reg.OpenKey('\Identities\' + userID +
          '\Software\Microsoft\Outlook Express\5.0', False) then
          ts := Reg.ReadString('Store Root');
      end;
    end;
  finally
    if (ts <> '') then
    begin
      SetLength(userID, 1024);
      if (ExpandEnvironmentStrings(pointer(ts), @userID[1], 1024) > 0) then
        result := pchar(userID)
      else
        result := ts;
    end;
    Reg.CloseKey;
    Reg.Free;
  end;
end;

How to check for any lower case or space in a string

Problem/Question/Abstract:

How to check for any lower case or space in a string

Answer:

function ContainsLowerCaseOrSpace(AString: string): boolean;
var
  MySet: set of char;
  Len, Counter: integer;
begin
  MySet := ['a'..'z', ' '];
  Len := Length(AString);
  Result := Len <> 0;
  Counter := 1;
  while (not Result) and (Counter <= Len) do
  begin
    if AString[Counter] in MySet then
      Result := True
    else
      Inc(Counter);
  end;
end;

procedure AddSpaceBeforeUpperCaseCharOrNumber(var AString: string);
var
  Counter: integer;
  bLastIsNumber: boolean;
  bLastIsUpper: boolean;
begin
  Counter := Length(AString);
  bLastIsUpper := False; {Assume the last character will never be an upper case}
  bLastIsNumber := AString[Counter] in ['0'..'9'];
  dec(Counter);
  while Counter > 1 do
  begin
    if AString[Counter] in ['0'..'9'] then
    begin
      if not bLastIsNumber then
        Insert(' ', AString, Counter + 1);
      bLastIsNumber := True;
    end
    else
    begin
      if bLastIsNumber or bLastIsUpper then
      begin
        Insert(' ', AString, Counter + 1);
        bLastIsNumber := False;
      end;
      bLastIsUpper := AString[Counter] in ['A'..'Z'];
    end;
    dec(Counter);
  end;
end;

How to create isometric maps

Problem/Question/Abstract:

I'm planning to make an isometric map based game. Now, to do this, I need to know if the user clicked on one (or more) squares, for example, a building or a creature. I cannot figure out how to do this.

Answer:

Create a new project. On the form, create a TImage and align it to client. Also assign the form's OnCreate event, and the Image's OnMouseUp and OnMouseDown events. Paste this code into Unit1 and run. A 10x10 grid will be drawn. Click in it to highlight a square.


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  private
  public
  end;

var
  Form1: TForm1;

implementation

uses
  Math;

{$R *.DFM}

var
  XC: Integer;
  YC: Integer;
  LastX: Single;
  LastY: Single;

const
  Scale = 20;

procedure Map(const WorldX: Single; const WorldY: Single; out DisplayX: Integer;
  out DisplayY: Integer);
begin
  DisplayX := Round(XC + Scale * (WorldX - WorldY) * 0.5 * Sqrt(3));
  DisplayY := Round(YC + Scale * (WorldX + WorldY) * 0.5);
end;

procedure UnMap(const DisplayX: Integer; const DisplayY: Integer; out WorldX: Single;
  out WorldY: Single);
var
  Sum: Single;
  Diff: Single;
begin
  Diff := (DisplayX - XC) / (0.5 * Scale * Sqrt(3));
  Sum := (DisplayY - YC) / (0.5 * Scale);
  WorldY := (Sum - Diff) / 2;
  WorldX := Sum - WorldY;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
  X1: Integer;
  Y1: Integer;
  X2: Integer;
  Y2: Integer;
begin
  XC := ClientWidth div 2;
  YC := ClientHeight div 2;
  with Image1.Picture.Bitmap do
  begin
    Width := Image1.Width;
    Height := Image1.Height;
  end;
  for I := -5 to 5 do
  begin
    Map(I, 5, X1, Y1);
    Map(I, -5, X2, Y2);
    with Image1.Picture.Bitmap.Canvas do
    begin
      MoveTo(X1, Y1);
      LineTo(X2, Y2);
    end;
    Map(5, I, X1, Y1);
    Map(-5, I, X2, Y2);
    with Image1.Picture.Bitmap.Canvas do
    begin
      MoveTo(X1, Y1);
      LineTo(X2, Y2);
    end;
  end;
end;

procedure ColorizeCell(const Color: TColor);
var
  PolygonData: array[0..3] of TPoint;
begin
  if ((Abs(LastX) < 5) and (Abs(LastY) < 5)) then
  begin
    Map(Floor(LastX), Floor(LastY), PolygonData[0].X, PolygonData[0].Y);
    Map(Floor(LastX), Ceil(LastY), PolygonData[1].X, PolygonData[1].Y);
    Map(Ceil(LastX), Ceil(LastY), PolygonData[2].X, PolygonData[2].Y);
    Map(Ceil(LastX), Floor(LastY), PolygonData[3].X, PolygonData[3].Y);
    with Form1.Image1.Picture.Bitmap.Canvas do
    begin
      Brush.Style := bsSolid;
      Brush.Color := Color;
      Polygon(PolygonData);
    end;
  end;
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Unmap(X, Y, LastX, LastY);
  ColorizeCell(clRed);
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  ColorizeCell(clWhite);
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  ColorizeCell(clWhite);
  Unmap(X, Y, LastX, LastY);
  ColorizeCell(clYellow);
end;

end.

How to store a text file in a resource and display the lines in a TStringGrid at runtime

Problem/Question/Abstract:

I am trying to work out how to store approximately 1000 lines of text (3 columns, 30 chars each) inside an application. I want to read the values and then display them in a TStringGrid and do some further manipulation.

Answer:

If you want to read the data into a stringgrid a way to do that without building a class around the resource data would be this. You start by placing the data into a file and the file into a resource as detailed in Tip Number 1004. Loading this data into a TStringGrid would work like this:


procedure LoadResourceIntoGrid(grid: TStringGrid);
var
  rs: TResourceStream;
  numElements: Integer;
  datarec: TFileData;
  i: Integer;
begin
  rs := TResourceStream.Create(hInstance, 'FILEDATA', RT_RCDATA);
  try
    numElements := rs.Size div Sizeof(numElements);
    grid.Perform(WM_SETREDRAW, 0, 0);
    try
      grid.RowCount := numElements + 1; {assuming a header row}
      {following assumes grids colcount has been set correctly already}
      for i := 1 to numElements do
      begin
        rs.ReadBuffer(datarec, sizeof(datarec));
        grid.Cells[grid.FixedCols, i] := datarec.col1;
        grid.Cells[grid.FixedCols + 1, i] := datarec.col2;
        grid.Cells[grid.FixedCols + 2, i] := datarec.col3;
      end;
    finally
      grid.Perform(WM_SETREDRAW, 1, 0);
      grid.Invalidate;
    end;
  finally
    rs.free
  end;
end;

How to pick from a list of TPanels in a TListBox and display the selected panel

Problem/Question/Abstract:

How to pick from a list of TPanels in a TListBox and display the selected panel

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    procedure ListBox1Click(Sender: TObject);
  private
    { Private declarations }
    FPanelList: TList;
    FActivePanel: TPanel;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{TForm1}

constructor TForm1.Create(AOwner: TComponent);
var
  i: integer;
  TempPanel: TPanel;
begin
  inherited;
  FPanelList := TList.Create;
  for i := 0 to 20 do
  begin
    TempPanel := TPanel.Create(self);
    TempPanel.Caption := 'TPanel' + IntToStr(i);
    Listbox1.Items.Add(TempPanel.Caption);
    FPanelList.Add(TempPanel);
  end;
end;

destructor TForm1.Destroy;
var
  i: integer;
begin
  for i := FPanelList.Count - 1 downto 0 do
    TPanel(FPanelList[i]).Free;
  FPanelList.Free;
  inherited;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  if FActivePanel <> nil then
    FActivePanel.Parent := nil;
  FActivePanel := FPanelList[ListBox1.ItemIndex];
  FActivePanel.Parent := self;
end;

end.

How to play a WAV file when minimizing or maximizing a window

Problem/Question/Abstract:

How to play a WAV file when minimizing or maximizing a window

Answer:

Try the API SndPlaySound. It works fine without the need of visible components. Use the OnResize event and check WindowStatus for any changes.


procedure TForm1.FormResize(Sender: TObject);
begin
  case WindowStatus of
    wsMinimized: sndPlaySound('min.wav', );
    wsMaximized: sndPlaySound('max.wav', );
  end;
end;

How to register and remove fonts at runtime

Problem/Question/Abstract:

How to register and remove fonts at runtime

Answer:

The following source code will show you how to add (register) and remove fonts at runtime.

unit Unit1;

interface

uses
  Windows, Sysutils, Messages, Classes, Graphics, Forms, StdCtrls, FileCtrl, Controls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    FileListBox1: TFileListBox;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private Declarations }
    procedure GetNewFontNames;
  public
    { Public Declarations}
  end;
var
  Form1: TForm1;

implementation

{$R *.DFM}
var
  sFontfile: string;
  result_send: Integer;
  LFont: TLogFont;
  result_add: Integer;

procedure TForm1.FormCreate(Sender: TObject);
var
  index: Integer;
begin
  Form1.caption := 'Loddfont - Dossier  ' + extractfilepath(application.exename);
  if FileListBox1.Items.Count = 0 then
    button1.caption := 'Fermer. Pas de polices dans ce dossier !';
  for index := 0 to FileListBox1.Items.Count - 1 do
  begin
    sFontfile := extractfilepath(application.exename) + filelistbox1.items[index] +
      #0;
    result_add := AddFontResource(@sFontfile[1]);
    if result_add = 0 then
    begin
      button1.caption := 'Fermer. Probl�me lors du chargement de ce dossier !';
    end
    else
    begin
      result_send := SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
      button1.caption := 'D�charger les polices et fermer Loddfont';
    end;
  end;
  GetNewFontNames;
  messagebeep(1);
end;

function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; Data: Pointer): Integer; stdcall;
var
  S: TStrings;
  Temp: string;
begin
  S := TStrings(Data);
  Temp := LogFont.lfFaceName;
  if (S.Count = 0) or (AnsiCompareText(S[S.Count - 1], Temp) <> 0) then
    S.Add(Temp);
  Result := 1;
end;

procedure TForm1.GetNewFontNames;
var
  DC: HDC;
begin
  DC := GetDC(0);
  LFont.lfCharSet := DEFAULT_CHARSET;
  EnumFontFamiliesEx(DC, LFont, @EnumFontsProc, LongInt(Listbox1.Items), 0);
  ReleaseDC(0, DC);
  Listbox1.sorted := True;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  index: Integer;
begin
  for index := 0 to FileListBox1.Items.Count - 1 do
  begin
    sFontfile := extractfilepath(application.exename) + filelistbox1.items[index] +
      #0;
    RemoveFontResource(@sFontfile[1]);
  end;
  result_send := SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
  form1.close;
end;

end.

Two colour fade effects

Problem/Question/Abstract:

Two color fade effects

Answer:

With a fast SetPal procedure you can create a smooth fade. Here are a few simple but effective fade routines:

var
  fadepal: array[0..15, 1..3] of byte;
  i, j: Integer;

procedure fadeout;
begin
  for i := 0 to 15 do
    getpal(colnum[i], fadepal[i, 1], fadepal[i, 2], fadepal[i, 3]);
  for j := 63 downto 0 do
  begin
    for i := 0 to 15 do
      setpal(colnum[i], fadepal[i, 1] * j div 63, fadepal[i, 2] * j div 63, fadepal[i, 3] * j div 63);
    delay(10);
  end;
end;

procedure fadein;
begin
  for j := 0 to 63 do
  begin
    for i := 0 to 15 do
      setpal(colnum[i], fadepal[i, 1] * j div 63, fadepal[i, 2] * j div 63, fadepal[i, 3] * j div 63);
    delay(10);
  end;
end;

Based on this you can also make interesting 'psycho-fades': instead of fading to black fade to another colour or to 2 or 4 or 16 other colors.

Find out if IP Address is valid

Problem/Question/Abstract:

Find out if IP Address is valid

Answer:

function IsWrongIP(ip: string): boolean;
var
  z, i: byte;
  st: array[1..3] of byte;
const
  ziff = ['0'..'9'];
begin
  st[1] := 0;
  st[2] := 0;
  st[3] := 0;
  z := 0;
  Result := False;
  for i := 1 to length(ip) do
    if ip[i] in ziff then
    else
    begin
      if ip[i] = '.' then
      begin
        inc(z);
        if z < 4 then
          st[z] := i
        else
        begin
          IsWrongIP := True;
          exit;
        end;
      end
      else
      begin
        IsWrongIP := True;
        exit;
      end;
    end;
  if (z <> 3) or (st[1] < 2) or (st[3] = length(ip)) or (st[1] + 2 > st[2]) or
    (st[2] + 2 > st[3]) or (st[1] > 4) or (st[2] > st[1] + 4) or (st[3] > st[2] + 4) then
  begin
    IsWrongIP := True;
    exit;
  end;
  z := StrToInt(copy(ip, 1, st[1] - 1));
  if (z > 255) or (ip[1] = '0') then
  begin
    IsWrongIP := True;
    exit;
  end;
  z := StrToInt(copy(ip, st[1] + 1, st[2] - st[1] - 1));
  if (z > 255) or ((z <> 0) and (ip[st[1] + 1] = '0')) then
  begin
    IsWrongIP := True;
    exit;
  end;
  z := StrToInt(copy(ip, st[2] + 1, st[3] - st[2] - 1));
  if (z > 255) or ((z <> 0) and (ip[st[2] + 1] = '0')) then
  begin
    IsWrongIP := True;
    exit;
  end;
  z := StrToInt(copy(ip, st[3] + 1, length(ip) - st[3]));
  if (z > 255) or ((z <> 0) and (ip[st[3] + 1] = '0')) then
  begin
    IsWrongIP := True;
    exit;
  end;
end;

How to specify the name of a database that is in a different directory

Problem/Question/Abstract:

In an SQL select statement, how do I specify the name of a database that is in a different directory? Is there a way to parameterize the name so that a BDE alias is used to supply the directory?

Answer:

You cannot parameterize the value in an SQL statement such that a BDE alias could use the value. You could programmatically change the directory specified in the BDE alias itself, though. For that, see the TSession.ModifyAlias method.

But there are other ways to do this, ways that do not involve aliases. The table reference in a local SQL statement can consist of just a table name:

SELECT *
FROM Customer

It can be a table name and filename extension:


SELECT *
FROM "Customer.db"

It can be a table name prefixed with the name of a BDE alias:

SELECT *
FROM ": DBDEMOS: Customer.db"

or it can be a table name prefixed with a specific drive and directory reference:

SELECT *
FROM "C:\Program Files\Common Files\Borland Shared\Data\Customer"

With the different parts of an SQL statement on different lines within the TQuery.SQL property, you can more easily change just one of those parts without affecting the other parts. Do this by referencing one element of the string list object that is the SQL property. For example, to change just the second line (the FROM clause):

with Query1 do
begin
  Close;
  SQL[1] := '"' + DatabaseStrVar + 'Customer.db"';
  Open;
end;

You could then set this memory variable DatabaseStrVar to a number of different values and the same code would still work.

1. An empty string.
2. The name of an alias (including colons in the variable).
3. A valid drive/ directory reference (ending in a back-slash).

Create a standard windows shortcut file

Problem/Question/Abstract:

How can I create a standard windows shortcut file (*.lnk) from my Delphi application?

Answer:

Below is an example that creates a shortcut to a DOS batch file. You need to use the procedure CreateLink();

program kg_MakeLink;

{****************************************************************}
{*                                                              *}
{* Language:    Delphi 3.00, 32 bit                             *}
{*              All code is within this one source file.        *}
{*                                                              *}
{* Description: Used to programmically create a 'ShortCut' to a *}
{*              DOS batch file. The ShortCut when invoked will  *}
{*              run in a minimized state. Location of newly     *}
{*              created ShortCut is in the same directory as    *}
{*              the batch file.                                 *}
{*                                                              *}
{* Comments:    It is up to the programmer to insure that all   *}
{*              commands called in the batch file are valid.    *}
{*                                                              *}
{* Suggestions: Attempt running the batch file under abnormal   *}
{*              conditions to see how things go, does the DOS   *}
{*              calls hang? etc.                                *}
{*                                                              *}
{* Error Codes: 0 = Success                                     *}
{*              1 = Either to many or not enough parameters     *}
{*              2 = File passed to this util, does not exist    *}
{*              3 = Failed to created ShortCut                  *}
{****************************************************************}
uses
  Windows, ShlObj, ActiveX, ComObj, SysUtils, Dialogs;

{$R *.RES}

procedure CreateLink(Target, Args, WorkDir, ShortCutName: string);
var
  IObj: IUnknown;
  Link: IShellLink;
  IPFile: IPersistFile;
  TargetW: WideString;
begin
  IObj := CreateComObject(CLSID_ShellLink);
  Link := IObj as IShellLink;
  IPFile := IObj as IPersistFile;

  with Link do
  begin
    SetPath(PChar(Target));
    SetArguments(PChar(Args));
    SetShowCmd(SW_SHOWMINIMIZED);
    SetWorkingDirectory(PChar(WorkDir));
  end;
  TargetW := ShortCutName;
  IPFile.Save(PWChar(TargetW), False);
end;

var
  a, b: string;

begin
  if ParamCount = 1 then
  begin
    a := ParamStr(1);
    if FileExists(a) then
    begin
      ShowMessage('A = ' + a);
      b := ExtractFilename(a) + '.lnk';
      ShowMessage('B = ' + b);
      try
        CreateLink(a, '', '', ExtractFileDir(a) + #92 + b);
      except
        halt(3); { Failed to create shortcut }
      end;
    end
    else
      halt(2); { File does not exist }
  end
  else
    halt(1); { Wrong amount of arguments }
end.

How to determine the current record number of a dataset

Problem/Question/Abstract:

How to determine the current record number of a dataset

Answer:

If the dataset is based upon a Paradox or dBASE table then the record number can be determined with a couple of calls to the BDE (as shown below). The BDE doesn't support record numbering for datasets based upon SQL tables, so if your server supports record numbering you will need to refer to its documentation.

The following function is given as part of a whole unit and takes as its parameter any component derived from TDataset (i.e. TTable, TQuery, TStoredProc) and returns the current record number (greater than zero) if it is a Paradox or dBASE table. Otherwise, the function returns zero.

For dBASE tables the record number returned is always the physical record number. So, if your dataset is a TQuery or you have a range set on your dataset then the number returned won't necessarily be relative to the dataset being viewed, rather it will be based on the record's physical position in the underlying dBASE table.

uses
  DB, DBTables, DbiProcs, DbiTypes, DbiErrs;

function GetRecordNumber(Dataset: TDataset): Longint;
var
  CursorProps: CurProps;
  RecordProps: RECProps;
begin
  { Return 0 if dataset is not Paradox or dBASE }
  Result := 0;
  with Dataset do
  begin
    { Is the dataset active? }
    if State = dsInactive then
      raise EDatabaseError.Create('Cannot perform this operation ' + 'on a closed dataset');
    { We need to make this call to grab the cursor's iSeqNums }
    Check(DbiGetCursorProps(Handle, CursorProps));
    { Synchronize the BDE cursor with the Dataset's cursor }
    UpdateCursorPos;
    { Fill RecordProps with the current record's properties }
    Check(DbiGetRecord(Handle, dbiNOLOCK, nil, @RecordProps));
    { What kind of dataset are we looking at? }
    case CursorProps.iSeqNums of
      0: Result := RecordProps.iPhyRecNum; { dBASE }
      1: Result := RecordProps.iSeqNum; { Paradox }
    end;
  end;
end;

end.

How to copy a 2D array with picture greylevels to an image

Problem/Question/Abstract:

I want to move a 2D array with picture grey-levels to an Image or BMP object without first save the array to disk? I want to display the image faster on the canvas than I do now by using canvas.pixels.

Answer:

A solution (not necessarily the best but it works) is as follows:


1. Create a Bitmap (TBitmap) within the TImage


Bitmap := TBitmap.Create;
BitMap.Width := NCol;
BitMap.Height := NRow;
{...}


2. Create a logical palette (greyscale or whatever) and assign it to Bitmap.Palette


CreatePalette(MyLogPalette);
{ etc. }


3. Now draw pixels into the Bitmap canvas NOT the image canvas (which is slow...). Use the
    number of colours in your logical palette to scale the intensity values.


4. Clean up. Free logical palette etc.

DeleteObject(Image.Picture.Bitmap.ReleasePalette);

How to change brightness and contrast in large bitmaps (2)

Problem/Question/Abstract:

I have a Truecolor bitmap in TBitmap. Is there any fast coding to set the brightness?

Answer:

Add a fixed value and clip it to the range. I have used a LUT, which is faster for larger bitmaps. The range of Brightness is -255 (-100%) to 255 (+100%). You can use a 32 or 24 Bit calculation depending on the compiler setting ChangeBrightness24Bit.


procedure ChangeBrightness(Bitmap: TBitmap; Brightness: Integer);
var
  LUT: array[Byte] of Byte;
  v, i: Integer;
{$IFDEF ChangeBrightness24Bit}
  w, h, x, y: Integer;
  LineSize: LongInt;
  pLineStart: PByte;
{$ENDIF}
  p: PByte;
begin
  { create LUT }
  for i := 0 to 255 do
  begin
    v := i + Brightness;
    if v < 0 then
      v := 0
    else if v > 255 then
      v := 255;
    LUT[i] := v;
  end;

{$IFDEF ChangeBrightness24Bit}
  { edit bitmap }
  w := Bitmap.Width;
  h := Bitmap.Height - 1;
  Bitmap.PixelFormat := pf24Bit;
  pLineStart := PByte(Bitmap.ScanLine[h]);
  { pixel line is aligned to 32 Bit }
  LineSize := ((w * 3 + 3) div 4) * 4;
  w := w * 3 - 1;
  for y := 0 to h do
  begin
    p := pLineStart;
    for x := 0 to w do
    begin
      p^ := LUT[p^];
      Inc(p);
    end;
    Inc(pLineStart, LineSize);
  end;
{$ELSE}
  { edit bitmap }
  Bitmap.PixelFormat := pf32Bit;
  p := PByte(Bitmap.ScanLine[Bitmap.Height - 1]);
  for i := 0 to Bitmap.Width * Bitmap.Height - 1 do
  begin
    p^ := LUT[p^];
    Inc(p);
    p^ := LUT[p^];
    Inc(p);
    p^ := LUT[p^];
    Inc(p, 2);
  end;
{$ENDIF}
end;

How to identify the paper names of the active printer

Problem/Question/Abstract:

How to identify the paper names of the active printer

Answer:

procedure TFReport.GetPapernames(sl: TStrings);
type
  TPaperName = array[0..63] of Char;
  TPaperNameArray = array[1..High(Integer) div Sizeof(TPaperName)] of TPaperName;
  PPapernameArray = ^TPaperNameArray;
var
  Device, Driver, Port: array[0..255] of Char;
  hDevMode: THandle;
  i, numPaperformats: Integer;
  pPaperFormats: PPapernameArray;
begin
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  numPaperformats := WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, nil, nil);
  if numPaperformats > 0 then
  begin
    GetMem(pPaperformats, numPaperformats * Sizeof(TPapername));
    try
      WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, Pchar(pPaperFormats), nil);
      sl.Clear;
      for i := 1 to numPaperformats do
        sl.add(pPaperformats^[i]);
    finally
      FreeMem(pPaperformats);
    end;
  end;
end;

Stream forms to and from disk

Problem/Question/Abstract:

I have a form that creates an advanced SQL string and I am trying to stream the entire form (TAdvanced) to disk in order to save the state of the form, and then be able to easily recall it later without having to decode the SQL string. However, after successfully (I think) streaming it to disk, I get the error "A component named PageControl1 already exists". I have tried all kinds of variations on this, but there always seems to be some conflict - either TAdvanced can't be assigned to TAdvanced or the current, or others. Any suggestions would be appreciated. Do I need to manually iterate through the components of the form and write each one in turn to the stream?

Answer:

I would use Read/ WriteComponentResFile with code similar to:

constructor TFrmPersistent.Create(AOwner: TComponent);
begin
  if FileExists('Persistent.xGS') then
  begin
    inherited CreateNew(AOwner);
    ReadComponentResFile('Persistent.xGS', self);
    self.Visible := false;
    FormCreate(self);
  end
  else
    inherited Create(AOwner);
end;

procedure TFrmPersistent.FormDestroy(Sender: TObject);
begin
  WriteComponentResFile('Persistent.xGS', self);
end;

Make Your Own Self Extractor (sfx)

Problem/Question/Abstract:

How to create an SFX (Self Extracting Executable)

Answer:

This tutorial will teach you the basics and structure of a SFX, in two parts, in theory (this file) and in practice (the project files)

STEP 1 o_o Choices [File Format]

We must take accountable what type of SFX where going to use, in this tutorial we will use the standard compression/storage standard.

Fields per Frame (File)
File Name
[Options]
  Fixed String Storage (255 Byte Standard)
    Advantages
      FAST
      EASY TO UNDERSTAND
      ZOMBIE READ (NO PROC)
    Disadvantages
      WASTED SPACE
      WASTED MEMORY
  Dynamic String Storage (1 to 256 Bytes)
    Advantages
      OPTIMAL SPACE USAGE

      LESS CHANGE OF CORRUPTION
      FASTER DOWNLOAD
      FASTER UPLOAD
    Disadvantages
      A LITTLE SLOWER
      PROCESSING READ (PROC)
Data Size [Options]
  Fixed Cardinal Storage (4 Byte Standard)
    Advantages
      FAST
      EASY TO UNDERSTAND
      ZOMBIE READ (NO PROC)
    Disadvantages
      WASTED SPACE
  Dynamic Cardinal Read (Advanced 1 - 5 Bytes)
    Advantages
      OPTIMAL SPACE USAGE
      LESS CHANCE OF CORRUPTION
      FASTER DOWNLOAD
      FASTER UPLOAD
    Disadvantages
      A LITTLE SLOWER
      PROCESSING READ (PROC)
      ADVANCED MEMORY ROUTINES  
Size Check [Options]
  Uncompressed Size (Cardinal)
    Advantages  
      FAST
      EASY
    Disadvantages
      UNSAFE
  CRC 32 (Cardinal)
    Advantages
      SAFE
      GET TO LEARN CRC32
    Disadvantages
      SLOW
      OVERKILL

You must look well into what you need and what out of the SFX to be able to choose the proper format to build, EVEN IF PEOPLE DON'T NOTICE, DO IT RIGHT!

STEP 2 o_0 Frame Format Structure Layout

Field Type Size
File Name DString 1 - 256 Bytes
Data Size Cardinal 4 Bytes
Uncompressed Size Cardinal 4 Bytes

We will introduce you step by step to the wild world of Dynamic Variables
Simple? YES
Useless? NO

Since this format doesn't have a POSITION field, we will use the old fashioned DATA HEADER approach to the SFX. This means it will be that it is meant to DUMP the files not to LOOK UP the files.

There are ways we can CONVERT this Frame Format to use in a FAT like table, but lets keep it simple (FOR NOW)

STEP 3 0_0 SFX File Format Structure

Data Type Size
SFX ID  Char 2
Frame Count Word 2
Frame Data Raw UNKNOWN
SFX Data Size Cardinal 4

SFX ID is used to detect if the executable (image file) contains valid SFX Data
Frame Count is used to tell us how many frames to process
Frame Data is the Frame Header (Structure) + Raw/Compressed File Data
SFX Data Size is NEEDED (you will see)

STEP 4 0_! How to add data to and Image File Module (EXE)

A little known fact of the all mighty image file (EXE) is that like a GOOD file format, it is that only what is specified is needed.

By that I mean that you can add what ever you want at the end and nothing will happen, no ZIP drive bursting in flames or even worse a "BLUE SCREEN" (c) Micro$oft 1991-2002

Now you see why I need the SFX Length at the END? yes its to go to the end of the READ-ONLY Image File (EXE) and read the Length, then look up the SFX ID to see if any SFX data is present on that Image File (EXE)

STEP 5 !_! Now to build an SFX module

Well this is an easy and important part of the process, make it as SMALL as POSSIBLE, yes kiddies

"YOU CAN PACK THE IMAGE FILE (EXE)"
TIP: UPX is great for SFX MODULES

Use less DELPHI libraries as possible, API is the way to go!
but since this is a intro tutorial we MUST make it simple.

Make a procedure to read and process the data,
in this case we can use it to READ, UNCOMPRESSED, WRITE the files.

FINAL STEP CODING!

How to read and write a Dynamic String

function ReadDString(Stream: TStream): string;
var

  LEN: Byte; // Length Byte

begin

  Stream.Read(LEN, 1); // Read Length (255 Max)
  SetLength(Result, LEN); // Set Delphi D-String Array Size
  Stream.Read(PChar(Result)^, LEN); // Read Data to D-String Array

end;

procedure WriteDString(Stream: TStream; const Str: string);
var

  LEN: Byte; // Length Byte

begin

  LEN := Length(Str); // Set Length Byte what Str[0] used to be
  Stream.Write(LEN, 1); // Write Length Byte (255 Max)
  Stream.Write(PChar(Str)^, LEN); // Write D-String Array Data

end;

COMMENT

Why the "PChar(Str)^" why not just use Str?
Well since the Str is a Delphi Dynamic-String Array (array of char), it stores its pointer, so if you attempt to use Str you are actually writing its pointer NOT the data, so what i do is I get the Pointer of the first Character on the array "PChar(Str)" then I release it as a VARIABLE or CONSTANT, as if it where a normal variable!.

Download

Download project files for both the SFX Maker and the SFX it self
it is your job to try to understand the code, (i re-use variables allot), the main idea is this:

CREATE NEW SFX FILE
WRITE SFX MODULE (MODULE EXE)
WRITE SFX DATA

SFX DATA
WRITE ID ('SF')
WRITE FILE COUNT
WRITE FILE
WRITE LENGTH

WRITE FILE
WRITE FILENAME
WRITE COMPRESSED LENGTH
WRITE UNCOMPRESSED LENGTH
WRITE COMPRESSED FILE DATA


Component Download: http://www.taxisairport.com/dhype/downloads/sfxtutorial.rar

Dropping Tables from MS SQL Server with Delphi

Problem/Question/Abstract:

How do I go about dropping Tables from MS SQL Server with Delphi

Answer:

I've been doing extensive work with Client/Server Delphi and MS SQL Server as my back-end database. The operational model that I use for my Client/Server is that the client application acts only as local interface, and that all queries and calculations - even temporary files - are performed or created on the server. Now this presents a couple of problems in that garbage cleanup isn't quite as easy as it is when using local tables as temporary files.

For instance, a lot of my programs create temporary files that I either reference later in the program or that I use as temporary storage for outer joins. Once I'm done with them, I need to delete them. With local tables, it's a snap. Just get a list of the tables, and with a little bit of code that uses some Windows API calls, delete them. Not so easy with SQL Server tables. The reason why is that you have to go through the BDE to accomplish the task - something that's not necessarily very intuitive. Luckily, however, it doesn't involve low-level BDE API calls.

Below is a procedure listing that drops tables from any SQL Server database. After the listing I'll discuss particulars...

Parameter Descriptions

//var Ses : TSession;         //A valid, open session
//DBName : String;            //Name of the SQL Server DB
//ArTables : array of String; //An array of table names
//StatMsg : TStatusMsg);      //A status message callback
                             //procedure

TStatusMsg is a procedural type used as a callback procedure

type
  TStatusMsg = procedure(Msg: string);

procedure DropMSSQLTempTables(var Ses: TSession;
  DBName: string;
  ArTables: array of string;
  StatMsg: TStatusMsg);
var
  N: Integer;
  qry: TQuery;
  lst: TStringList;
begin
  lst := TStringList.Create;

  Ses.GetTableNames(DBName, '', False, False, lst);

  try
    for N := Low(arTables) to High(arTables) do
      if (lst.IndexOf(ArTables[N]) > 0) then
      begin
        StatMsg('Removing ' + arTables[N] +
          ' from client database');
        qry := TQuery.Create(nil);
        with qry do
        begin
          Active := False;
          SessionName := Ses.SessionName;
          DatabaseName := DBName;
          SQL.Add('DROP TABLE ' + arTables[N]);
          try
            ExecSQL;
          finally
            Free;
            qry := nil;
          end;
        end;
      end;
  finally
    lst.Free;
  end; { try/finally }
end;

The pseudo-code for this is pretty easy.

Get a listing of all tables in the SQL Server database passed to the procedure.
Get a table name from the table name array.
If a passed table name happens to be in the list of table retrieved from the database, DROP it.
Repeat 2. and 3. until all table names have been exhausted.

The reason why I do the comparison in step 3 is because if you issue a DROP query against a non-existent table, SQL Server will issue an exception. This methodology avoids that issue entirely.

Below is a detailed description of the parameters.

Parameter Name
Type
Description
Ses
var TSession
This is a session instance variable that you pass by reference into the procedure. Note: It MUST be instantiated prior to use. The procedure does not create an instance. It assumes it already exists. This is especially necessary when using this procedure within a thread. But if you're not creating a multi- threaded application, then you can use the default Session variable.
DBName
String
Name of the MS SQL Server client database
ArTables
Array of String
This is an open array of string that you can pass into the procedure. This means that you can pass any size array and the procedure will handle it. For instance, in the Primary table maker program, I define an array as follows:

arPat[0] := 'dbo.Temp0';
arPat[1] := 'dbo.Temp1';
arPat[2] := 'dbo.Temp2';
arPat[3] := 'dbo.Temp3';
arPat[4] := 'dbo.Temp4';
arPat[5] := 'dbo.Temp5';
arPat[6] := 'dbo.PatList';
arPat[7] := 'dbo.PatientList';
arPat[8] := 'dbo.EpiList';
arPat[9] := 'dbo.' + FDisease + 'CrossTbl_' + FQtrYr;
arPat[10] := 'dbo.' + FDisease + 'Primary_' + FQtrYr;

and pass it into the procedure.
StatMsg
TStatusMsg
This is a procedural type of : procedure(Msg : String). You can&#8217;t use a class method for this procedure; instead, you declare a regular procedure that references a regular procedure. For example, I declare an interface-level procedure called StatMsg that references a thread instance variable and a method as follows:

procedure StatMsg(Msg: string);
begin
  thr.FStatMsg := Msg;
  thr.Synchronize(thr.UpdateStatus);
end;

The trick here is that "thr" is the instance variable used to instantiate my thread class. The instance variable resides in the main form of my application. This means that it too must be declared as an interface variable.


I'm usually averse to using global variables and procedures. It's against structured programming conventions. However, what this procedure buys me is the ability to place it in a centralized library and utilize it in all my programs.

Before you use this, please make sure you review the table above. You need to declare a type of TStatusMsg prior to declaring the procedure. If you don't, you'll get a compilation error.

Query result into a string list

Problem/Question/Abstract:

Have you ever needed to load the result of a query into a string ?
Here's how to load the result of a query into a string list.

Answer:

Have you ever needed to load the result of a query into a string ?
Here's how to load the result of a query into a string list.

Let's say we have a table named 'Contact' which holds the fields 'first_name', 'last_name', 'phone', 'salutation'.
Let's say you just need to load these result once into your application, you can either keep a permanent connection to access the data or you can load it once, or whenever necessary, into memory and then free the connection.

Let's choose to load the data into memory, otherwise this article would not have any reason for existing! :)

What I show here is a very simple "trick", using a TQuery and TStringList, I show how to load each record from the TQuery's result set into a string of the TStringList.
So, let's say we need the last name and from the contact table.
You know a simple

SELECT last_name FROM contact

will do the job, all you need to do is to loop the result and add it to the string list.
But, how about if we need the salutation, last name and contact fields all at once in only one string ?  Well, the solution is also simple, for record a loop through the requeted attributes is also done!

Before I show the code to do this simple task, I'll explain how it will be achieved:

1. Receiver the database name, table name, attributes, field separator and a string list.
2. Split the attributes string into a list of strings
3. Run the database query
4. Loop in the result set
4.1. For each result set, loop the attributes
4.2. Add all attributes from the result set into the string list

And now, a possible implementation of this:

You will require these units: dbtables, stdctrls and classes.

// - One Attribute for each array position, sequentially -

procedure FillRecordSL(DBName, T, A, C, FS: string; var SL: TStringList);
var
  Attrs: TStringList;
  F: ShortInt;

  // - Split Attributes -
  procedure SplitAttributes(A: string; var Attrs: TStringList);
  var
    X: Integer;
    S: string;
  begin
    if not (Assigned(Attrs)) then
      Attrs := TStringList.Create;

    S := '';
    X := 1;
    while (X <= Length(A)) do
    begin
      if (A[X] = ',') then
      begin
        Attrs.Add(Trim(S));
        S := '';
      end
      else
        S := S + A[X];

      Inc(X);
    end;
    Attrs.Add(Trim(S + A[X]));

  end;

begin
  Attrs := TStringList.Create;
  SlitAttributes(A, Attrs);

  with TQuery.Create(nil) do
  begin
    DatabaseName := DBName;
    FilterOptions := [foCaseInsensitive];
    SQL.Add('SELECT ' + A + ' FROM ' + T);
    if Length(C) > 0 then
      SQL.Add('WHERE ' + C);
    Prepare;
    while not (Prepared) do
      ;
    Open;
    First;
    try
      while not (EOF) do
      begin
        AuxStr := '';
        for F := 0 to Attrs.Count - 1 do
          AuxStr := AuxStr + FS + Fields[F].AsString;
        Delete(AuxStr, 1, Length(FS));
        SL.Add(AuxStr);
        Next;
      end;
      Close;
    finally
      Free;
    end;
  end;

  Attrs.Free;
end;

Let's assume that your database name is MyDB and you already have a SL variable of type TStringList.
Now some examples, to access the salutation, last name and contact, all you have to do is to call the procedure this way:

FillRecordSL('MyDB', 'contact', 'salutation, last_name, contact', '', ' ', SL);

Now the SL varibale helds someting like this:

SL[0] = 'Mr. Kong 098765432'
SL[1] = 'Mrs. Chita 098765431'
SL[2] = 'Miss Tarzan 123456789'

FillRecordSL('MyDB', 'contact', 'salutation, first_name, last_name, contact',
  'salutation = ''Mrs.''', '; ', SL);

Now the SL varibale helds someting like this:

SL[1] = 'Mrs.; Mila; Chita; 098765431'

FillRecordSL('MyDB', 'contact', 'last_name, first_name, contact', '', ', ', SL);

Now the SL varibale helds someting like this:

SL[0] = 'Kong, King, 098765432'
SL[1] = 'Chita, Mila, 098765431'
SL[2] = 'Tarzan, Jane, 123456789'

You can expand this procedure to increase its capabilities, what I ment to show here was just a starting point.
Hope it helps you.

Data Encryption - How It Works...

Problem/Question/Abstract:

How does Data Encryption Work

Answer:

Encryptions Early Predecessors
&#8220;Since man was created, war began&#8221;

A little known fact is that even since the days of the Greeks- Encryption was a priority, people trying to stay one step ahead of there rivals, Text Messages where good as gold and a great way to communicate, but in war it is an indispensable tool but not so secure.

the &#8220;Cesar&#8221; cipher is a good example, Cesar used a very simple but effective method for protecting his messages that where sent to his army.

Normal

ABCDEFGHIJKLMNOPQRSTUVWXYZ

Coded

EFGHIJKLMNOPQRSTUVWXYZABCD

The letters where shifted left 4 spaces

A message might look like this:

MCFVNH

Meaning this:

HYBRID

Even in the early 1900&#8217;s the USA used a similar form to communicate with its troops, a BOOK a Paragraph was used as the CODEC, starting by logging the letters so they wouldn&#8217;t repeat them self&#8217;s:

For example:

&#8220;IT WAS THE BEST OF TIMES, IT WAS THE WORST OF TIMES&#8221;

The letters get logged starting from the beginning.

&#8220;IT &#8221; = &#8220;AB&#8221;

&#8220;WAS&#8221; = &#8220;CDE&#8221;

&#8220;THE&#8221; = &#8220;BFG&#8221;

Notice that the &#8216;T&#8217; got repeated so its value is still &#8216;B&#8217; and so on.

How Data Gets Encrypted
&#8220;The virtual age&#8221;

Now encryption changed thanks to computers, since the birth of the all mighty BYTE one single change and you have a whole new number.

Now a BYTE is made of 8 BITS

8-7-6-5-4-3-2-1

each BIT has a value (the double of the last) assigned to it

128-64-32-16-8-4-2-1

The max value of a BYTE is 255 (the sum of all the BITS)

Logical operators are used to modify the bits in a byte or more

OR

(Add)


The OR operator is used to set the BITS in a value. example:

If you decided to OR the value: 4

(00000100)

with the value: 2

(00000010)

the result will be the number 6

(00000110)

since the sum of the 3rd BIT and the 2nd BIT gives us 6


AND

(Extract)


The AND operator is used to check if the BITS in a VALUE are set.

If you decided to AND the value: 4

(00000100)

with the value: 8

(00001000)

the result will be the number 0

(00000000)

Since the value 8 (the 4th BIT) is not set

If the BIT where set

the result will be the number 8 (AGAIN)

(00001000)


XOR

(Toggle)


The all mighty XOR operator is used to toggle the BITS in a VALUE (1=0 and 0=1)

If you decided to XOR the value: 255

(11111111)

with the value: 4

(00000100)

the result will be the number 251

(11111011)

The all the BITS in the value where toggled now if we repeat the process with the last result (251)

(11111011)

with the value: 4

(00000100)

the result will be the number 255 again

(11111111)

Now you see why the XOR is used so much, since you need not remember the original value only the KEY or in this case the 4

All values that you XOR are changed BIT by BIT so if you use a VALUE (KEY) lower than the DATA you will only change the first bytes in that value

For example an Integer (123456789) uses 4-Bytes and the value 90210 uses 2-Bytes, so if you XOR 123456789 with 90210 the changes will only affect the first 2-Bytes.

Random numbers are great but you must find a better way to generate them, since most Compilers have there own way of generating them (using the TIME is the most common) the DATA may get lost or corrupted easily.

Now the most popular is the PGP type of Encryption that I will explain later,

But first we need to explain how to generate a GOOD and SAFE key

Data Types
&#8220;One spoon or two&#8221;

The key as well as the data gets split in different data sets for example you can toggle 1 byte / 2 bytes (word) / 4 bytes (W32 Integer) / 8 bytes (int64). This way you can toggle more data and take less time. But you must always remember where your algorithm is going to be used; some systems can&#8217;t handle a 64bit Integer (some handhelds, etc). And a must is to always pair up the data size with the key size, you don&#8217;t want to encrypt text and leave readable hole.

Cipher Logic
&#8220;Lose your self in the numbers&#8221;

A KEY is always important, the time for the magical &#8220;SWORDFISH&#8221; password has ended; now you need not remember a single word but the less similar to a WORD the better.

A good KEY is longer than 128-BITS (32 BYTES/CHARS)

It is always recommended to use the full 8-BITS in each BYTE rather than just the ones used for the &#8216;Letter Characters&#8217;, the less repetitive the better.

Yes in the case of some PGP like keys they can still use the small passwords, that is because the DATA is not encrypted with the key it self instead it is Encrypted with a Session key, that key is created via any temporary data on the machine, memory, mouse position, windows version, etc.

And then the Session key is encrypted with the user key. In the case of PGP the Session key is encrypted with the Public Key.

Predetermined Keys
&#8220;Does size REALLY matter&#8221;

One of the best ways to encrypt data is to use predetermined

Keys for example the well known BLOWFISH and TWOFISH use this technique as well as many others. The USER KEY gets split in multiple sections that are used to toggle the Predetermined Keys, which in turn toggle the data in various passes.

Time and Time Again
&#8220;Shake well&#8221;

The best technique is to toggle the same part more than once, in most cases 16 times is enough. Another use for this is to shred data like most programs you can scramble the data so much that it will become unrecognizable to any data recovery program, others just zero-out the bytes, but in most cases the data on a disk can still be recovered if it was just zeroed, the Hard Disk leaves a small trace or residue of the last value there (un-format for example).

Cover your tracks
&#8220;Crouching Tiger, Hidden Footprint&#8221;

Now it is best to learn assembler for this but any language will do, since time is of the essence, I use assembler, to cover your tracks it is best to add fake procedures or moves like shifting and switching variables, in the event that a cracker might want to break the encryption. Now a days it is useless since the world revolves around keys, the cracker can have the code but not the data.

Ensure that every node in a TTreeView is unique (2)

Problem/Question/Abstract:

I have a 3 level TTreeview. The nodes in levels 2 and 3 must have unique captions (text). Items will be added in a loop so I can't check the "Selected" text against the data to be entered. However, I will know which node where data entry will begin. If adding child nodes to a node on level 2 for example, I assume I need to loop through the children of the particular parent node of the node on level 2 and check the text property? Does this make sense?

Answer:

Yes. Use the edited nodes Parent.GetfirstChild to get a reference to the first child node of that parent. Then use that nodes GetNextSibling to find the next node on that level to examine, and so on. Untested:

function IsDuplicateNode(aNode: TTreenode): Boolean;
var
  walker: TTreenode;
begin
  Assert(Assigned(aNode), 'Need a node to examine!');
  if Assigned(aNode.Parent) then
    walker := aNode.Parent.GetFirstChild
  else
    walker := TTreeview(aNode.Treeview).Items[0];
  Result := False;
  while Assigned(walker) do
  begin
    if (walker <> aNode) and AnsiSametext(walker.Text, aNode.Text) then
    begin
      Result := true;
      Break;
    end;
    walker := walker.GetNextSibling;
  end;
end;

How to get the PopupPoint of a TPopupMenu

Problem/Question/Abstract:

I have a popup menu assigned to a TListView. I'm trying to get the ListItem where the right click occured. I can not get the coords where the popup click happened due to the fact that PopupMenu.PopupPoint is protected.

Answer:

type
  TCrackPopupMenu = class(TPopupMenu)
  end;

procedure TForm1.PopupMenu1Popup(Sender: TObject);
var
  pt: TPoint;
begin
  pt := TCrackPopupMenu(PopupMenu1).PopupPoint;
  Label1.Caption := Format('Popped up at: X = %d, Y = %d', [pt.x, pt.y]);
end;

By the way, PopupPoint returns screen coordinates.

Registering a file type on Windows 9x/2000/NT

Problem/Question/Abstract:

Registering a file type on Windows 9x/2000/NT

Answer:

This is typically the task of an installer like Wise or InstallShield, buy you may be in a situation where you have to do it manually.

Registering an application to handle a certain file type means putting a few entries in the registry. Just use the function from the code below.

program RegisterExt;

uses
  Registry;

procedure RegisterExtension(
  const sAppName: string;
  const sAppPath: string;
  const sIconName: string;
  const sExtension: string);
var
  Reg: TRegistry;
begin { RegisterExtension }
  Reg := TRegistry.Create;
  with Reg do
  begin
    RootKey := HKEY_CLASSES_ROOT;
    OpenKey('.ext', True);
    WriteString('', sAppName);
    CloseKey;
    OpenKey(sAppName, True);
    WriteString('', sAppName);
    OpenKey('DefaultIcon', True);
    WriteString('', sIconName);
    CloseKey;
    OpenKey(sAppName + '\shell\open\command', True);
    WriteString('', sAppPath);
    CloseKey;
    Free;
  end { with Reg };
end; { RegisterExtension }

begin
  RegisterExtension('MyGreatApplication',
    'c:\program files\mystuff\myApp.exe',
    'c:\program files\mystuff\myApp.ico',
    '.shl');
end.

How to create a status bar that displays the system's time, date and keyboard status

Problem/Question/Abstract:

How to create a status bar that displays the system's time, date and keyboard status

Answer:

unit Status;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, Menus, Gauges;

type
  TStatus = class(TCustomPanel)
  private
    FDate: Boolean;
    FKeys: Boolean;
    FTime: Boolean;
    FResources: Boolean;
    DateTimePanel: TPanel;
    ResPanel: TPanel;
    ResGauge: TGauge;
    CapPanel: TPanel;
    NumPanel: TPanel;
    InsPanel: TPanel;
    HelpPanel: TPanel;
    UpdateWidth: Boolean;
    FTimer: TTimer;
    procedure SetDate(A: Boolean);
    procedure SetKeys(A: Boolean);
    procedure SetTime(A: Boolean);
    procedure SetResources(A: Boolean);
    procedure SetCaption(A: string);
    function GetCaption: string;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetupPanelFields(ThePanel: TPanel);
    procedure SetupPanel(ThePanel: TPanel; WidthMask: string);
    procedure UpdateStatusBar(Sender: TObject);
  published
    property ShowDate: Boolean read FDate write SetDate default True;
    property ShowKeys: Boolean read FKeys write SetKeys default True;
    property ShowTime: Boolean read FTime write SetTime default True;
    property ShowResources: Boolean read FResources write SetResources default True;
    property BevelInner;
    property BevelOuter;
    property BevelWidth;
    property BorderStyle;
    property BorderWidth;
    property Caption: string read GetCaption write SetCaption;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ParentColor;
    property ParentCtl3d;
    property ParentFont;
    property ParentShowHint;
    property PopUpMenu;
    property ShowHint;
    property Visible;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Additional', [TStatus]);
end;

procedure TStatus.SetupPanelFields(ThePanel: TPanel);
begin
  with ThePanel do
  begin
    Alignment := taCenter;
    Caption := '';
    BevelInner := bvLowered;
    BevelOuter := bvNone;
    {Set all these true so they reflect the settings of the TStatus}
    ParentColor := True;
    ParentFont := True;
    ParentCtl3D := True;
  end;
end;

procedure TStatus.SetupPanel(ThePanel: TPanel; WidthMask: string);
begin
  SetupPanelFields(ThePanel);
  with ThePanel do
  begin
    Width := Canvas.TextWidth(WidthMask);
    Align := alRight;
  end;
end;

constructor TStatus.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Parent := TWinControl(AOwner);
  FTime := True;
  FDate := True;
  FKeys := True;
  FResources := True;
  {Force the status bar to be aligned bottom}
  Align := alBottom;
  Height := 19;
  BevelInner := bvNone;
  BevelOuter := bvRaised;
  {When UpdateWidth is set TRUE, status bar will recalculate panel widths once}
  UpdateWidth := True;
  Locked := True;
  TabOrder := 0;
  ;
  TabStop := False;
  Font.Name := 'Arial';
  Font.Size := 8;
  {Create the panel that will hold the date and time}
  DateTimePanel := TPanel.Create(Self);
  DateTimePanel.Parent := Self;
  SetupPanel(DateTimePanel, '  00/00/00 00:00:00 am  ');
  {Create the panel that will hold the resources graph}
  ResPanel := TPanel.Create(Self);
  ResPanel.Parent := Self;
  SetupPanel(ResPanel, '                    ');
  {Create the 2 Gauges that will reside within the Resource Panel}
  ResGauge := TGauge.Create(Self);
  ResGauge.Parent := ResPanel;
  ResGauge.Align := alClient;
  ResGauge.ParentFont := True;
  ResGauge.BackColor := Color;
  ResGauge.ForeColor := clLime;
  ResGauge.BorderStyle := bsNone;
  {Create the panel that will hold the CapsLock state}
  CapPanel := TPanel.Create(Self);
  CapPanel.Parent := Self;
  SetupPanel(CapPanel, '  Cap  ');
  {Create the panel that will hold the NumLock state}
  NumPanel := TPanel.Create(Self);
  NumPanel.Parent := Self;
  SetupPanel(NumPanel, '  Num  ');
  {Create the panel that will hold the Insert/Overwrite state}
  InsPanel := TPanel.Create(Self);
  InsPanel.Parent := Self;
  SetupPanel(InsPanel, '  Ins  ');
  {Create the panel that will hold the status text}
  HelpPanel := TPanel.Create(Self);
  HelpPanel.Parent := Self;
  SetupPanelFields(HelpPanel);
  {Have the help panel consume all remaining space}
  HelpPanel.Align := alClient;
  HelpPanel.Alignment := taLeftJustify;
  {This is the timer that will update the status bar at regular intervals}
  FTimer := TTimer.Create(Self);
  if FTimer <> nil then
  begin
    FTimer.OnTimer := UpdateStatusBar;
    {Updates will occur twice a second}
    FTimer.Interval := 500;
    FTimer.Enabled := True;
  end;
end;

destructor TStatus.Destroy;
begin
  FTimer.Free;
  HelpPanel.Free;
  InsPanel.Free;
  NumPanel.Free;
  CapPanel.Free;
  ResGauge.Free;
  ResPanel.Free;
  DateTimePanel.Free;
  inherited Destroy;
end;

procedure TStatus.SetDate(A: Boolean);
begin
  FDate := A;
  UpdateWidth := True;
end;

procedure TStatus.SetKeys(A: Boolean);
begin
  FKeys := A;
  UpdateWidth := True;
end;

procedure TStatus.SetTime(A: Boolean);
begin
  FTime := A;
  UpdateWidth := True;
end;

procedure TStatus.SetResources(A: Boolean);
begin
  FResources := A;
  UpdateWidth := True;
end;

{When we set or get the TStatus caption, it is affecting the HelpPanel caption instead}

procedure TStatus.SetCaption(A: string);
begin
  HelpPanel.Caption := ' ' + A;
end;

function TStatus.GetCaption: string;
begin
  GetCaption := HelpPanel.Caption;
end;

{This procedure sets the captions appropriately}

procedure TStatus.UpdateStatusBar(Sender: TObject);
begin
  if ShowDate and ShowTime then
    DateTimePanel.Caption := DateTimeToStr(Now)
  else if ShowDate and not ShowTime then
    DateTimePanel.Caption := DateToStr(Date)
  else if not ShowDate and ShowTime then
    DateTimePanel.Caption := TimeToStr(Time)
  else
    DateTimePanel.Caption := '';
  if UpdateWidth then
    with DateTimePanel do
      if ShowDate or ShowTime then
        Width := Canvas.TextWidth('  ' + Caption + '  ')
      else
        Width := 0;
  if ShowResources then
  begin
    ResGauge.Progress := GetFreeSystemResources(GFSR_SYSTEMRESOURCES);
    if ResGauge.Progress < 20 then
      ResGauge.ForeColor := clRed
    else
      ResGauge.ForeColor := clLime;
  end;
  if UpdateWidth then
    if ShowResources then
      ResPanel.Width := Canvas.TextWidth('                    ')
    else
      ResPanel.Width := 0;
  if ShowKeys then
  begin
    if (GetKeyState(vk_NumLock) and $01) <> 0 then
      NumPanel.Caption := '  Num  '
    else
      NumPanel.Caption := '';
    if (GetKeyState(vk_Capital) and $01) <> 0 then
      CapPanel.Caption := '  Cap  '
    else
      CapPanel.Caption := '';
    if (GetKeyState(vk_Insert) and $01) <> 0 then
      InsPanel.Caption := '  Ins  '
    else
      InsPanel.Caption := '';
  end;
  if UpdateWidth then
    if ShowKeys then
    begin
      NumPanel.Width := Canvas.TextWidth(' Num ');
      InsPanel.Width := Canvas.TextWidth(' Ins ');
      CapPanel.Width := Canvas.TextWidth(' Cap ');
    end
    else
    begin
      NumPanel.Width := 0;
      InsPanel.Width := 0;
      CapPanel.Width := 0;
    end;
  UpdateWidth := False;
end;

{This allows font changes to be detected so the panels will be adjusted}

procedure TStatus.CMFontChanged(var Message: TMessage);
begin
  inherited;
  UpdateWidth := True;
end;

end.

interface

implementation

end.

How to transfer data between a TDBGrid and the clipboard

Problem/Question/Abstract:

How to transfer data between a TDBGrid and the clipboard

Answer:

The grid must be in Edit or Insert mode for the paste to work.

Add 'ClipBrd' to the Uses list
Add 'gk: Word;' to your global variables
Add the following procedures to Implementation, substituting names as required

procedure TMyForm.MyDBGridKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
{OnKeyDown event handler for your DBGrid}
const
  vk_c = $43;
  vk_v = $56;
begin
  if Shift = [ssCtrl] then
  begin
    if key = vk_v then
      Shift := [ssShift];
    if (key = vk_c) or (key = vk_v) then
    begin
      gk := Key;
      key := 0;
    end;
  end;
end;

procedure TMyForm.MyDBGridKeyPress(Sender: TObject; var Key: Char);
{OnKeyPress event handler for your DBGrid}
const
  vk_c = $43;
  vk_v = $56;
begin
  if gk <> 0 then
  begin
    Key := chr(0);
    if gk = vk_c then
      ClipBoard.AsText := MyTable.Fields[MyDBGrid.SelectedIndex].AsString;
    if gk = vk_v then
    begin
      if (MyTable.State = dsEdit) or (MyTable.State = dsInsert) then
        MyTable.Fields[MyDBGrid.SelectedIndex].AsString := ClipBoard.AsText
      else
        MessageBeep(0);
    end;
    gk := 0;
  end;
end;

How to avoid palette problems with a TImage / TBitmap

Problem/Question/Abstract:

I have written an D 4.0 application that opens a jpeg, paints it to a TImage canvas, alters the TImage, and then saves the TImage back to a new jpeg file. The application works great on the development machine, however when installing it on another machine (using IS 2) it generates incorrect pictures. The jpeg are displayed correctly. When I draw to the canvas the picture is also correct. However when the image is saved to a new file the original portion of the image looks like garbage, however the portion that was added is correct. I can't find any dependencies listed that need to get distributed. Did I miss something?

Answer:

First of all, the canvas of a TImage is not meant to be written on by anyone else but the image the TImage contains. Also, this sounds like a palette problem. If so, your development machine probably doesn't use palettes (16,24 or 32 bit color depth) and your test machine uses palettes (8 bit color depth). Try something like this instead (not tested):

procedure DrawBitmapOnJPEG(JPEG: TJPEGImage; BMP: TBitmap);
var
  Bitmap: TBitmap;
begin
  Bitmap := TBitmap.Create;
  try
    { Convert JPEG to bitmap (DIB hopefully) }
    Bitmap.Assign(JPEG);
    { Avoid palette problems }
    Bitmap.PixelFormat := pf24bit;
    { Draw BMP on JPEG }
    Bitmap.Canvas.Draw(0, 0, BMP);
    { Convert bitmap back to JPEG }
    JPEG.Assign(Bitmap);
  finally
    Bitmap.Free;
  end;
end;

Invisible title - hide the program's title bar

Problem/Question/Abstract:

Invisible title - hide the program's title bar

Answer:

This is a quick way to hide your program's title bar:

procedure TForm1.FormCreate(Sender: TObject);
var
  OldStyle: longint;
begin
  OldStyle := GetWindowLong(Handle, GWL_STYLE);
  SetWindowLong(Handle, GWL_STYLE, OldStyle and not WS_CAPTION);
  ClientHeight := Height;
end;

Copy the current record of a dataset

Problem/Question/Abstract:

Copy the current record of a dataset

Answer:

I found this routine which copies the current record of the currently selected record. This is useful e.g. to keep a temporary record for display in a form.

{************************************************
// procedure AppendCurrent
//
// Will append an exact copy of the current
// record of the dataset that is passed into
// the procedure and will return the dataset
// in edit state with the record pointer on
// the currently appended record.
************************************************}

procedure AppendCurrent(Dataset: Tdataset);
var
  aField: Variant;
  i: Integer;
begin
  // Create a variant Array
  aField := VarArrayCreate(
    [0, DataSet.Fieldcount - 1],
    VarVariant);
  // read values into the array
  for i := 0 to (DataSet.Fieldcount - 1) do
  begin
    aField[i] := DataSet.fields[i].Value;
  end;
  DataSet.Append;
  // Put array values into new the record
  for i := 0 to (DataSet.Fieldcount - 1) do
  begin
    DataSet.fields[i].Value := aField[i];
  end;
end;

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.

How to position maximized forms

Problem/Question/Abstract:

I am working on a project that must keep the 640x480 pixel screen size. I would like to make it MDI. I've designed a small form with a menu and a tool bar (like Delphi's IDE). The user will click on this IDE like form and a new window will be display. Here is the problem: When the user maximizes this window, it goes to (0,0) thus hiding IDE form.

Answer:

Handle WM_GETMINMAXINFO, that allows you to specify position and size of the maximized window:


private
{ Private declarations }

procedure WMGetMinMaxInfo(var msg: TWMGetMinmaxInfo); message WM_GETMINMAXINFO;

procedure TForm2.WMGetMinMaxInfo(var msg: TWMGetMinmaxInfo);
var
  r: TRect;
begin
  inherited;
  SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0);
  r.top := Application.Mainform.Height + Application.Mainform.Top;
  with msg.MinMaxInfo^.ptMaxSize do
  begin
    x := r.right - r.left;
    y := r.bottom - r.top;
  end;
  msg.Minmaxinfo^.ptmaxPosition := r.TopLeft;
end;


This code will make the form use the full available screen area (minus taskbar) under the main form, you will need to modify it to limit it to a maximum of 640x480.

Export ALL tables from MS jet to CSV via ADO

Problem/Question/Abstract:

How to export All Tables in a Microsoft Jet DB to a CSV file

Answer:

procedure TMainForm.SaveAllTablesToCSV(DBFileName: string);
var
  InfoStr,
    FileName,
    RecString,
    WorkingDirectory: string;
  OutFileList,
    TableNameList: TStringList;
  TableNum,
    FieldNum: integer;
  VT: TVarType;
begin
  ADOTable1.Active := false;
  WorkingDirectory := ExtractFileDir(DBFileName);
  TableNameList := TStringList.Create;
  OutFileList := TStringList.Create;
  InfoStr := 'The following files were created' + #13#13;

  ADOConnection1.GetTableNames(TableNameList, false);
  for TableNum := 0 to TableNameList.Count - 1 do
  begin
    FileName := WorkingDirectory + '\' +
      TableNameList.Strings[TableNum] + '.CSV';
    Caption := 'Saving "' + ExtractFileName(FileName) + '"';
    ADOTable1.TableName := TableNameList.Strings[TableNum];
    ADOTable1.Active := true;
    OutFileList.Clear;

    ADOTable1.First;
    while not ADOTable1.Eof do
    begin

      RecString := '';
      for FieldNum := 0 to ADOTable1.FieldCount - 1 do
      begin
        VT := VarType(ADOTable1.Fields[FieldNum].Value);
        case VT of
          // just write the field if not a string
          vtInteger, vtExtended, vtCurrency, vtInt64:
            RecString := RecString + ADOTable1.Fields[FieldNum].AsString
        else
          // it IS a string so put quotes around it
          RecString := RecString + '"' +
            ADOTable1.Fields[FieldNum].AsString + '"';
        end; { case }

        // if not the last field then use a field separator
        if FieldNum < (ADOTable1.FieldCount - 1) then
          RecString := RecString + ',';
      end; { for FieldNum }
      OutFileList.Add(RecString);

      ADOTable1.Next;
    end; { while }

    OutFileList.SaveToFile(FileName);
    InfoStr := InfoStr + FileName + #13;
    ADOTable1.Active := false;

  end; { for  TableNum }
  TableNameList.Free;
  OutFileList.Free;
  Caption := 'Done';
  ShowMessage(InfoStr);
end;

procedure TMainForm.Button1Click(Sender: TObject);
const
  ConnStrA = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=';
  ConnStrC = ';Persist Security Info=False';
  ProvStr = 'Microsoft.Jet.OLEDB.4.0';
begin
  OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));
  if OpenDialog1.Execute then

  try
    ADOConnection1.ConnectionString :=
      ConnStrA + OpenDialog1.FileName + ConnStrC;
    ADOConnection1.Provider := ProvStr;
    ADOConnection1.Connected := true;
    ADOTable1.Connection := ADOConnection1;
    SaveAllTablesToCSV(OpenDialog1.FileName);
  except
    ShowMessage('Could not Connect to ' + #13 +
      '"' + OpenDialog1.FileName + '"');
    Close;
  end;

end;

How to check file and directory attributes

Problem/Question/Abstract:

How to check file and directory attributes

Answer:

The sample below works with the folder c:\temp .

procedure TForm1.Button1Click(Sender: TObject);
var
  Ergebnis: integer;
  Hidden: boolean;
  ReadOnly: boolean;
  Directory: boolean;
begin
  {Get the current file attributes and store them in a local bool variable.
  lbl_hidden, lbl_ReadOnly and lbl_Directory are TLabels}
  Ergebnis := fileGetAttr('C:\Temp');
  if Ergebnis and faHidden <> 0 then
  begin
    hidden := True;
    lbl_hidden.Caption := 'Hidden File';
  end
  else
  begin
    Hidden := False;
    lbl_hidden.Caption := 'Not a hidden file';
  end;
  if Ergebnis and faDirectory <> 0 then
  begin
    Directory := True;
    lbl_Directory.Caption := 'We have a directory';
  end
  else
  begin
    Directory := False;
    lbl_Directory.Caption := 'There is no directory';
  end;
  if Ergebnis and faReadOnly <> 0 then
  begin
    ReadOnly := True;
    lbl_ReadOnly.Caption := 'File is write-protected';
  end
  else
  begin
    ReadOnly := False;
    lbl_ReadOnly.Caption := 'File is not write-protected';
  end;
  refresh;
  sleep(4000);
  {Set attributes}
  FileSetAttr('C:\Temp', faHidden or faReadOnly or faDirectory);
  {Check set attributes and reset Ergebnis variable to original status}
  Ergebnis := FileGetAttr('C:\Temp');
  if Ergebnis and faHidden <> 0 then
  begin
    lbl_hidden.Caption := 'Attribute Hidden is set'; {TLabel}
    if not hidden then
      Ergebnis := Ergebnis xor fahidden;
  end
  else
    lbl_hidden.Caption := 'Attribute Hidden is not set';
  if Ergebnis and faReadOnly <> 0 then
  begin
    lbl_ReadOnly.Caption := 'Attribute Read Only is set';
    if not ReadOnly then
      Ergebnis := Ergebnis xor faReadOnly;
  end
  else
    lbl_ReadOnly.Caption := 'Attribute ReadOnly not set';
  if Ergebnis and faDirectory <> 0 then
  begin
    lbl_Directory.Caption := 'Directory set';
    if not Directory then
      Ergebnis := Ergebnis xor faDirectory;
  end
  else
    lbl_Directory.Caption := 'Directory not set';
  refresh;
  sleep(4000);
  {Reset attributes}
  FileSetAttr('C:\Temp', Ergebnis);
  {Check if attributes were reset correctly}
  Ergebnis := fileGetAttr('C:\Temp');
  if Ergebnis and faHidden <> 0 then
    lbl_hidden.Caption := 'Hidden file'
  else
    lbl_hidden.Caption := 'Not a hidden file';
  if Ergebnis and faDirectory <> 0 then
    lbl_Directory.Caption := 'We have a directory'
  else
    lbl_Directory.Caption := 'There is no directory';
  if Ergebnis and faReadOnly <> 0 then
    lbl_ReadOnly.Caption := 'File is write-protected'
  else
    lbl_ReadOnly.Caption := 'File is not write-protected';
  refresh;
end;