Threaded Brute Forcing Class

Problem/Question/Abstract:

How to create a simple brute forcing engine in a delphi class.

Answer:

{-----------------------------------------------------------------------------
Unit Name: classThreadBruteForce

Version: 1.0

Release Date: 21-Aug-2002

Compiler directives:

    TINY     - removes unnessecary error messages. test that output
               is not empty
    and
    OPTIMIZE (less information is available)

Purpose:

Description:

    A TThread which generates brute force combinations through the
    onDo event.

Notes:
    Charset contains the characters (these are sorted internally)
    onFinished event provided

    Not exactly fast but it does the job.

    Use it like this:-

    brute := TBruteThread.create(true);
    brute.charset := 'abcdefghijklmnopqrstuvwxyz';  // Chars to brute
    brute.numCharacters := 5;                       // Max chars
    brute.onDo := Form1ThreadOnDo;
    brute.resume;

Dependancies:

History:

        Copyright 2002 by Stewart Moss
        All rights reserved.
-----------------------------------------------------------------------------}

unit classBruteForce;

interface
uses classes, sysutils;

type
  TBruteThread = class(TThread)
  private
    FNumChars: Integer;
    FCharset: string;
    FonDo: TNotifyEvent;
    FonFinished: TNotifyEvent;

    CharCount: string;
    minChar: char;
    maxChar: char;
    imaxChar: integer;

    incBruteLock: boolean;
    // locks the incBrute function

    procedure init;
    function incBrute(posi: integer): integer;
    function StringBubbleSort(StrIn: string): string;

  public
{$IFNDEF OPTIMIZE}
    BruteCount: integer; // not recommended on large bruteforce,
    // use your own counter
{$ENDIF}
    BruteResult: string;

    procedure execute; override;

  published

    property onDo: TNotifyEvent read FonDo write FonDo;
    property onFinished: TNotifyEvent read FonFinished write FonFinished;

    property CharSet: string read FCharset write FCharset;
    property numCharacters: Integer read FNumChars write FNumChars;

  end;

implementation

{ TBruteThread }

procedure TBruteThread.execute;
var
  loop: integer;
  tmpstr: string;
begin
  if FNumChars <= 0 then
  begin
{$IFNDEF TINY}
    raise exception.create('invalid Numchars');
{$ENDIF}
{$IFDEF TINY}
    exit;
{$ENDIF}
  end;

  if FCharSet = '' then
  begin
{$IFNDEF TINY}
    raise exception.create('Charset is blank');
{$ENDIF}
{$IFDEF TINY}
    exit;
{$ENDIF}
  end;

  init;

  while (not terminated) do
  begin
    if incbrute(1) > FNumChars then
      break;

    loop := 0;
    bruteresult := '';
    while loop < FNumChars do
    begin
      inc(loop);
      if charcount[loop] = #0 then
        break;

      // speed optimization
      tmpstr := BruteResult;
      BruteResult := tmpstr + charcount[loop];
    end;
{$IFNDEF OPTIMIZE}
    inc(Brutecount);
{$ENDIF}

    if assigned(onDo) then
      onDo(Self);
  end;

  if assigned(onFinished) then
    onFinished(Self);
end;

{-----------------------------------------------------------------------------
  Procedure: incBrute
  Arguments: posi: integer
  Result:    integer

  Purpose: Recurive

  Description:
    This function brutes

      Copyright 2002 by Stewart Moss
      All rights reserved.
-----------------------------------------------------------------------------}

function TBruteThread.incBrute(posi: integer): integer;
var
  tmpint: integer;
  bufferpos: integer;
begin
  result := posi;
  bufferpos := pos(charcount[posi], FCharset);
  charcount[posi] := FCharset[bufferpos + 1];
  if FCharset[Bufferpos] = maxchar then
  begin
    charcount[posi] := minchar;
    tmpint := incBrute(posi + 1);
    if tmpint > FnumChars then
      result := tmpint;
  end;
end;

procedure TBruteThread.init;
var
  loop: integer;
begin
  FCharSet := StringBubbleSort(FCharset);
  minchar := FCharset[1];
  maxChar := FCharset[length(FCharset)];
  imaxchar := ord(MaxChar);
  charcount := '';
  for loop := 1 to FNumChars do
  begin
    charcount := charcount + #0;
  end;
{$IFNDEF OPTIMIZE}
  Brutecount := 0;
{$ENDIF}

end;

function TBruteThread.StringBubbleSort(StrIn: string): string;
var
  i, j: Integer;
  temp: Char;
  tmplen: integer;
begin
  tmplen := length(StrIn);
  for i := 1 to tmplen do
    for j := 1 to tmplen do
      if strIn[i] < StrIn[j] then
      begin
        temp := StrIn[i];
        StrIn[i] := StrIn[j];
        StrIn[j] := temp;
      end;
  Result := strIn;
end;

end.

How to format the cell borders of an Excel spreadsheet

Problem/Question/Abstract:

How to format the cell borders of an Excel spreadsheet

Answer:

Various ways of setting borders on a worksheet (WS):

{ ... }
var
  Rng: OleVariant;
  LeftEdge: Border;
{ ... }
WS.Range['A5', 'D5'].Borders.Item[xlEdgeTop].Weight := xlThick;
WS.Range['A5', 'D5'].Borders.Item[xlEdgeTop].Color := clYellow;
WS.Range['A5', 'D5'].Borders.Item[xlEdgeBottom].Linestyle := xlDouble;
WS.Range['A5', 'D5'].Borders.Item[xlEdgeBottom].Color := clYellow;
{ ... }

{ ... }
WS.Evaluate('B6, C6, D6, E6, F6').Borders.Item[xlEdgeLeft].Line
style := xlContinuous;
Rng := WS.Range['A1', 'A1'];
Rng.BorderAround(xlContinuous, xlThin, Color := clFuchsia);
LeftEdge := WS.Range['B2', 'B5'].Borders.Item[xlEdgeLeft];
LeftEdge.Linestyle := xlContinuous;
LeftEdge.Weight := 3;
LeftEdge.Color := clLime;
{ ... }

How to convert a TMemoryStream to an OLE variant and vice versa

Problem/Question/Abstract:

How to convert a TMemoryStream to an OLE variant and vice versa

Answer:

function MemoryStreamToOleVariant(Strm: TMemoryStream): OleVariant;
var
  Data: PByteArray;
begin
  Result := VarArrayCreate([0, Strm.Size - 1], varByte);
  Data := VarArrayLock(Result);
  try
    Strm.Position := 0;
    Strm.ReadBuffer(Data^, Strm.Size);
  finally
    VarArrayUnlock(Result);
  end;
end;

function OleVariantToMemoryStream(OV: OleVariant): TMemoryStream;
var
  Data: PByteArray;
  Size: integer;
begin
  Result := TMemoryStream.Create;
  try
    Size := VarArrayHighBound(OV, 1) - VarArrayLowBound
      (OV, 1) + 1;
    Data := VarArrayLock(OV);
    try
      Result.Position := 0;
      Result.WriteBuffer(Data^, Size);
    finally
      VarArrayUnlock(OV);
    end;
  except
    Result.Free;
    Result := nil;
  end;
end;

Print an HTML file using TWebBrowser

Problem/Question/Abstract:

How to print an HTML file using TWebBrowser

Answer:

Solve  1:

var
  I, O: OleVariant;
begin
  I := 0;
  WebBrowser1.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, I, O);
end;


Solve  2:

uses
  ActiveX

procedure PrintWebBrowser(WB: TWebBrowser);
var
  OleCommandTarget: IOleCommandTarget;
  Command: TOleCmd;
  Success: HResult;
begin
  if not Assigned(WB) then
    Exit;
  if not Assigned(WB.Document) then
    Exit;
  {Get reference to IOleCommandTarget}
  WB.Document.QueryInterface(IOleCommandTarget, OleCommandTarget);
  {Check if printing is currently possible}
  Command.cmdID := OLECMDID_PRINT;
  if OleCommandTarget.QueryStatus(nil, 1, @Command, nil) <> S_OK then
  begin
    {Something went wrong ...}
    Exit;
  end;
  if (Command.cmdf and OLECMDF_ENABLED) <> 0 then
  begin
    {Print}
    Success := OleCommandTarget.Exec(nil, OLECMDID_PRINT,
      OLECMDEXECOPT_DONTPROMPTUSER, EmptyParam, EmptyParam);
    case Success of
      S_OK: ; {Everything's fine}
      OLECMDERR_E_CANCELED: ShowMessage('Aborted by user');
    else
      ShowMessage('Error');
    end;
  end
  else
  begin
    {Printing not possible}
  end;
end;


Solve 3:

After navigating to a page with TWebBrowser you may want to print it. Well, the Microsoft Internet Explorer control can do that, show a print preview dialog, and even a page setup dialog.

var
  vaIn, vaOut: OleVariant; // Needed in all examples
{ ...}
// Printing without the Printer dialog
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER,
  vaIn, vaOut);
// Print with the Printer dialog
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER,
  vaIn, vaOut);
// Show the Print Preview dialog
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINTPREVIEW,
  OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
// Show the Page Setup dialog
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PAGESETUP, OLECMDEXECOPT_PROMPTUSER,
  vaIn, vaOut);

How to restrict the number of lines in a TMemo

Problem/Question/Abstract:

How can I get the following to happen with a memo: I would like to make it start purging lines from the top when a line is added at the bottom after I have 1024 lines.

Answer:

You can do the following (I am making the example for TCustomMemo to make this more general).

TLimitedMemo = class(TCustomMemo)
private
  fChanging: Boolean;
protected
  procedure Change; override;
public
  constructor Create(AOwner: TComponent); override;
end;

procedure TLimitedMemo.Change;
var
  i: Integer;
begin
  if fChanging then
    Exit;
  inherited;
  with Lines do
  try
    BeginUpdate;
    if Count > 5 then
    begin
      fChanging := True;
      for i := 0 to Count - 6 do
        Delete(0);
      fChanging := False;
    end;
  finally
    EndUpdate;
  end;
end;

constructor TLimitedMemo.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fChanging := False;
end;

In this case, this memo is allowing 5 lines(you can change it at your will).

How to change the position of the dropdown list of a TComboBox

Problem/Question/Abstract:

I have been able to find out how to increase the width of a combo box drop down so that it is wide enough to read the text. However if my combo box is positioned on the right hand side of a form when there is a particularly wide list the scroll bar and the list gets cut off on the edge of the screen. Is there a way to change the position the dropdown list?

Answer:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, stdctrls, Unit2;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    ComboBox1: TComboBox;
    procedure Button1Click(Sender: TObject);
    procedure ComboBox1DropDown(Sender: TObject);
  private
    { Private declarations }
    procedure WMUser(var msg: TMessage); message WM_USER;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to 20 do
    combobox1.Items.add(StringofChar(Chr(Ord('A') + i), Random(50) + 10));
  combobox1.Perform(CB_SETDROPPEDWIDTH, combobox1.Width * 2, 0)
end;

function EnumProc(wnd: HWND; var wndresult: HWND): BOOL; stdcall;
var
  classname: array[0..63] of Char;
begin
  Result := True;
  GetClassname(wnd, classname, sizeof(classname));
  if SameText(classname, 'ComboLBox') then
  begin
    Result := false;
    wndresult := wnd;
  end;
end;

procedure TForm1.ComboBox1DropDown(Sender: TObject);
var
  wnd: HWND;
  r: Trect;
  w: Integer;
begin
  wnd := 0;
  EnumThreadWindows(GetCurrentThreadID, @EnumProc, integer(@wnd));
  if wnd <> 0 then
  begin
    PostMessage(handle, WM_USER, wnd, 0);
  end
  else
    memo1.lines.add('Window not found');
end;

procedure TForm1.WMUser(var msg: TMessage);
var
  wnd: HWND;
  r: Trect;
  w: Integer;
begin
  wnd := msg.wparam;
  GetWindowRect(wnd, r);
  if r.Right > Screen.width then
  begin
    w := r.right - r.Left;
    MoveWindow(wnd, Screen.Width - w, r.top, w, r.Bottom - r.Top, true);
  end;
  memo1.lines.add(format('Wnd: %x, r: (%d,%d,%d,%d)', [wnd, r.left, r.top, r.right, r.bottom]));
end;

initialization
  randomize;
end.

TNCCanvas - write on a form's non-client area

Problem/Question/Abstract:

TNCCanvas - write on a form's non-client area

Answer:

This canvas gives you access to a form's none-client (NC) area and can be used to create a window with a personal frame style:


TNCCanvas = class(TCanvas)
private
  FDeviceContext: HDC;
  FWindowHandle: HWnd;
  function GetWindowRect: TRect;
protected
  procedure CreateHandle; override;
  procedure FreeHandle;
public
  constructor Create(aWindow: hWnd);
  destructor Destroy; override;
  property WindowRect: TRect read GetWindowRect;
end;

{ TNCCanvas - Object }

constructor TNCCanvas.Create(aWindow: hWnd);
begin
  inherited Create;
  FWindowHandle := aWindow;
end;

destructor TNCCanvas.Destroy;
begin
  FreeHandle;
  inherited Destroy;
end;

procedure TNCCanvas.CreateHandle;
begin
  if FWindowHandle = 0 then
    inherited CreateHandle
  else
  begin
    if FDeviceContext = 0 then
      FDeviceContext := GetWindowDC(FWindowHandle);
    Handle := FDeviceContext;
  end;
end;

procedure TNCCanvas.FreeHandle;
begin
  Handle := 0;
  if FDeviceContext <> 0 then
  begin
    ReleaseDC(FWindowHandle, FDeviceContext);
    FDeviceContext := 0;
  end;
end;

function TNCCanvas.GetWindowRect: TRect;
begin
  winProcs.GetWindowRect(FWindowHandle, Result);
  with Result do
  begin
    Right := Pred(Right - Left);
    Bottom := Pred(Bottom - Top);
    Left := 0;
    Top := 0;
  end;
end;

Extracting both the small and the large icon from a file

Problem/Question/Abstract:

Extracting both the small and the large icon from a file

Answer:

The Windows help files only document ExtractIcon which extracts the large icon from an EXE (DLL, etc.).

There is an undocumented function ExtractIconEx which retrieves both the small and the large icon as shown below.


procedure TForm1.FormPaint(Sender: TObject);
var
  LargeIcon: HIcon;
  SmallIcon: HIcon;
  IconCount: Integer;
  i: Integer;
  FileName: PChar;
begin
  // draw a stripe with all large icons contained in the file
  // and below of that a stripe with all small icons.

  FileName := 'C:\WinNT\RegEdit.exe';
  IconCount := ExtractIconEx(FileName, -1, LargeIcon, SmallIcon, 0);
  for i := 0 to Pred(IconCount) do
  begin
    ExtractIconEx(FileName, i, LargeIcon, SmallIcon, 1);
    DrawIcon(Canvas.Handle, 5 + i * 36, 5, LargeIcon);
    DrawIconEx(Canvas.Handle, 5 + i * 36, 50, SmallIcon,
      GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON), 0, 0, DI_NORMAL);
  end;
end;

Replacement for the C ternary conditional operator "?"

Problem/Question/Abstract:

Replacement for the C ternary conditional operator "?"

Answer:

Solve 1:

Original functions by Project JEDI Code Library (JCL).

It's better(read faster) than use Variant Type.

Ps.: Portuguese comments.

//*******************************************************
// Declara??o
// Substitui??o do operador "?" em C
//*******************************************************

function Iff(const Condition: Boolean; const TruePart, FalsePart: Boolean): Boolean;
  overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart: Byte): Byte;
  overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart: Cardinal):
  Cardinal; overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart: Char): Char;
  overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart: Extended):
  Extended; overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart: Integer):
  Integer; overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart:
  Pointer): Pointer; overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart:
  string): string; overload;
{$IFDEF SUPPORTS_INT64}
function Iff(const Condition: Boolean; const TruePart, FalsePart:
  Int64): Int64; overload;
{$ENDIF SUPPORTS_INT64}

//*******************************************************
// Fun?�es
// Substitui??o do operador "?" em C
//*******************************************************

function Iff(const Condition: Boolean; const TruePart, FalsePart:
  Boolean): Boolean; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;
//*******************************************************

function Iff(const Condition: Boolean; const TruePart, FalsePart:
  Byte): Byte; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;
//*******************************************************

function Iff(const Condition: Boolean; const TruePart, FalsePart:
  Cardinal): Cardinal; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;
//*******************************************************

function Iff(const Condition: Boolean; const TruePart, FalsePart:
  Char): Char; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;
//*******************************************************

function Iff(const Condition: Boolean; const TruePart, FalsePart:
  Extended): Extended; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;
//*******************************************************

function Iff(const Condition: Boolean; const TruePart, FalsePart:
  Integer): Integer; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;
//*******************************************************

function Iff(const Condition: Boolean; const TruePart, FalsePart:
  Pointer): Pointer; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;
//*******************************************************

function Iff(const Condition: Boolean; const TruePart, FalsePart:
  string): string; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;
//*******************************************************
{$IFDEF SUPPORTS_INT64}

function Iff(const Condition: Boolean; const TruePart, FalsePart:
  Int64): Int64; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;
{$ENDIF SUPPORTS_INT64}


Solve 2:

Delphi 6+ has the following functions:

function IfThen(AValue: Boolean; const ATrue: Integer; const AFalse: Integer = 0):
  Integer; overload;

function IfThen(AValue: Boolean; const ATrue: Int64; const AFalse: Int64 = 0): Int64;
  overload;

function IfThen(AValue: Boolean; const ATrue: Double; const AFalse: Double = 0.0):
  Double; overload;

function IfThen(AValue: Boolean; const ATrue: string; const AFalse: string =
  ''): string; overload;

Free a parent form when its child gets closed or freed

Problem/Question/Abstract:

I am using a TPageControl and show some forms on its pages. So, whenever I want to show a form I create a new page on the TPageControl for that form and then displat the form in that page. Now I want free that page when the user closes the form sitting on it. I tried using the form's OnClose or OnDestroy events to free the parent tabsheet of the form but I get an access violation.

Answer:

Solve 1:

It is difficult enough to destroy a control from an event handler of that control, trying to destroy its parent adds even more problems to that. The best way to handle this is to leave the destruction of the tabsheet to a neutral 3rd party, in this case the form holding the pagecontrol. In the embedded forms OnClose you post (via postmessage) a custom message to the form holding the pagecontrol and then hide the embedded form. The host form then destroys the tabsheet and that also destroys the embedded form. Posting the message delays the action long enough to allow any code in the embedded form to complete safely. Example:

{Unit for the embedded form}

unit Unit2;

interface

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

const
  UM_KILLCONTROL = WM_USER + 666;
type
  TUMKillControl = record
    msg: Cardinal;
    control: TControl;
    unused: LPARAM;
    result: LRESULT;
  end;
type
  TForm2 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
  public
  end;

implementation

{$R *.dfm}

procedure TForm2.Button1Click(Sender: TObject);
begin
  close
end;

procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  action := caHide;
  PostMessage(GetParentForm(self).Handle, UM_KILLCONTROL, Integer(parent), 0);
end;

end.

{Unit for the host form}

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    StatusBar: TStatusBar;
    Button1: TButton;
    PageControl1: TPageControl;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    procedure UMKillControl(var msg: TUMKillControl); message UM_KILLCONTROL;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  tab: TTabSheet;
begin
  tab := TTabSheet.Create(self);
  tab.PageControl := pagecontrol1;
  with TForm2.create(self) do
  begin
    borderstyle := bsNone;
    parent := tab;
    tab.caption := caption;
    align := alclient;
    show;
  end;
end;

procedure TForm1.UMKillControl(var msg: TUMKillControl);
begin
  msg.control.Free;
end;

end.


Solve 2:

As long as the child form is not "owned" by the tabsheet on which it is parented (being owned by the form which owns the PageControl is OK), you can do this:

{ ... }
type
  TfNastyChild = class(TForm)
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    fKillParent: TWinControl;
  public
    { Public declarations }
    destructor Destroy; override;
  end;

implementation

{$R *.dfm}

procedure TfNastyChild.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if (Parent is TTabsheet) and (Owner <> Parent) then
  begin
    Hide;
    fKillParent := Parent;
    Parent := nil;
  end;
  action := caFree;
end;

destructor TfNastyChild.Destroy;
begin
  if assigned(fKillParent) and not (csDestroying in fKillParent.ComponentState) then
    fKillParent.Free;
  inherited;
end;

Freeing a TList

Problem/Question/Abstract:

Freeing a TList

Answer:

If there is any possibility of the freeing code being called re-entrantly, make sure to store a nil in the list before freeing the object; your code should look like this:


// original from Ray Lischner
for i := 0 to List.Count - 1 do
begin
  TempNode := List[i];
  List[i] := nil;
  TempNode.Free;
end;
List.Free;

How to find out program path

Problem/Question/Abstract:

How to find out program path

Answer:

function Path_App: string;
var
  x: string;
  y: string;
begin
  x := ParamStr(0);
  y := ExtractFileName(ParamStr(0));
  Result := copy(x, 0, length(x) - length(y));
end;

How to detect a color within a range of pixels around the mouse cursor

Problem/Question/Abstract:

I need to search for a pixel of a given TColor around the mouse cursor position. My main problem is that I have to search in a range of pixels around the center of the mouse's actual position starting with one pixel.

Answer:

function FindPixelOnCanvas(
  canvas: TCanvas; {canvas to find pixel on}
  const startAt: TPoint; {start position}
  tolerance: Integer; {pixel range to check}
  color: TColor; {color to look for}
  const rect: TRect; {dimension of canvas}
  var foundPos: TPoint {returns last position tested}
  ): Boolean; {returns true if color found, false if not}
var
  i, k, n: Integer;
begin
  Result := False;
  for n := 0 to tolerance do
    for i := -n to +n do
      for k := -n to +n do
        if (Abs(i) = n) or ((Abs(k) = n) then
          begin
            foundPos := Point(startAt.X + i, startAt.Y + k);
            if PtInRect(foundPos, rect) and (Canvas.Pixels[foundPos.X, foundPos.Y] = color) then
            begin
              Result := True;
              Exit;
            end;
          end;
end;

How to do a locate on a non-indexed field

Problem/Question/Abstract:

How to do a locate on a non-indexed field

Answer:

The following function can be added to your to your unit and called as follows:

Locate(Table1, Table1LName, 'Beman');

Table1 is your table component, Table1LName is TField you've add with the fields editor (double click on the table component) and 'Beman' is the name you want to find.

{Locate will find sValue in a non-indexed table}

function Locate(const oTable: TTable; const oField: TField; const sValue: string): Boolean;
var
  bmPos: TBookMark;
  bFound: Boolean;
begin
  Locate := False;
  bFound := False;
  if not oTable.Active then
    Exit;
  if oTable.FieldDefs.IndexOf(oField.FieldName) < 0 then
    Exit;
  bmPos := oTable.GetBookMark;
  with oTable do
  begin
    DisableControls;
    First;
    while not EOF do
      if oField.AsString = sValue then
      begin
        Locate := True;
        bFound := True;
        Break;
      end
      else
        Next;
  end;
  if (not bFound) then
    oTable.GotoBookMark(bmPos);
  oTable.FreeBookMark(bmPos);
  oTable.EnableControls;
end;

Add a bitmap to a menu item

Problem/Question/Abstract:

Add a bitmap to a menu item

Answer:

Just follow these steps:

Create a Picture and store it as a file 'img.bmp'.
Use the SetMenuItemBitmaps API call to connect the Picture to the Menu with these parameters:
MenuItemFile is the name given to the horizontal Menuitem, e.g. "File", "Edit", "Help"
0,1 ... is the position of the item on which you want to place the bitmap. (start counting with 0)
The first of the two bitmap handles is the one for the bitmap displayed for the unchecked menuitem
The second bitmap handle is the one for the checked menuitem. They may be the same.

All this can by coded in the .Create of a form.

Try to make the picture not to large, or it will not be displayed completely. Only the right-top of the bitmap will be displayed.

Finally, here's the code:


var
  Bmp1: TPicture;

  ...

  Bmp1 := TPicture.Create;
  Bmp1.LoadFromFile('.\img.bmp');
  SetMenuItemBitmaps(MenuItemTest.Handle, 0, MF_BYPOSITION,
    Bmp1.Bitmap.Handle, Bmp1.Bitmap.Handle);
  ...


Don't forget to free the bitmap Bmp1 e.g. when you destroy your form.

How to force a TListBox to set a horizontol scrollbar if an entry is being cropped

Problem/Question/Abstract:

I have a listbox on a form which contains a list of stuff of varying widths. In some situations, they all fit in the box, in some cases the entries are too long to fit and their right end gets cropped. Is there some way to force the listbox to set a horizontol scrollbar if and only if an entry is being cropped? I can brute force set the ScrollWidth property to 1000, but this puts a scrollbar in place all the time. I only want a scrollbar if it's necessary.

Answer:

{ ... }
listbox.Scrollwidth := CalcMaxWidthOfStrings(listbox.Items, listbox.font);
{ ... }

function CalcMaxWidthOfStrings(aList: TStrings; aFont: TFont): Integer;
var
  max, n, i: Integer;
  canvas: TCanvas;
begin
  Assert(Assigned(aList));
  Assert(Assigned(aFont));
  canvas := TCanvas.Create;
  try
    canvas.Handle := CreateDC('DISPLAY', nil, nil, nil);
    try
      Canvas.Font := aFont;
      max := 0;
      for i := 0 to aList.Count - 1 do
      begin
        n := Canvas.TextWidth(aList[i]);
        if n > max then
          max := n;
      end;
      Result := max;
    finally
      DeleteDC(canvas.Handle);
      canvas.Handle := 0;
    end;
  finally
    canvas.free;
  end;
end;

Various color conversion routines

Problem/Question/Abstract:

Is there a routine that can take a hex color value and convert it to a Delphi formatted value like: "Cornsilk1 Cornsilk1 255 248 220 #FFF8DC" into $00DCF8FF ?

Answer:

Solve 1:

function Swap32(aLong: Longint): Longint; assembler;
asm
  BSWAP eax
end;

function HexColorToColor(HexColor: string): TColor;
{input: '#FFF8DC' -> output $DCF8FF as TColor, use IntTohex to convert output to string again if needed}
begin
  Assert(Length(hexcolor)) > 1;
  Assert(hexcolor[1] = '#');
  hexcolor[1] := '$';
  Result := Swap32(StrToInt(hexcolor));
end;


Solve 2:

The safest way to convert this is to use the following:

{ ... }
var
  r, g, b: string;
begin
  r := Copy(HexValue, 2, 2);
  g := {... same, but for the GG part}
  b := {...same, but for the BB part}
  {Finally}
  DelphiColor := RGB(STrToInt('$' + R), STrToInt('$' + G), STrToInt('$' + B));
end;

Note: You should never shift the RGB data manually as the bit order is different in various screen modes. The first two bytes you refered to as $00 is the alpha channel, or color intensity. Packages like Graphics32 that support this feature normally allows you to manipulate this directly, where $FF is normal color, while $00 is completely invisible. But all of this can be avoided by using the example above. Try it out, you will see what i mean.


Solve 3:

A HTML color string has the format #RRGGBB, the color values are coded as two digit hexadecimal numbers. Delphi's TColor is an Integer value. If the bits 24..31 = 0 then the value describes a RGB color.

RGB color:
Bit
  0.. 7: red
  8..15: green
  16..23: blue
  24..31: 0

Source code:

{exchange red and blue color values}

function ByteSwapColor(Color: TColor): TColor; assembler;
asm
  BSWAP  EAX
  SHR  EAX, 8
end;

resourcestring
  SIsNotAHTMLColorValue = '%s is not a HTML color value';

procedure ConvertHTMLtoRGBColor(HTMLColor: string; var Color: TColor): Boolean;
begin
  Result := False;
  if Length(HTMLColor) <> 7 then
    Exit;
  if HTMLColor[1] <> '#' then
    Exit;
  HTMLColor[1] := '$';
  Color := StrToIntDef(HTMLColor, -1);
  Result := (0 <= Color) and (Color <= $FFFFFF);
  if Result then
    Color := ByteSwapColor(Color);
end;

function HTMLtoRGBColor(const HTMLColor: string): TColor;
begin
  if not ConvertHTMLtoRGBColor(HTMLColor, Result) then
    raise EConvertError.CreateFmt(SIsNotAHTMLColorValue, [HTMLColor]);
end;

function RGBtoHTMLColor(Color: TColor): string;
begin
  Color := RGBColor(Color);
  Color := ByteSwapColor(Color);
  Result := Format('#%.6x', [Color]);
end;


Solve 4:

function HTMLToDelphiColor(S: string): TColor;
var
  Red, Green, Blue: LongInt;
begin
  Red := StrToInt('$' + Copy(S, 1, 2));
  Green := StrToInt('$' + Copy(S, 3, 2));
  Blue := StrToInt('$' + Copy(S, 5, 2));
  Result := (Blue shl 16) + (Green shl 8) + Red;
end;

function ColorToHTMLHex(Color: TColor): string;
begin
  Result := IntToHex(ColorToRGB(Color), 6);
  Result := '#' + Copy(Result, 5, 2) + Copy(Result, 3, 2) + Copy(Result, 1, 2);
end;

How to really do before and after processing on web requests using borlands web module

Problem/Question/Abstract:

Do you not know where to put CoInitialize or CoUnitialize?

The problem with Borlands web module architech is that there is no true after dispatch method.  Yes, there is one but it only gets called only if your response was handled by an action item and will not get called if your response was sent by an action item.  I have a complete and simple solution for this problem that will allow you to execute code before an after handling a response.. always.

Answer:

First a code listing, then an explanation.

procedure TWebModule1.WebModuleBeforeDispatch(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
  PrevBeforeDispatchMethod: THTTPMethodEvent;
begin
  Handled := True;
  {
    ******* Do initialization code here such as CoInitialize
  }
  try
    PrevBeforeDispatchMethod := BeforeDispatch;
    try
      BeforeDispatch := nil;
      {
        ****** Process anything before calling Action Items here
      }
      DispatchAction(Request, Response);
    finally
      BeforeDispatch := PrevBeforeDispatchMethod;
    end;
  finally
    {
      ******* Do cleanup here such as CoUnInitialize
    }
  end;
end;

Now, to explain.

You need to create an OnBeforeDispatch event, then paste the above code into it. This bypasses Borlands behavior in a way.

This is what goes on behind the scenes....

Borlands web application calls your web modules DispatchAction method, the dispatch action event then calls your BeforeDispatch event if you have assigned one... now for the trick, if your BeforeDispatch event handles the request then no action item will be called. I take advantage of that behavior.  The Dispatach event will be called 2 times, once by the web application and a second time by the above code... to prevent recursion I set the BeforeDispatch event to nil.  Because I set handled to true, the first call made by the web application will not call any action items... remember if the BeforeDispatch event Sets handled to true then the DispatchAction event will not call action items.  Therefore my BeforeDispatch event calls the action items through a second call to DispatchAction... DispatchAction will not call my BeforeDispatch event because I set it to nil before calling DispatchAction.

There is one problem that can occur, AfterDispatch will be called 2 times. If you are not using the AfterDispatch event then you have no problems.

I suggest you not use the AfterDispatch event handler or write some code to prevent your code executing 2 times.

Delete our own application

Problem/Question/Abstract:

How to delete our own application

Answer:

Solve 1:

This solution comes from my idea of doing a installer program. InstallShield(C) and others just uses that solution.

Do not use a Batch file, instead use a small (about 25K) console application that just takes one parameter (the file
that must be deleted) and waits until your application unloads and/or EXE file is unlocked. Just run it from your application before exiting.

program DelFile;
{$APPTYPE CONSOLE}
uses SysUtils, Windows;
begin
  if (ParamCount = 0) then
    Exit;
  repeat
    Sleep(10);
  until (DeleteFile(PChar(ParamStr(1))));
end.

To do a better work, the DelFile.Exe file should be put during the installation of the program into the Windows\Temp folder and runned from there, specifing the complete path of the file that must be deleted.

PRO:
  The batch file can be modified and can be done to not delete your file.
VS:
  You must hide a program in the Windows\Temp folder of a  user, that's not good.


Solve 2:

You can use the registry key:

HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Runonce

to add a command that will be runned only once, and your application will be deleted next type your Windows will be restarted.

Key name: "DeleteMyOwnApplicationFile"
Key value: "c:\windows\temp\delfile.exe c:\myapp\myapp.exe"

PRO:
  The next time Windows starts, you application will be surelly not
  loaded, also if it's in the Statup folder.
VS:
  You must hide a program in the Windows\Temp folder of a
  user, that's not good.
  The system must be rebooted.  

Solve 3:

Always using, the key registry, don't use your delfile.exe, but:

Key name: "DeleteMyOwnApplicationFile"
Key value: "del c:\myapp\myapp.exe"

...using the DOS "Del" command.

PRO:
  You don't need to hide programs.
VS:
  The system must be restarted.

Create a Treeview with Keys from the Registry

Problem/Question/Abstract:

Anyone have any sample code on how to load a TreeView with registry keys, i  want to load the
KEY_CURRENT_USER\\Software key, and i want all the subkeys  to load in the treeview too.

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    TreeView1: TTreeView;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private

  public

    procedure FillRegBranch(rootkey: hkey; parentkey: string; ParentNode: TTreeNode);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  Node: TTreeNode;
begin
  TreeView1.Items.Clear;
  TreeView1.Items.BeginUpdate;
  Node := TreeView1.Items.AddChild(nil, 'Borland');
  FillRegBranch(HKEY_Local_Machine, 'Software\Borland', Node);
  TreeView1.Items.EndUpdate;
end;

procedure tForm1.FillRegBranch(rootkey: hkey; parentkey: string; ParentNode:
  TTreeNode);
var
  Cnt: Integer;
  StList: TStrings;
  Node: tTreeNode;
  Registry: TRegistry;
begin
  Registry := TRegistry.Create;
  try
    Registry.RootKey := rootkey;
    if Registry.OpenKey(parentkey, false) then
    begin
      StList := tStringlist.Create;
      try
        Registry.GetKeyNames(StList);
        for Cnt := 0 to StList.count - 1 do
        begin
          Node := TreeView1.Items.addChild(ParentNode, StList.Strings[cnt]);
          if Registry.HasSubKeys then
            FillRegBranch(rootkey, parentkey + '\' + StList.Strings[cnt], node);
        end;
      finally
        StList.Free;
      end;
    end;
  finally
    Registry.Free;
  end;
end;

end.

An Edit Control with AutoComplete Capabilities

Problem/Question/Abstract:

Microsoft�s AutoComplete can be used in a Delphi Application in a Friendly way with the following component

Answer:

// Implements a TCustomEdit with AutoComplete Capabilities
// Author: Jorge Abel Ayala Marentes
// Created: 15/Oct/2000
// Last Modification: 21/Nov/2000

unit U_AutoCompleteEdit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, StrTools, ShlIntf, ActiveX, ComObj;

type
  TSearchListChangeEvent = procedure of object;

  TAutoCompleteEdit = class(TCustomEdit)
  private
    FSearchListChange: TSearchListChangeEvent;
    FAutoComplete: IAutoComplete2;
    FStrings: IUnknown;
    FStringList: TStrings;
    procedure SetFStringList(const Value: TStrings);
  protected
    procedure SearchListChange;
  public
    constructor Create(AOwner: TComponent); override;

    //Needed to init AutoComplete when the component is first Loaded
    procedure Loaded; override;
    destructor Destroy; override;
    procedure SetAutoComplete;
  published
    property AutoSelect;
    property AutoSize;
    property BorderStyle;
    property CharCase;
    property HideSelection;
    property MaxLength;
    property ParentColor;
    property Text;
    property OnChange;
    property SearchList: TStrings read FStringList write SetFStringList;
    property OnSearchListChange: TSearchListChangeEvent read FSearchListChange
      write FSearchListChange;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Sitio Web', [TAutoCompleteEdit]);
end; //end of Register

{ TAutoCompleteEdit }

constructor TAutoCompleteEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Parent := TWinControl(AOwner);
  FStringList := TStringList.Create;
  SearchListChange;
end; //end of TAutoCompleteEdit.Create

destructor TAutoCompleteEdit.Destroy;
begin
  FStringList.Free;
  inherited;
end; //end of TAutoCompleteEdit.Destroy

//Updated: Last version didt�nt work because the searchlist wasn�t
//initializaed when the component was loaded :)

procedure TAutoCompleteEdit.Loaded;
begin
  inherited;
  if FStringList.Count > 0 then
    SetAutoComplete;
end; //end of TAutoCompleteEdit.Loaded

procedure TAutoCompleteEdit.SearchListChange;
begin
  if Assigned(FSearchListChange) then
    FSearchListChange;
end; //end of TAutoCompleteEdit.SearchListChange

procedure TAutoCompleteEdit.SetAutoComplete;
begin
  FAutoComplete := CreateComObject(CLSID_AutoComplete) as IAutoComplete2;

  FStrings := TEnumString.Create(FStringList) as IUnknown;
  OleCheck(FAutoComplete.SetOptions(ACO_AUTOSUGGEST
    or ACO_AUTOAPPEND or ACO_UPDOWNKEYDROPSLIST or ACO_USETAB));
  OleCheck(FAutoComplete.Init(Self.Handle, FStrings, nil, nil));
end; //end of TAutoCompleteEdit.SetAutoComplete

procedure TAutoCompleteEdit.SetFStringList(const Value: TStrings);
begin
  SearchList.Assign(Value);
  SetAutoComplete;
  SearchListChange;
end; //end of TAutoCompleteEdit.SetFStringList

end.

You can download the complete component.

Please note that AutoComplete can only be used if you have Sell32.dll verson 4.7 or above, I think that if you install IE 5.0 or above you won�t have any troble, there are still some improvements I can think of, but please any feedback will be apreciated, let me kwnow your ideas.


Component Download: AutoCompleteEdit.zip

Giving a MDI window a background image/tile

Problem/Question/Abstract:

How do I give my MDI window a background image or tile?

Answer:

This is a handy trick I found somewhere:

Put an image called Image1 on your main form.
Add the following routine to your main form:

Make sure you have the following variables in your main form object:

FClientInstance: TFarProc;
FPrevClientProc: TFarProc;

{ MDI Background code }

procedure TMainForm.ClientWndProc(var Message: TMessage);
var
  Dc: hDC;
  Row: Integer;
  Col: Integer;
begin
  with Message do
    case Msg of
      WM_ERASEBKGND:
        begin
          Dc := TWMEraseBkGnd(Message).Dc;
          // Tile Image on DC
          for Row := 0 to ClientHeight div Image1.Picture.Height do
            for Col := 0 to ClientWidth div Image1.Picture.Width do
              BitBlt(Dc,
                Col * Image1.Picture.Width,
                Row * Image1.Picture.Height,
                Image1.Picture.Width,
                Image1.Picture.Height,
                Image1.Picture.Bitmap.Canvas.Handle,
                0,
                0,
                SRCCOPY);
          Result := 1;
        end;
    else // Pass on other msg's
      Result := CallWindowProc(FPrevClientProc,
        ClientHandle,
        Msg,
        wParam,
        lParam);
    end;
end;

And put this in your mainform OnShow event:

// MDI background tiles stuff, chain in de WndProc.
FClientInstance := MakeObjectInstance(ClientWndProc);
FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance));

You now have a background!

Connect/Disconnect network drives

Problem/Question/Abstract:

How do I map a drive letter to a network resource?

Answer:

//we could use the standard dialog to have the user do it

procedure TForm1.Button1Click(Sender: TObject);
begin
  WNetConnectionDialog(Handle, RESOURCETYPE_DISK)
end;

//we can use the same to connect a printer

procedure TForm1.Button1Click(Sender: TObject);
begin
  WNetConnectionDialog(Handle, RESOURCETYPE_PRINT)
end;

//or we can do this by code

procedure TForm1.Button2Click(Sender: TObject);
var
  NetResource: TNetResource;
begin
  { fill out TNetResource record structure }
  NetResource.dwType := RESOURCETYPE_DISK;
  NetResource.lpLocalName := 'S:';
  NetResource.lpRemoteName := '\\myserver\public';
  NetResource.lpProvider := '';

  { map our network drive using our TNetResource record structure }
  if (WNetAddConnection2(NetResource,
    '', {Password (if needed) or empty}
    '', {User name (if needed) or empty}
    CONNECT_UPDATE_PROFILE) <> NO_ERROR) then
    raise Excepcion.Create('unable to map drive')
      //there are other constants to check the error
    //ERROR_ACCESS_DENIED, ERROR_ALREADY_ASSIGNED, etc
end;

//to disconnect it simply...

procedure TForm1.Button2Click(Sender: TObject);
begin
  if WNetCancelConnection2('S:', 0, TRUE) <> NO_ERROR then
    raise Exception.create('Error disconnecting map drive');
  //of course there are also some other constants to check why the error
  //occurred: ERROR_DEVICE_IN_USE, ERROR_NOT_CONNECTED, etc
end;

OpenGL I: Hello World

Problem/Question/Abstract:

Most people know Delphi as a RAD tool to create database applications, Delphi programmers know that with Delphi you can do EVERYTHING

Answer:

There's quite some people out there doing great efforts to promote OpenGL and DirectX technologies with Delphi;
I will mention this, as I got the base code (and fixed it a little bit) from here:
http://nehe.gamedev.net/

In this article I will show you the base code to create fast and small Delphi-OpenGL applications

I would like to comment that graphics programming is not easy, you will need some knowledge about math and a lot of reading, is like learning a new languaje (a hard one)

First, we will be using no forms (to make application small) and therefore obviously no components (we're going to do this as real programmers =o) )

Our application will consist of the "project source" and one unit In our unit we are just going to create a record to hold some of the application values and some simple constants that are explained in detail here's the "header" of our unit (sorry, no classes or objects):

type
  TGLWindow = record
    Active: Boolean;
      //Window Active Flag (False is minimized, so we don't draw stuff when minimized)
    ExitGame: Boolean; //The main loop is based on this variable
    Keys: array[0..255] of Bool; //Array Used For The Keyboard Routine
    Fullscreen: Boolean; //Fullscreen Flag
    MouseLButton: Integer;
    MouseRButton: Integer; //Left or right buttons pressed? (0 or 1)
    MouseX: Integer;
    MouseY: Integer;
    MouseZ: Integer;
      //Used when right button is pressed (up and down move in and out in the Z axis)
  end;

  { All User Variables Here }
var
  GS: TGLWindow;

const
  POS_X = 100; //Position of window (only when NOT in fullscren mode)
  POS_Y = 100;
  RES_X = 640; //Resolution
  RES_Y = 480;
  RES_BITS = 16; //16 bits resolution
  WIN_TITLE = 'My Game'; //Title for our window

Then from our unit we need to export this function:

function WinMain(hInstance: HINST; hPrevInstance: HINST; lpCmdLine: PChar; nCmdShow:
  Integer): integer; stdcall;

and we will also need these variables (private to our unit, so after implementation):

var
  h_RC: HGLRC; //Permanent Rendering Context
  h_DC: HDC; //Private GDI Device Context
  h_Wnd: HWND; //Holds Our Window Handle

This function basically does everything, initializes the window, draws our stuff, process messages, and when you're done destroys the window. Ok, now we need all the procedures to initialize, process messages, etc...

Here are the functions and some explanations (I'll just list the functions and later will put the actual implementation of each one)

function DrawGLScene(): Bool; { All Rendering Done Here }
procedure ReSizeGLScene(const Width: GLsizei; Height: GLsizei);
{ Resize and Initialize The GL Window }
function InitGL(const Width, Height: Glsizei): Bool;
{ All Setup For OpenGL Goes Here }

//WndProc handles all the messages coming to our window

function WndProc(hWnd: HWND; //Handle For The Window
  message: UINT; //Message For This Window
  wParam: WPARAM; //Additional Message Information
  lParam: LPARAM): //Additional Message Information
LRESULT; stdcall;

{in the CreateWindow we do:
- Register the class window
- Create the window
- Get a Device Context (DC)
- Create a Rendering Context (RC) }

function CreateGLWindow(Title: PChar; PosX, PosY: Integer; const Width,
  Height, Bits: Integer; const FullScreenFlag: Bool): Bool; stdcall;

{In the KillWindow we do (obviously the opposite of the CreateWindow and in reverse order):
- Restore the display settings (we need to do this even if something else fails)
- Delete the Rendering Context (RC)
- Release the Device Context (DC)
- Destroy the Window
- Unregister the class window }

procedure KillGLWindow; { Properly Kill the Window }

//WinMain is the actual Main Program (gets called from the actual Main.dpr)

function WinMain(hInstance: HINST; hPrevInstance: HINST; lpCmdLine: PChar;
  nCmdShow: Integer): integer; stdcall;

That's all you will need to get started, here's the implementation of these procedures/functions, take a good look at WinMain and WndProc, they show some good stuff even for not graphic applications, you could use them to create small programs that do not require windows...

oh... and one last thing... the "hello world" program in OpenGL won't even show the words "Hello World" (WHAAAT??)
the thing is that outputing text to the screen in OpenGL is a little advanced and I will show it to you in later articles (if you are interested that is). The purpose of this article is to show you the base code and hopefully you will get to understand it and then from there we can concentrate in the OpenGL stuff, so... I will just show you how to create a simple rectangle =o (,but don't be dissapointed, as I say OpenGL is not easy and you won't be creating the next QUAKE in the next 3 months, first you need to create a rectangle, a triangle... a circle ...and theeeen... eventually you will get there (if you really persist)

with no more preambule, here's the code:

  //---------------------------------------------------------//
  //                                                         //
  //     Original Copyrights: Daniel Vivas                   //
  //                          daniel@vivas.com.br            //
  //                                                         //
  //     Main Game Unit                                      //
  //     Ported To Delhi By: Bryce TeBeest                   //
  //     Assistance Provided By: JP Krauss                   //
  //                                                         //
  //     Taken from Jeff Molofi (NEHE) WebSite               //
  //     http://nehe.gamedev.net                             //
  //                                                         //
  //     Some fixes and comments by: EberSys                 //
  //---------------------------------------------------------//
unit oglMain;

interface

uses
  Classes,
  Messages,
  Windows,
  OpenGL;

type
  TGLWindow = record
    Active: Boolean;
      //Window Active Flag (False is minimized, so we don't draw stuff when minimized)
    ExitGame: Boolean; //The main loop is based on this variable
    Keys: array[0..255] of Bool; //Array Used For The Keyboard Routine
    Fullscreen: Boolean; //Fullscreen Flag
    MouseLButton: Integer;
    MouseRButton: Integer; //Left or right buttons pressed? (0 or 1)
    MouseX: Integer;
    MouseY: Integer;
    MouseZ: Integer;
      //Used when right button is pressed (up and down move in and out in the Z axis)
  end;

  { All User Variables Here }
var
  GS: TGLWindow;

const
  POS_X = 100; //Position of window (only when NOT in fullscren mode)
  POS_Y = 100;
  RES_X = 640; //Resolution
  RES_Y = 480;
  RES_BITS = 16; //16 bits resolution
  WIN_TITLE = 'My Game'; //Title for our window

  {-----------------------------------------------------------}
  { Public Procedures: }

function WinMain(hInstance: HINST; hPrevInstance: HINST; lpCmdLine: PChar; nCmdShow:
  Integer): integer; stdcall;
{-----------------------------------------------------------}

implementation

var
  h_RC: HGLRC; //Permanent Rendering Context
  h_DC: HDC; //Private GDI Device Context
  h_Wnd: HWND; //Holds Our Window Handle
  {-----------------------------------------------------------}

function DrawGLScene(): Bool; { All Rendering Done Here }
begin
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); //Clear Screen and Depth Buffer
  glLoadIdentity(); //Reset The View (move to 0, 0, 0)

  glTranslatef(0.0, 0.0, -6.0); // Move Right 1.5 Units And Into The Screen 6.0
  glColor3f(0.0, 0.5, 0.5);
  glBegin(GL_QUADS); // Draw A Quad
  glVertex3f(-0.5, 0.5, 0.0); // Top Left
  glVertex3f(0.5, 0.5, 0.0); // Top Right
  glVertex3f(0.5, -0.5, 0.0); // Bottom Right
  glVertex3f(-0.5, -0.5, 0.0); // Bottom Left
  glEnd();

  DrawGLScene := True
end;

procedure ReSizeGLScene(const Width: GLsizei; Height: GLsizei);
  { Resize and Initialize The GL Window }
var
  fWidth, fHeight: GLFloat;
begin
  if (Height = 0) then //Prevent Divide by Zero
    Height := 1; //Be Setting Height at One

  glViewport(0, 0, Width, Height);
    //Reset The Current Viewport and Perspective Transformation
  glMatrixMode(GL_PROJECTION); //Select The Projection Matrix
  glLoadIdentity(); //Reset The Project Matrix
  fWidth := Width;
  fHeight := Height;
  gluPerspective(45.0, fWidth / fHeight, 0.1, 100);
    //Calculate the Aspect Ratio of the Window
  glMatrixMode(GL_MODELVIEW); //Select The ModelView Matrix
end;

{ All Setup For OpenGL Goes Here }

function InitGL(const Width, Height: Glsizei): Bool;
var
  fWidth, fHeight: GLfloat;
begin
  glClearColor(0.0, 0.0, 0.0, 0.0); //Black Background
  glClearDepth(1.0); //Depth Buffer Setup
  glDepthFunc(GL_LESS); //Text
  glEnable(GL_DEPTH_TEST); //Enables Depth Testing
  glShadeModel(GL_SMOOTH); //Enables Smooth Color Shading
  glMatrixMode(GL_PROJECTION);
  glLoadIdentity(); //reset the View (move to 0, 0, 0)

  fWidth := Width;
  fHeight := Height;
  gluPerspective(45.0, fWidth / fHeight, 0.1, 100);
    //Calculate Aspect Ratio Of The Window
  glMatrixMode(GL_MODELVIEW)
end;

//WndProc handles all the messages coming to our window

function WndProc(hWnd: HWND; //Handle For The Window
  message: UINT; //Message For This Window
  wParam: WPARAM; //Additional Message Information
  lParam: LPARAM): //Additional Message Information
LRESULT; stdcall;
begin
  if message = WM_SYSCOMMAND then
    case wParam of //Check System Calls
      SC_SCREENSAVE, SC_MONITORPOWER:
        //Screensaver Trying To Start, Monitor Trying To Enter Powersave
        begin
          Result := 0;
          exit
        end
    end;

  case message of //Tells Windows We Want To Check Message
    WM_ACTIVATE:
      begin
        if (Hiword(wParam) = 0) then //Check Minimization State
          GS.Active := True
        else
          GS.Active := False; //when Active is False we don't draw anything
        Result := 0;
      end;
    WM_CLOSE: //Did we get a close message?
      begin
        PostQuitMessage(0); //Send A Quit Message
        Result := 0; //Return To The Message Loop
      end;
    WM_KEYDOWN: //Is A Key Being Held Down?
      begin
        GS.Keys[wParam] := True;
        Result := 0; //Return To The Message Loop
      end;
    WM_KEYUP: //Is A Key Being Released?
      begin
        GS.Keys[wParam] := False;
        Result := 0;
      end;
    WM_SIZE: //Resize scene
      begin
        ReSizeGLScene(LOWORD(lParam), HIWORD(lParam)); //LoWord=Width, HighWord=Height
        Result := 0;
      end;
    WM_LBUTTONDOWN: //(mouse) Left button pressed
      begin
        ReleaseCapture(); //Need Them Here, Because If Mouse Moves Off
        SetCapture(h_Wnd); //Window and Returns, It Needs To Reset Status
        GS.MouseLButton := 1;
        GS.MouseX := LOWORD(lParam);
        GS.MouseY := HIWORD(lParam);
      end;
    WM_LBUTTONUP: //(mouse) Left button released
      begin
        ReleaseCapture();
        GS.MouseLButton := 0;
        GS.MouseX := 0;
        GS.MouseY := 0;
        Result := 0;
      end;
    WM_RBUTTONDOWN: //(mouse) Right button pressed
      begin
        ReleaseCapture();
        SetCapture(h_Wnd);
        GS.MouseRButton := 1;
        GS.MouseZ := HIWORD(lParam);
        Result := 0;
      end;
    WM_RBUTTONUP: //(mouse) Right button released
      begin
        ReleaseCapture();
        GS.MouseRButton := 0;
        Result := 0
      end
  else
    { Pass All Unhandled Messages TO DefWinProc }
    Result := DefWindowProc(hWnd, message, wParam, lParam)
  end //case message of
end;

{In the KillWindow we do (obviously the opposite of the CreateWindow and in reverse order):
- Restore the display settings (we need to do this even if something else fails)
- Delete the Rendering Context (RC)
- Release the Device Context (DC)
- Destroy the Window
- Unregister the class window }

procedure KillGLWindow; { Properly Kill the Window }
begin
  if (GS.FullScreen) then
  begin //Are We In FullScreen Mode?
    ChangeDisplaySettings(devmode(nil^), 0); //Switch Back To The Desktop
    ShowCursor(True); //Show The Mouse Pointer
  end;

  if (h_RC <> 0) and not (wglDeleteContext(h_RC)) then //Are We Able To Delete The Rc?
  begin
    MessageBox(0, 'Release of Rendering Context failed.', ' Shutdown Error', MB_OK or
      MB_ICONERROR);
    h_RC := 0 //Set Rendering Context To Null
  end;
  if (h_DC <> 0) and (releaseDC(h_Wnd, h_DC) = 0) then
    //Are We Able To Release The Device Context?
  begin
    MessageBox(0, 'Release of Device Context failed.', ' Shutdown Error', MB_OK or
      MB_ICONERROR);
    h_Dc := 0; //Set Dc To Null
  end;
  if (h_Wnd <> 0) and not (destroywindow(h_Wnd)) then
    //Are We Able To Destroy The Window?
  begin
    MessageBox(0, 'Could not release hWnd.', ' Shutdown Error', MB_OK or
      MB_ICONERROR);
    h_Wnd := 0; //Set hWnd To Null
  end;
  UnregisterClass('OpenGL', hInstance)
end;

{in the CreateWindow we do:
- Register the class window
- Create the window
- Get a Device Context (DC)
- Create a Rendering Context (RC) }

function CreateGLWindow(Title: PChar; PosX, PosY: Integer; const Width, Height, Bits:
  Integer; const FullScreenFlag: Bool): Bool; stdcall;
var
  PixelFormat: GLUint; //Holds The Result After Searching For A Match
  WC: TWndClass; //Windows Class Structure
  dwExStyle: DWord; //Extended Windows Style
  dwStyle: DWord; //Window Style
  PFD: PixelFormatDescriptor; //Tells Windows How We Want Things To Be
  dmScreenSettings: DevMode; //Device Mode
  h_Instance: hInst; //Holds The Instance Of The Application
begin
  h_Instance := GetModuleHandle(nil); //Grab An Instance For Our Window
  GS.Fullscreen := FullScreenFlag; //Set The Global FullScreen Flag

  with WC do //can't use parentesis on "with" when using packed records
  begin
    Style := CS_HREDRAW or CS_VREDRAW or CS_OWNDC;
      //ReDraw On Size -- Own DC For Window
    lpfnWndProc := @WndProc; //WndProc Handles The Messages
    cbClsExtra := 0; //No Extra Window Data
    cbWndExtra := 0; //No Extra Window Data
    hInstance := h_Instance; //Set The Instance
    hIcon := LoadIcon(0, IDI_WINLOGO); //Load The Default Icon
    hCursor := LoadCursor(0, IDC_ARROW); //Load The Arrow Pointer
    hbrBackground := 0; //No BackGround Required For OpenGL
    lpszMenuName := nil; //We Don't Want A Menu
    lpszClassname := 'OpenGL'; //Set The Class Name
  end;

  if (RegisterClass(WC) = 0) then //Attempt To Register The Class Window
  begin
    MessageBox(0, 'Failed To Register The Window Class.', 'Error', MB_OK or
      MB_ICONERROR);
    CreateGLWindow := False;
    exit
  end;

  if (GS.FullScreen) then
  begin
    ZeroMemory(@dmScreenSettings, SizeOf(dmScreenSettings));
      //Make Sure Memory's Availiable

    with dmScreenSettings do //don't use parentesis on "with" when using packed records
    begin
      dmSize := SizeOf(dmScreenSettings); //Size Of The DevMode Structure
      dmPelsWidth := Width; //Selected Screen Width
      dmPelsHeight := Height; //Selected Screen Height
      dmBitsPerPel := Bits; //Selected Bits Per Pixel
      dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
        //Try to Set Selected Mode
    end;

    if (ChangeDisplaySettings(dmScreenSettings, CDS_FULLSCREEN) <>
      DISP_CHANGE_SUCCESSFUL) then
      if (MessageBox(0,
                                'This Fullscreen Mode Is Not Supported.  Use Windowed Mode Instead?',
                                WIN_TITLE,
        MB_YESNO or MB_ICONEXCLAMATION) = IDYES) then
        GS.Fullscreen := False //Select Windowed Mode
      else
      begin
        { Show Message Box To Let User Know Program Is Ending }
        MessageBox(0, 'Program Will Now Close.', 'Error', MB_OK or MB_ICONERROR);
        CreateGLWindow := False; //Return False
        Exit
      end
  end;

  if (GS.Fullscreen) then //If Still In FullScreen Mode
  begin
    dwExStyle := WS_EX_APPWINDOW; //Entended Window Style
    dwStyle := WS_POPUP or WS_CLIPSIBLINGS or WS_CLIPCHILDREN; //Window Style
    ShowCursor(False);
    PosX := 0; //reset these to zero
    PosY := 0
  end
  else
  begin
    dwExStyle := WS_EX_APPWINDOW or WS_EX_WINDOWEDGE; //Extended Window Style
    dwStyle := WS_OVERLAPPEDWINDOW or WS_CLIPSIBLINGS or WS_CLIPCHILDREN;
      //Windows Style
  end;

  h_Wnd := CreateWindowEx(dwExStyle, //Extends Style For The Window
    'OpenGL', //Class Name
    Title, //Window Title
    dwStyle, //Window Style
    PosX, PosY, //Window Position
    Width, Height, //Selected Width and Height
    0, //No Parent Window
    0, //No Menu
    hInstance, //Instance
    nil); //Don't Pass Anything To WM_CREATE
  if (h_Wnd = 0) then
  begin //If The Window Creation Failed
    KillGLWindow(); //Reset The Display
    MessageBox(0, 'Window Creation Error.', 'Error', MB_OK or MB_ICONEXCLAMATION);
    CreateGLWindow := False;
    exit;
  end;

  with PFD do //don't use parentesis on "with" when using packed records
  begin //Tells Window How We Want Things To Be
    nSize := SizeOf(PIXELFORMATDESCRIPTOR); //Size Of This Pixel Format Descriptor
    nVersion := 1; //Version Number (?)
    dwFlags := PFD_DRAW_TO_WINDOW //Format Must Support Window
    or PFD_SUPPORT_OPENGL //Format Must Support OpenGL
    or PFD_DOUBLEBUFFER; //Must Support Double Buffering
    iPixelType := PFD_TYPE_RGBA; //Request An RGBA Format
    cColorBits := Bits; //Select Our Color Depth
    cRedBits := 0; //Color Bits Ignored
    cRedShift := 0;
    cGreenBits := 0;
    cGreenShift := 0;
    cBlueBits := 0;
    cBlueShift := 0;
    cAlphaBits := 0; //No Alpha Buffer
    cAlphaShift := 0; //Shift Bit Ignored
    cAccumBits := 0; //No Accumulation Buffer
    cAccumRedBits := 0; //Accumulation Bits Ignored
    cAccumGreenBits := 0;
    cAccumBlueBits := 0;
    cAccumAlphaBits := 0;
    cDepthBits := 16; //16 Bit Z-Buffer (Depth Buffer)
    cStencilBits := 0; //No Stencil Buffer
    cAuxBuffers := 0; //No Auxilary Buffer
    iLayerType := PFD_MAIN_PLANE; //Main Drawing Layer
    bReserved := 0; //Reserved
    dwLayerMask := 0; //Layer Masks Ignored
    dwVisibleMask := 0;
    dwDamageMask := 0;
  end;

  h_DC := GetDC(h_Wnd); //Try Getting a Device Context
  if (h_DC = 0) then // Did We Get Device Context For The Window?
  begin
    KillGLWindow(); //Reset The Display
    MessageBox(0, 'Cant''t create a GL device context.', 'Error', MB_OK or
      MB_ICONEXCLAMATION);
    CreateGLWindow := False; //Return False
    exit;
  end;
  PixelFormat := ChoosePixelFormat(h_Dc, @pfd);
    // Finds The Closest Match To The Pixel Format We Set Above
  if (PixelFormat = 0) then //Did We Find A Matching Pixelformat?
  begin
    KillGLWindow(); //Reset The Display
    MessageBox(0, 'Cant''t Find A Suitable PixelFormat.', 'Error', MB_OK or
      MB_ICONEXCLAMATION);
    CreateGLWindow := False; //Return False
    exit;
  end;
  if not (SetPixelFormat(h_Dc, PixelFormat, @pfd)) then
  begin //Are We Able To Set The Pixelformat?
    KillGLWindow(); //Reset The Display
    MessageBox(0, 'Cant''t set PixelFormat.', 'Error', MB_OK or MB_ICONEXCLAMATION);
    CreateGLWindow := False; //Return False
    exit;
  end;

  h_RC := wglCreateContext(h_DC); //Are We Able To create a Rendering Context?
  if (h_RC = 0) then
  begin
    KillGLWindow(); //Reset The Display
    MessageBox(0, 'Cant''t create a GL rendering context.', 'Error', MB_OK or
      MB_ICONEXCLAMATION);
    CreateGLWindow := False; //Return False
    exit;
  end;

  if not (wglMakeCurrent(h_DC, h_RC)) then
    //Are We Able To Activate The Rendering Context?
  begin
    KillGLWindow(); //Reset The Display
    MessageBox(0, 'Cant''t activate the GL rendering context.', 'Error', MB_OK or
      MB_ICONEXCLAMATION);
    CreateGLWindow := False; //Return False
    exit;
  end;

  ShowWindow(h_Wnd, SW_SHOW); //Show The Window
  SetForegroundWindow(h_Wnd); //Slightly Higher Priority
  SetFocus(h_Wnd); //Set Keyboard Focus To The Window
  ReSizeGLScene(Width, Height); //Set Up Our Perspective Gl Screen
  if not (InitGl(Width, Height)) then
    //Do all the initialization here (load textures, etc)
  begin
    KillGLWindow(); //Reset The Display
    MessageBox(0, 'Initialization Failed.', 'Error', MB_OK or MB_ICONEXCLAMATION);
    CreateGLWindow := False; //Return False
    exit;
  end;
  CreateGLWindow := True //Succes
end;

//WinMain is Main Program (gets called from the actual Main.dpr)

function WinMain(hInstance: HINST; hPrevInstance: HINST; lpCmdLine: PChar; nCmdShow:
  Integer): integer; stdcall;
var
  msg: TMsg;
begin
  if MessageBox(0, 'Would You Like To Run In FullScreen Mode?', 'Start FullScreen',
    MB_YESNO or MB_ICONQUESTION) = idNo then
    GS.Fullscreen := False
  else
    GS.Fullscreen := True;

  if not (CreateGLWindow(WIN_TITLE, POS_X, POS_Y, RES_X, RES_Y, RES_BITS,
    GS.Fullscreen)) then
  begin //Could We Create The OpenGL Window?
    Result := 0;
    exit
  end;

  while not (GS.ExitGame) do //Main Game Loop
  begin
    if (PeekMessage(msg, 0, 0, 0, PM_REMOVE)) then //Is There A Message?
    begin
      if (msg.message = WM_QUIT) then //Have We Received A Quit Message?
        GS.ExitGame := True
      else
      begin
        TranslateMessage(msg); //Translate Message
        DispatchMessage(msg); //Dispatch the Message
      end
    end
    else
      {//No messages, so keep rendering our game} if (GS.Active) and not (DrawGLScene())
      then //here's where all the fun happens
        GS.ExitGame := True
      else
        SwapBuffers(h_DC); //Not Time To Quit Yet

    //Check for keyboard input here
    if (GS.Keys[VK_ESCAPE]) then //Time To Quit
    begin
      GS.Keys[VK_ESCAPE] := False;
      GS.ExitGame := True;
    end
    else if (GS.Keys[VK_F1]) then //Toggle FullScreen Mode
    begin
      GS.Keys[VK_F1] := False;
      KillGLWindow(); //Kill Our Current Window
      GS.Fullscreen := not GS.Fullscreen; //Toggle Our Fullscreen Flag
      //Recreate Our Window
      if not CreateGLWindow(WIN_TITLE, POS_X, POS_Y, RES_X, RES_Y, RES_BITS,
        GS.Fullscreen) then
        Result := 0;
    end
  end; //While not GS.ExitGame

  { End of the Game }
  KillGLWindow(); //Shutdown
  Result := msg.wParam
end;

end.

{and here's the code for the "project source"}

program prjShell;

uses
  oglMain in 'oglMain.pas';

begin
  GS.Active := True;
  WinMain(hInstance, hPrevInst, CmdLine, CmdShow);
end.

Determine if a Unicode string is Baltic or Russian

Problem/Question/Abstract:

How to determine if a Unicode string is Baltic or Russian

Answer:

procedure TForm1.SetReadableText(const ws: WideString);
var
  s: string;
  pch: PChar;
  i, CodePage, Charset: Integer;
begin
  CodePage := 1252;
  Charset := ANSI_CHARSET;
  pch := PChar(PWideChar(ws));
  for i := 0 to length(ws) - 1 do
  begin
    if ord(pch[2 * i + 1]) = 1 then
    begin
      CodePage := 1257;
      Charset := BALTIC_CHARSET;
      break;
    end;
    if ord(pch[2 * i + 1]) = 4 then
    begin
      CodePage := 1251;
      Charset := RUSSIAN_CHARSET;
      break;
    end;
  end;
  setlength(s, 2 * length(ws));
  setlength(s, WideCharToMultiByte(CodePage, 0, PWideChar(ws), length(ws),
    PChar(s), length(s), nil, nil));
  Edit1.Font.Charset := Charset;
  Edit1.Text := s;
end;

Create a scrollbox that lets you disable automatic scrolling

Problem/Question/Abstract:

How to create a scrollbox that lets you disable automatic scrolling

Answer:

unit MyScrollBox;

interface

uses
  SysUtils, Classes, Controls, Forms;

type
  TMyScrollBox = class(TScrollBox)
  private
    FEnableScrollInView: Boolean;
  protected
    procedure AutoScrollInView(AControl: TControl); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property EnableScrollInView: Boolean read FEnableScrollInView
      write FEnableScrollInView default True;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TMyScrollBox]);
end;

procedure TMyScrollBox.AutoScrollInView(AControl: TControl);
begin
  if FEnableScrollInView then
    inherited AutoScrollInView(AControl);
end;

constructor TMyScrollBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEnableScrollInView := True;
end;

end.

Fill a polygon

Problem/Question/Abstract:

How to fill a polygon

Answer:

Below is a demo application with all code inside for drawing and hit-testing polygons. It uses an algorithm which searches for intersections between each scanline (or Y coordinate) with polygon vertices. It is not optimized (though it's quite fast) and it's also universal. It fills all types of polygons, not just concave, or similar. Filling style is equivalent to WINDING comparing to GDI and cannot be changed so far. The slowest part of polygon filling is it's rasterization, also called the polygon scan conversion where polygon has to be transformed into regions that needs to be filled. This can be speed up by caching previously calculated fill ranges. You can do that yourself or you can use TPolygon object that is included. It caches ranges by itself. Note that caching will only work if points do not change (cache is discarded on each point change) but for hit-testing you don't need to use caching because ranges for only one scanline are calculates and not for whole polygon (except if you use TPolygon object where all ranges are precalculated).

unit Main;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    SpinEdit1: TSpinEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure SpinEdit1Change(Sender: TObject);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

type
  {Stores a fill range which is equal to a scanline but there can be many fill ranges for one X coordinate}
  TRange = packed record
    X: Integer;
    Count: Word;
  end;
  TRangeList = array of TRange;
  TRangeListArray = array of TRangeList;

  {TPolygon class represents a polygon. It containes points that define a polygon and
  caches fill range list for fast polygon filling.}
  TPolygon = class
  private
    FPoints: array of TPoint;
    FStartY: Integer;
    FRangeList: TRangeListArray;

    function GetCount: Integer;
    procedure SetCount(AValue: Integer);
    function GetPoint(Index: Integer): TPoint;
    procedure SetPoint(Index: Integer; APoint: TPoint);
  protected
    {Initializes range list}
    procedure RangeListNeeded;
    function GetFillRange(Y: Integer): TRangeList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure AssignPoints(APoints: array of TPoint);
    procedure Offset(dx, dy: Integer);
    property Count: Integer read GetCount write SetCount;
    property Points[Index: Integer]: TPoint read GetPoint write SetPoint;
  end;

  {Returns fill range list for specified Y coordinate. It calculates intersection
  points with specified scanline (at Y coordinates).}
procedure Polygon_GetFillRange(const Points: array of TPoint; Y: Integer;
  out ARangeList: TRangeList);
{Returns bounds of polygon}
function Polygon_GetBounds(const Points: array of TPoint): TRect;
{Returns True if point lies inside polygon}
function Polygon_PtInside(const Points: array of TPoint; Pt: TPoint): Boolean;

implementation

{$R *.dfm}

type
  pRangeItem = ^TRangeItem;
  TRangeItem = record
    X: Integer;
    Up: Boolean;
    Next: pRangeItem;
  end;

procedure Polygon_GetFillRange(const Points: array of TPoint; Y: Integer;
  out ARangeList: TRangeList);
var
  {first item in list}
  AItem: pRangeItem;

  procedure AddIntersection(X: Integer; Up: Boolean);
  var
    p, p2, Prev: pRangeItem;
  begin
    New(p);
    Prev := nil;
    p^.X := X;
    p^.Up := Up;
    p^.Next := nil;
    if Assigned(AItem) then
    begin
      {insert into sorted position}
      p2 := AItem;
      while Assigned(p2) do
      begin
        if p2^.X > X then
        begin
          if Assigned(Prev) then
          begin
            Prev^.Next := p;
            p^.Next := p2;
            Break;
          end
          else
          begin
            p^.Next := p2;
            AItem := p;
            Break;
          end;
        end;
        if p2^.Next = nil then
        begin
          {add to the end}
          p2^.Next := p;
          Break;
        end;
        Prev := p2;
        p2 := p2^.Next;
      end;
    end
    else
      AItem := p;
  end;

var
  i, X, X0, Cnt: Integer;
  LastDirection: Boolean;
  p: pRangeItem;
begin
  if Length(Points) = 0 then
    Exit;
  AItem := nil;
  Cnt := 0;
  for i := 0 to Length(Points) - 2 do
  begin
    if ((Points[i].Y > Y) and (Points[i + 1].Y <= Y)) or ((Points[i].Y <= Y) and
      (Points[i + 1].Y > Y)) then
      if Points[i + 1].Y <> points[i].Y then
      begin
        X := Round(Points[i].X + ((Points[i + 1].X - Points[i].X) *
          (Y - Points[i].Y) / (Points[i + 1].Y - points[i].Y)));
        AddIntersection(X, Points[i + 1].Y > Points[i].Y);
        Inc(Cnt);
      end;
  end;
  {close polygon}
  i := Length(Points) - 1;
  if ((Points[i].Y > Y) and (Points[0].Y <= Y)) or ((Points[i].Y <= Y) and (Points[0].Y
    > Y)) then
    if Points[0].Y <> points[i].Y then
    begin
      X := Round(Points[i].X + ((Points[0].X - Points[i].X) * (Y - Points[i].Y) /
        (Points[0].Y - points[i].Y)));
      AddIntersection(X, Points[0].Y > Points[i].Y);
      Inc(Cnt);
    end;
  p := AItem;
  {calculate fill ranges}
  i := 1; {use as acumulative direction counter}
  SetLength(ARangeList, Cnt);
  Cnt := 0; {number of range items in array}
  if Assigned(AItem) then
  begin
    LastDirection := AItem^.Up; {init last direction}
    X0 := AItem^.X;
    AItem := AItem^.Next;
  end;
  while Assigned(AItem) do
  begin
    if AItem^.Up = LastDirection then
    begin
      Inc(i);
      if i = 1 then
        X0 := AItem^.X; {init start position}
    end
    else
    begin
      Dec(i);
      if i = -1 then
        X0 := AItem^.X; {init start position}
    end;
    if i = 0 then
    begin
      ARangeList[Cnt].X := X0;
      ARangeList[Cnt].Count := AItem^.X - X0;
      Inc(Cnt);
      LastDirection := AItem^.Up;
    end;
    AItem := AItem^.Next;
  end;
  {shrink list}
  SetLength(ARangeList, Cnt);
  {delete internal range list}
  while Assigned(p) do
  begin
    AItem := p;
    p := p^.Next;
    Dispose(AItem);
  end;
end;

function Polygon_GetBounds(const Points: array of TPoint): TRect;
var
  i: Integer;
begin
  Result := Rect(0, 0, 0, 0);
  for i := 0 to Length(Points) - 1 do
  begin
    if i = 0 then
      Result := Rect(Points[i].X, Points[i].Y, Points[i].X, Points[i].Y)
    else
    begin
      if Points[i].X < Result.Left then
        Result.Left := Points[i].X;
      if Points[i].Y < Result.Top then
        Result.Top := Points[i].Y;
      if Points[i].X > Result.Right then
        Result.Right := Points[i].X;
      if Points[i].Y > Result.Bottom then
        Result.Bottom := Points[i].Y;
    end;
  end;
  Result.Right := Result.Right + 1;
  Result.Bottom := Result.Bottom + 1;
end;

function Polygon_PtInside(const Points: array of TPoint; Pt: TPoint): Boolean;
var
  RL: TRangeList;
  i: Integer;
begin
  Result := False;
  Polygon_GetFillRange(Points, Pt.Y, RL);
  for i := 0 to Length(RL) - 1 do
  begin
    Result := (Pt.X >= RL[i].X) and (Pt.X < RL[i].X + RL[i].Count);
    if Result then
      Exit;
  end;
end;

{TPolygon}

procedure TPolygon.AssignPoints(APoints: array of TPoint);
begin
  SetLength(FRangeList, 0);
  SetLength(FPoints, Length(APoints));
  Move(APoints, FPoints, Length(APoints) * SizeOf(TPoint));
  {clear cache}
  SetLength(FRangeList, 0);
end;

constructor TPolygon.Create;
begin
  SetLength(FPoints, 0);
  SetLength(FRangeList, 0);
  FStartY := 0;
end;

destructor TPolygon.Destroy;
begin
  SetLength(FPoints, 0);
  SetLength(FRangeList, 0);
end;

function TPolygon.GetCount: Integer;
begin
  Result := Length(FPoints);
end;

function TPolygon.GetFillRange(Y: Integer): TRangeList;
begin
  RangeListNeeded;
  SetLength(Result, 0);
  if (Y >= FStartY) and (Y < Length(FPoints) + FStartY) then
    Result := FRangeList[Y];
end;

function TPolygon.GetPoint(Index: Integer): TPoint;
begin
  Result := FPoints[Index];
end;

procedure TPolygon.Offset(dx, dy: Integer);
var
  i, j: Integer;
begin
  RangeListNeeded;
  FStartY := FStartY + dy;
  for i := 0 to Length(FRangeList) - 1 do
    for j := 0 to Length(FRangeList[i]) - 1 do
      Inc(FRangeList[i][j].X, dx);
end;

procedure TPolygon.RangeListNeeded;
var
  R: TRect;
  Y, i: Integer;
begin
  if Length(FPoints) <> Length(FRangeList) and Length(FPoints) then
  begin
    SetLength(FRangeList, Length(FPoints));
    R := Polygon_GetBounds(FPoints);
    i := 0;
    for Y := R.Top to R.Bottom do
    begin
      Polygon_GetFillRange(FPoints, Y, FRangeList[i]);
      Inc(i);
    end;
  end;
end;

procedure TPolygon.SetCount(AValue: Integer);
begin
  SetLength(FPoints, AValue);
  {Clear cache on point list change}
  SetLength(FRangeList, 0);
end;

procedure TPolygon.SetPoint(Index: Integer; APoint: TPoint);
begin
  FPoints[Index] := APoint;
  {Clear cache if a point changes}
  SetLength(FRangeList, 0);
end;

var
  APoints: array of TPoint;
  AColor: TColor = clBlack;
  APtInside: Boolean = False;

procedure FillPolygon(ACanvas: TCanvas; APoints: array of TPoint);
var
  i, j: Integer;
  R: TRect;
  ARangeList: TRangeList;
begin
  ACanvas.Pen.Color := AColor;
  {Find polygon bounds because we only need to calculate fill-ranges from
  top to bottom value of rectangle}
  R := Polygon_GetBounds(APoints);
  for i := R.Top to R.Bottom do
  begin
    Polygon_GetFillRange(APoints, i, ARangeList);
    {Since there can be many fill ranges for one Y, function returns a list of all}
    for j := 0 to Length(ARangeList) - 1 do
    begin
      {fill pixels inside range}
      {so far I'll just draw a line with GDI but this part can be substituted with your own draw function}
      ACanvas.MoveTo(ARangeList[j].X, i);
      ACanvas.LineTo(ARangeList[j].X + ARangeList[j].Count, i);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to Length(APoints) - 1 do
    APoints[i] := Point(Random(ClientWidth), Random(ClientHeight));
  Repaint;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  Randomize;
  SetLength(APoints, SpinEdit1.Value);
  for i := 0 to Length(APoints) - 1 do
    APoints[i] := Point(Random(ClientWidth), Random(ClientHeight));
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  FillPolygon(Canvas, APoints);
end;

procedure TForm1.SpinEdit1Change(Sender: TObject);
var
  i: Integer;
begin
  SetLength(APoints, SpinEdit1.Value);
  for i := 0 to Length(APoints) - 1 do
    APoints[i] := Point(Random(ClientWidth), Random(ClientHeight));
  Repaint;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if Polygon_PtInside(APoints, Point(X, Y)) then
  begin
    if not APtInside then
    begin
      Caption := 'Inside: YES';
      AColor := clRed;
      APtInside := True;
      Repaint;
    end;
  end
  else
  begin
    if APtInside then
    begin
      Caption := 'Inside: NO';
      AColor := clBlack;
      APtInside := False;
      Repaint;
    end;
  end;
end;

end.

{main.dfm}

object Form1: TForm1
  Left = 290
    Top = 153
    Width = 783
    Height = 540
    Caption = 'Inside: NO'
    Color = clBtnFace
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    OldCreateOrder = False
    OnCreate = FormCreate
    OnMouseMove = FormMouseMove
    OnPaint = FormPaint
    PixelsPerInch = 96
    TextHeight = 13
    object Label1: TLabel
    Left = 168
      Top = 12
      Width = 54
      Height = 13
      Caption = 'Point count'
  end
  object Button1: TButton
    Left = 8
      Top = 8
      Width = 145
      Height = 25
      Caption = 'Randomize points'
      TabOrder = 0
      OnClick = Button1Click
  end
  object SpinEdit1: TSpinEdit
    Left = 232
      Top = 8
      Width = 73
      Height = 22
      MaxValue = 0
      MinValue = 0
      TabOrder = 1
      Value = 8
      OnChange = SpinEdit1Change
  end
end

Deleting all records in a table/deleting a table in a database without SQL

Problem/Question/Abstract:

How can we delete all the records in a table without using a SQL statement?
How can we delete a table in a database without using a SQL statement?

Answer:

In Delphi, all versions, we have a component called TTable. We can use a method of that component to delete all the records in a table. Note that we should have privilege on that database to delete records in that table.

We can use the following code to do that:

with Table1 do
begin
  Active := False;
  DatabaseName := 'dbname';
  TableName := 'tablename';
  EmptyTable;
end;

The important thing to note here is that we need to set the Table&#8217;s active property to false before calling the EmptyTable method.

If we try to empty the table when the table is open (i.e Active is True), then we will be getting an EDBEngineError exception like the following:

Table cannot be opened for exclusive use.

Also we can use another method of the TTable component to delete the table itself provided we have privileges on that database to do that.

The following code will do that:

with Table1 do
begin
  Active := False;
  DatabaseName := 'dbname';
  TableName := 'tablename';
  DeleteTable;
end;

Here also the table must be closed (setting the Active property to false) before calling the DeleteTable method. Otherwise the method will throw an exception.

If we perform this operation on an open table, you will be getting an EDatabaseError exception like the following:
Table1 : Cannot perform this operation on a open dataset.

It&#8217;s always easy to call a method of a component in Delphi; but we should remember some important things before we call that method.

Here with these two methods above, we need to keep in mind two things before calling them:

We should have enough privileges to do that operation on a database where the table resides.
We need to close the table by either calling the TTable&#8217;s close method or setting the Ttable&#8217;s active property to false.

Create an autorun CD

Problem/Question/Abstract:

This is not exactly a Delphi trick, but as a programmer (using any language) some time you might need this

Answer:

what you have to do is just create a text file with the notepad (or whatever) with the following text:

[autorun]
OPEN=myprogram.EXE
ICON=myicon.ICO

of course myprogram.exe is the application that you want to "autorun" and the icon will be the icon for the CD when you put it in that's it, now just save your text file with the name: AutoRun.INF in the root of the CD and you've got your self an autorun CD

Read MS-SQL Error Logs via SQL-DMO into TStrings

Problem/Question/Abstract:

Functions to load a StringList with MS-SQL Server Error Logs via SQL-DMO. MS-SQL DMO is a COM/OLE object that can do many things, in this article we just read the error logs off the server.
There a two overloaded functions, one for Windows Authentication, and another for SQL Authentication. The function returns true if successful. The default log number is 0 (Current Log).

// Windows Authentication

function SqlErrorLog(AStrings: TStrings;
const ASqlServer: string;
ALogNumber: integer = 0): boolean; overload;

// SQL Authentication
function SqlErrorLog(AStrings: TStrings;
const ASqlServer, AUserName, APassword: string;
ALogNumber: integer = 0): boolean; overload;

Example

// Load memo using Default Log 0 and Windows Authentication
if SqlErrorLog(Memo1.Lines, 'BusServer1') then
.....

// Load memo using Log 3 and SQL Authentication
if SqlErrorLog(Memo1.Lines, 'BusServer', 'harry', 'mypass', 3) then
..

Answer:

uses ComObj, Variants; {Variants is for Delphi 7}

// =====================================================
// PRIMITIVE Load MS SQL Server Error Log Function
// =====================================================

function _SqlErrorLog(AObject: OleVariant;
AStrings: TStrings;
const ASqlServer: string;
ALogNumber: integer): boolean;
var
oLog: OleVariant;
bResult: boolean;
i: integer;
begin
try
AObject.Connect(ASqlServer);

try
AStrings.BeginUpdate;
oLog := AObject.ReadErrorLog(ALogNumber);
for i := 1 to oLog.Rows do
AStrings.Add(oLog.GetColumnString(i, 1));
oLog := Unassigned;
finally
AStrings.EndUpdate;
end;

AObject.Disconnect;
bResult := true;
except
bResult := false;
end;

AObject := Unassigned;
Result := bResult;
end;

// =====================================================
// Get SQL Server Log using Windows Authentication
// =====================================================

function SqlErrorLog(AStrings: TStrings;
const ASqlServer: string;
ALogNumber: integer = 0): boolean; overload;
var
oDMO: OleVariant;
bResult: boolean;
begin
AStrings.Clear;

try
oDMO := CreateOleObject('SQLDMO.SQLServer');
oDMO.LoginSecure := true;
bResult := _SqlErrorLog(oDMO, AStrings, ASqlServer, ALogNumber);
except
bResult := false;
end;

Result := bResult;
end;

// =====================================================
// Get SQL Server Log using SQL Authentication
// =====================================================

function SqlErrorLog(AStrings: TStrings;
const ASqlServer, AUserName, APassword: string;
ALogNumber: integer = 0): boolean; overload;
var
oDMO: OleVariant;
bResult: boolean;
begin
AStrings.Clear;

try
oDMO := CreateOleObject('SQLDMO.SQLServer');
oDMO.LoginSecure := false;
oDMO.Login := AUserName;
oDMO.Password := APassword;
bResult := _SqlErrorLog(oDMO, AStrings, ASqlServer, ALogNumber);
except
bResult := false;
end;

Result := bResult;
end;