Change fonts between columns in a TStringGrid

Problem/Question/Abstract:

How to change fonts between columns in a TStringGrid

Answer:

You must write the text to the canvas after setting the font. Use Canvas.TextRect for this:

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
begin
  with Sender as TStringGrid do
  begin
    case aCol of
      0: canvas.font.name := 'Courier New';
      1..5: canvas.font.name := 'Arial';
    end;
    Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top + 2, Cells[ACol, ARow]);
  end;
end;

How to create unique numbers for a primary index field

Problem/Question/Abstract:

Using D4, Paradox 7 and a peer-to-peer network on Win95/ 98, I am currently thinking about the problems of using AutoInc fields as primary indexes to avoid key violations. On balance, I feel that it is probably best to avoid potential problems by choosing an alternative primary index system. But what are the alternatives? Using a DateTime field as the unique primary index or use a number that is incremented in code?

Answer:

If you need a unique number for a primary key create a single-field-single-record table to hold the last used value and call the following function when you need a new number.

function dgGetUniqueNumber(LastNumberTbl: TTable): LongInt;
{Gets the next value from a one field one record table which stores the last used
value in its first field. The parameter LastNumberTbl is the table that contains the last used number.}
const
  ntMaxTries = 100;
var
  I, WaitCount, Tries: Integer;
  RecordLocked: Boolean;
  ErrorMsg: string;
begin
  Result := 0;
  Tries := 0;
  with LastNumberTbl do
  begin
    {Make sure the table contains a record. If not, add one and set the first field to zero.}
    if RecordCount = 0 then
    begin
      Insert;
      Fields[0].AsInteger := 0;
      Post;
    end;
    {Try to put the table that holds the last used number into edit mode. If calling Edit
    raises an exception wait a random period and try again.}
    Randomize;
    while Tries < ntMaxTries do
    try
      Inc(Tries);
      Edit;
      Break;
    except
      on E: EDBEngineError do
        {The call to Edit failed because the record could not be locked.}
      begin
        {See if the lock failed because the record is locked by another user.}
        RecordLocked := False;
        for I := 0 to Pred(E.ErrorCount) do
          if E.Errors[I].ErrorCode = 10241 then
            RecordLocked := True;
        if RecordLocked then
        begin
          {Wait for a random period and try again.}
          WaitCount := Random(20);
          for I := 1 to WaitCount do
            Application.ProcessMessages;
          Continue;
        end
        else
        begin
          {The record lock failed for some reason other than another user has the
          record locked. Display the BDE error stack and exit.}
          ErrorMsg := '';
          for I := 0 to Pred(E.ErrorCount) do
            ErrorMsg := ErrorMsg + E.Errors[I].Message + ' (' + IntToStr(E.Errors[I].ErrorCode) + '). ';
          MessageDlg(ErrorMsg, mtError, [mbOK], 0);
          Exit;
        end;
      end;
    end;
    if State = dsEdit then
    begin
      Result := Fields[0].AsInteger + 1;
      Fields[0].AsInteger := Result;
      Post;
    end
    else
      {If the record could not be locked after the specified number of tries raise an exception.}
      raise Exception.Create('Cannot get next unique number. (dgGetUniqueNumber)');
  end;
end;

Determine the processor speed in MHz

Problem/Question/Abstract:

Determine the processor speed in MHz

Answer:

Here is a handy routine which will return an estimated core processor speed (CPU speed) of your PC. Read the comment to see how to use it.


function GetCpuSpeed: Comp;
{ function to return the CPU clock speed only.                                     }
{ Usage: MessageDlg(Format('%.1f MHz', [GetCpuSpeed]), mtConfirmation, [mbOk], 0); }
var
  t: DWORD;
  mhi, mlo, nhi, nlo: DWORD;
  t0, t1, chi, clo, shr32: Comp;
begin
  shr32 := 65536;
  shr32 := shr32 * 65536;

  t := GetTickCount;
  while t = GetTickCount do
  begin
  end;
  asm
     DB 0FH
     DB 031H
     mov mhi,edx
     mov mlo,eax
  end;

  while GetTickCount < (t + 1000) do
  begin
  end;
  asm
     DB 0FH
     DB 031H
     mov nhi,edx
     mov nlo,eax
  end;

  chi := mhi;
  if mhi < 0 then
    chi := chi + shr32;

  clo := mlo;
  if mlo < 0 then
    clo := clo + shr32;

  t0 := chi * shr32 + clo;

  chi := nhi;
  if nhi < 0 then
    chi := chi + shr32;

  clo := nlo;
  if nlo < 0 then
    clo := clo + shr32;

  t1 := chi * shr32 + clo;

  Result := (t1 - t0) / 1E6;
end;

How to get the free system resources

Problem/Question/Abstract:

How to get the free system resources

Answer:

unit Sysresources;

interface

uses
  Windows, Sysutils;

const
  GFSR_SYSTEMRESOURCES = 0;
  GFSR_GDIRESOURCES = 1;
  GFSR_USERRESOURCES = 2;

function GetSystemResources(typ: Word): Integer;

implementation

var
  hDll: HMODULE;
  pProc: function(typ: word): Integer; stdcall;

function GetSystemResources(typ: word): Integer;
begin
  result := pProc(typ);
end;

function InternalGetSystemresources(typ: Word): Integer; stdcall;
begin
  result := -1;
end;

initialization
  pProc := InternalGetSystemresources;
  if Win32Platform <> VER_PLATFORM_WIN32_NT then
  begin
    hdll := LoadLibrary('rsrc32.dll');
    if hdll <> 0 then
    begin
      @pProc := getProcAddress(hdll, '_MyGetFreeSystemResources32@4');
      if @pProc = nil then
        pProc := InternalGetSystemresources;
    end;
  end;
finalization
  if hDLL <> 0 then
    FreeLibrary(hdll);
end.

How to control the MIDI speaker output volume

Problem/Question/Abstract:

How can I control the MIDI speaker output volume? If that's not directly possible: how can I programmatically open the volume control?

Answer:

First you need to ID the device


tmpreg := TRegistry.Create;
tmpreg.RootKey := HKEY_CURRENT_USER;
tmpreg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Multimedia\MIDIMap', false);


{ ... }
if tmpreg.ValueExists('CurrentInstrument') then
begin
  MidiOutPutDev := tmpreg.ReadString('CurrentInstrument');
end;
tmpreg.destroy;
{ ... }

Then get a handle of the device


amt := MidiOutGetNumDevs;
MidiOutputDevid := -1;
for t := 1 to amt do
begin
  MidiOutGetDevCaps(t - 1, @Midicap, Sizeof(Midicap));
  if Strpas(@MidiCap.szPName) = MidiOutPutDev then
  begin
    MidiOutputDevid := t - 1;
  end;
end;


Then set the volume either master or seperate


procedure SetVolumeMidi(RVolume, LVolume: Cardinal);
begin
  midiOutSetVolume(MidiOutputDevid, (RVolume * 256 * 256) + LVolume);
end;

procedure SetMVolumeWave(Volume: Cardinal);
var
  pl, pr: Cardinal;
begin
  pr := (WRPan * Volume) div 100;
  pl := (WLPan * Volume) div 100;
  waveOutSetVolume(WaveOutputDevid, (pr * 256 * 256) + pl);
end;


Include mmsystem in your Uses clause

How to convert the mouse coordinates into a line and character offset in a TRichEdit

Problem/Question/Abstract:

I am currently trapping the OnMouseMove event, however have run into significant problems converting the mouse coordinates into a line and character offset in a rich edit.

Answer:

procedure TForm1.RichEdit1MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
  Integer);
var
  Point: TPoint;
  Value: LongInt;
  LineNumber: Integer;
  LinePos: Integer;
  Line: string;
begin
  {Get absolute position of character beneath mouse}
  Point.x := X;
  Point.y := Y;
  Value := RichEdit1.Perform(EM_CHARFROMPOS, 0, LParam(@Point));
  if Value >= 0 then
  begin
    {Get line number}
    LineNumber := RichEdit1.Perform(EM_LINEFROMCHAR, Value, 0);
    {Get line position}
    LinePos := Value - RichEdit1.Perform(EM_LINEINDEX, LineNumber, 0);
    {Get line}
    Line := RichEdit1.Lines[LineNumber];
    Label1.Caption := Format('Line: %d Column: %d: %s', [LineNumber, LinePos, Line]);
  end
  else
  begin
    Label1.Caption := EmptyStr;
  end;
end;

This only works for RichEdits.

How to check if a control is partially covered by another window

Problem/Question/Abstract:

Is there a way that I can know if there is a 'Stay On Top' form owned by another application partially covering my control?

Answer:

You would have to iterate over all windows above yours in Z-order and check for each window you find if it has the WS_EX_TOPMOST exstyle set and is visible. If it has, you have to get its window rectangle (GetWindowRect) and test if that overlaps your window. Example:

procedure TForm1.Button1Click(Sender: TObject);

  function IsTopmost(wnd: HWND): Boolean;
  begin
    Result := (GetWindowLong(wnd, GWL_EXSTYLE) and WS_EX_TOPMOST) <> 0;
  end;

  procedure logWindowInfo(wnd: HWND);
  const
    visString: array[Boolean] of string = ('not ', '');
  var
    buffer: array[0..256] of Char;
    r: TRect;
  begin
    if wnd = 0 then
      exit;
    GetClassname(wnd, buffer, sizeof(buffer));
    memo1.lines.add(format(' Window of class %s ', [buffer]));
    Windows.getWindowrect(wnd, r);
    memo1.lines.add(format(' at (%d,%d):(%d,%d)', [r.left, r.top, r.right,
      r.bottom]));
    memo1.lines.add(format(' Window is %svisible',
      [visString[IsWindowVisible(wnd)]]));
    memo1.lines.add(format(' Window is %stopmost', [visString[IsTopmost(wnd)]]));
  end;

var
  wnd: HWND;
begin
  memo1.clear;
  wnd := handle;
  repeat
    wnd := GetNextWindow(wnd, GW_HWNDPREV);
    LogWindowInfo(wnd);
  until
    wnd = 0;
  memo1.lines.add('End log');
end;

An easier approach would be to make your own window topmost while it is active.

How to do greyscale dithering in Delphi

Problem/Question/Abstract:

How to do greyscale dithering in Delphi

Answer:

procedure Greyscale(dib8, dib24: TFastDIB; Colors: Byte);
type
  TDiv3 = array[0..767] of Byte;
  TScale = array[0..255] of Byte;
  TLineErrors = array[-1.. - 1] of DWord;
  PDiv3 = ^TDiv3;
  PScale = ^TScale;
  PLineErrors = ^TLineErrors;
var
  x, y, i, Ln, Nxt: Integer;
  pc: PFColor;
  pb: PByte;
  Lines: array[0..1] of PLineErrors;
  Div3: PDiv3;
  Scale: PScale;
  pti: PDWord;
  dir: ShortInt;
begin
  dib8.FillColors(0, Colors, tfBlack, tfWhite);
  New(Div3);
  pb := Pointer(Div3);
  for i := 0 to 255 do
  begin
    pb^ := i;
    Inc(pb);
    pb^ := i;
    Inc(pb);
    pb^ := i;
    Inc(pb);
  end;
  New(Scale);
  pb := Pointer(Scale);
  x := (Colors shl 16) shr 8;
  y := x;
  for i := 0 to 255 do
  begin
    pb^ := y shr 16;
    Inc(y, x);
    Inc(pb);
  end;
  GetMem(Lines[0], 24 * (dib24.Width + 2));
  GetMem(Lines[1], 24 * (dib24.Width + 2));
  pc := PFColor(dib24.Bits);
  for x := 0 to dib24.Width - 1 do
  begin
    Lines[0, x] := Div3[pc.r + pc.g + pc.b] * 16;
    Inc(pc);
  end;
  pc := Ptr(Integer(pc) + dib24.Gap);
  dir := 1;
  for y := 1 to dib24.Height do
  begin
    Nxt := y mod 2;
    Ln := 1 - Nxt;
    if y < dib24.Height then
    begin
      for x := 0 to dib24.Width - 1 do
      begin
        Lines[Nxt, x] := Div3[pc.r + pc.g + pc.b] * 16;
        Inc(pc);
      end;
      pc := Ptr(Integer(pc) + dib24.Gap);
    end;
    x := 0;
    if dir = -1 then
      x := dib24.Width - 1;
    pti := @Lines[Ln, x];
    pb := @dib8.Pixels8[y - 1, x];
    while ((x > -1) and (x < dib24.Width)) do
    begin
      pti^ := pti^ div 16;
      if pti^ > 255 then
        pti^ := 255
      else if pti^ < 0 then
        pti^ := 0;
      pb^ := Scale[pti^];
      i := pti^ - dib8.Colors[pb^].r;
      if i <> 0 then
      begin
        Inc(Lines[Ln, x + dir], i * 7);
        Inc(Lines[Nxt, x - dir], i * 3);
        Inc(Lines[Nxt, x], i * 5);
        Inc(Lines[Nxt, x + dir], i);
      end;
      Inc(pb, dir);
      Inc(pti, dir);
      Inc(x, dir);
    end;
    Inc(pb, dib8.Gap);
    dir := -dir;
  end;
  Dispose(Lines[0]);
  Dispose(Lines[1]);
  Dispose(Scale);
  Dispose(Div3);
end;

How to check if a drive is ready

Problem/Question/Abstract:

How to check whether there is a floppy or CD inside the drives?

Answer:

function DiskInDrive(const Drive: char): Boolean;
var
  DrvNum: byte;
  EMode: Word;
begin
  result := false;
  DrvNum := ord(Drive);
  if DrvNum >= ord('a') then
    dec(DrvNum, $20);
  EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    if DiskSize(DrvNum - $40) <> -1 then
      result := true
    else
      messagebeep(0);
  finally
    SetErrorMode(EMode);
  end;
end;

How to display the record number in the indicator rectangle of a TDBGrid

Problem/Question/Abstract:

How to display the record number in the indicator rectangle of a TDBGrid

Answer:

Solve 1:

You can show a record number (in case the dataset supports one) in the indicator's rectangle (check if your grid has a dgIndicator in its Options):

{ ... }
TMyDBGrid = class(TDBGrid)
protected
  procedure DrawCell(ACol: Integer; ARow: Integer; ARect: TRect;
    AState: TGridDrawState); override;
  procedure SetColumnAttributes; override;
end;

{ ... }

procedure TMyDBGrid.DrawCell(ACol: Integer; ARow: Integer; ARect: TRect;
  AState: TGridDrawState);
var
  XInt: integer;
begin
  inherited DrawCell(ACol, ARow, ARect, AState);
  if (ACol = 0) and (dgIndicator in Options) and Assigned(DataLink.DataSet)
    and (DataLink.DataSet.Active) then
  begin
    if dgTitles in Options then
      if ARow = 0 then
        exit
      else
        dec(ARow);
    Canvas.FillRect(ARect);
    DataLink.ActiveRecord := ARow;
    XInt := DataLink.DataSet.RecNo;
    Canvas.TextOut(ARect.Left, ARect.Top, intToStr(XInt));
  end;
end;

procedure TMyDBGrid.SetColumnAttributes;
begin
  inherited SetColumnAttributes;
  if (dgIndicator in Options) then
    ColWidths[0] := 20;
end;

This code worked fine for Paradox tables with BDE datasets and for Interbase tables with InterBase Express's TIBTable.


Solve 2:

Drop a TDBGrid on a form. Add all the required columns through the columns editor. Set the fieldname and title caption. Add an extra column and set it right at the top of the columns list, so that this will appear as the first column to display the record number. Don't set a field name for this column. Set any title caption like 'Row No'. Also make sure that the extra added column for displaying the row number is read-only.

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  if DataCol = 0 then
  begin
    if table1.State = dsInsert then
    begin
      if Table1.RecNo < 0 then
        DBGrid1.Canvas.TextOut(rect.Left + 2, rect.Top + 3,
                                 IntTostr(Table1.recordcount + 2))
      else
        DBGrid1.Canvas.TextOut(rect.Left + 2, rect.Top + 3, IntTostr(Table1.RecNo));
    end
    else
      DBGrid1.Canvas.TextOut(rect.Left + 2, rect.Top + 3, IntTostr(Table1.RecNo));
  end;
end;

procedure TForm1.DBGrid1ColEnter(Sender: TObject);
begin
  if DBGrid1.SelectedIndex = 0 then
    DBGrid1.SelectedIndex := 1;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  DBGrid1.SelectedIndex := 1;
end;

Understanding what files are and choosing a Delphi file type - part 2

Problem/Question/Abstract:

What is a File? How are they stored? What format is best for my project? - The second part of a series by Philip Rayment

Answer:

Which file type should I use?

By now I hope you understand that, in theory, you can use any Delphi file type to read and write any file (although using a TextFile to read a file that is not text generally won't work very well). You could, for example, use an untyped file or a file of char, to read and write ASCII text. You could, in theory, use an untyped file to write an executable program file.

In practice, of course, particular file types work better with some files than others. If your file contains just strings of text, TextFile is the obvious choice. Similarly, if your file contains data of a single type (including records), a typed file is the way to go. However, there are always going to be those occasions when you want a file to contain data of various types. For example, a Windows resource file might contain some icons, some bitmaps, and some cursors.

Let us have a look at examples of how to save some employee data with each of the three file types. We will include a file version number at the start of the file. Unless you are sure that your file format will never change, a file version number is a good idea so that your program will know what format the data is in. The Untyped and Text files will also include a value indicating the number of records. This is not essential but assists with reading in the information.

The Typed file does not need this as the number of records can be easily calculated by dividing the size of the file by the size of the type. There is of course more than one way to write and read files; the examples below are not necessarily the only ways. In each of these examples let's assume the following declarations:

type
  ��PersonRecord� = �packed�record
    ��ChistianName: �string[15];
  ����Surname: ������string[15];
  ����Address1: �����string[30];
  ����Address2: �����string[30];
  ����Town: ���������string[15];
  ����Postcode: �����word;
  �� {zip code for Americans}
  ����Birthdate: ����Tdate;
  ����YearsService: �byte
  ����ID: �����������word;
  ��End;
  ��� {PersonRecord} {this record is 114 bytes long}

var
  People: array�of�PersonRecord;

const
  ���LatestFileVersion� = �3;

We will use two records with the following values so that we can work out the file sizes for each method:


Record 1
Record 2
ChistianName
Fred
Josephine
Surname
Smith
Black-Forest
Address1
13 Railway Crescent
Flat 16
Address2

144 Carrington Highway
Town:
Smallville
Williamstown East
Postcode
9053
8405
Birthdate
29-2-1952
25-12-1970
YearsService
15
3
ID
14587
34423


In the code examples, the figures in square brackets are the bytes written by each statement for each of the two records.

Example 1: Untyped File

procedure�WriteFile(filename:string);
var
��fil:�file;
��i:�integer;
��num:�word;�����{allows up to 65535 records}
const��ver:����byte�=�LatestFileVersion;

���procedure�WriteString(s:ShortString);
���begin���{WriteString}
�����BlockWrite(fil,s,succ(length(s));
���end;���{WriteString}

begin���{WriteFile}
���assignFile(fil,filename);�rewrite(fil,1); {Create the file}
���BlockWrite(fil,ver,sizeof(ver));                     [1]{Write the file version}
���num:=length(People);
���BlockWrite(fil,num,sizeof(num));                     [2]{Write the number
                                                                                                                                                                                                                                of records}
���for�i:=0�to�high(people)�do
�������with�people[i]�do�begin{write the data}
���������WriteString(ChristianName);                    [5,9]
���������WriteString(Surname);                          [6,13]
���������WriteString(Address1);                         [20,8]
���������WriteString(Address2);                         [1,23]
���������WriteString(Town);                             [11,18]
���������BlockWrite(fil,Postcode,sizeof(Postcode));[2,2]
���������BlockWrite(fil,Birthdate,sizeof(Birthdate));[8,8]
���������BlockWrite(fil,YearsService,sizeof(YearsService)); [1,1]
���������BlockWrite(fil,ID,sizeof(ID));                     [2,2]
�������end;���{with}
���CloseFile(fil);
end;���{WriteFile}

procedure�ReadFile(filename:string);
var����fil:����file;
�������i:������integer;
�������num:����word;�����{allows up to 65535 records}
                         ver:����byte;

���function�ReadString:ShortString;
���begin���{ReadString}
�����BlockRead(fil,result,1);               {Read the length of the string}
�����BlockRead(fil,s[1],length(s));         {Read the string itself}
���end;���{ReadString}

begin���{ReadFile}
���assignFile(fil,filename);�reset(fil,1);  {Open the file}
���BlockRead(fil,ver,sizeof(ver));      {Read the file version}
���BlockRead(fil,num,sizeof(num));      {Read the number of records}
���SetLength(People,num);
���for�i:=0�to�high(people)�do
�������with�people[i]�do�begin��{Read the data}
���������ChristianName:=ReadString;
���������Surname:=ReadString;
���������Address1:=ReadString;
���������Address2:=ReadString;
���������Town:=ReadString;
���������BlockRead(fil,Postcode,sizeof(Postcode));
���������BlockRead(fil,Birthdate,sizeof(Birthdate));
���������BlockRead(fil,YearsService,sizeof(YearsService));
���������BlockRead(fil,ID,sizeof(ID));
�������end;���{with}
���CloseFile(fil);
end;���{WriteFile}

Analysis

The total file size is 143 bytes, the smallest of our examples, but the most complex to write. We had to use a temporary variable (ver) as the BlockWrite statement requires variables, not constants. If we later need to increase the maximum length of a surname, for example, changing the record declaration is all that is required.

Example 2: File of Record

procedure�WriteFile(filename:string);
var
��fil:����file�of�PersonRecord;
��i:������integer;
��rec:����PersonRecord
begin���{WriteFile}
���assignFile(fil,filename);�rewrite(fil); {Create file}
���fillchar(rec,sizeof(rec),0);  {clear fields (not necessary)}
���rec.postcode:=LatestFileVersion;       {any suitable numeric field would do}
���Write(fil,rec);              [114]       {write a record containing the
                                                                                                                                                                        file version}
���for�i:=0�to�high(people)�do
    �Write(fil,People[i]);      [114,114]  {Write the data}
���CloseFile(fil);
end;���{WriteFile}

procedure�ReadFile(filename:string);
var�fil:����file�of�PersonRecord;
  i:�integer;
��rec:�PersonRecord
��ver:�byte;
begin���{ReadFile}
��assignFile(fil,filename);�reset(fil);��{Open the file}
��Read(fil,rec);��{Read a record containing the file version...}
��ver:=rec.postcode;��{... and extract the file version from it}
��SetLength(people,pred(filesize(fil)�div�sizeof(rec));���{calculate number of records.}
��for�i:=0�to�high(people)�do�Read(fil,People[i]);��{Read the data}
��CloseFile(fil);
end;���{ReadFile}

Analysis

The total file size is 342 bytes, by far the largest of our examples, but also the easiest to write. The space is in the unused parts of the strings, which were designed to hold the largest likely names and addresses, plus in the additional record we used at the start just to hold the file version. If we decide later that we need to allow longer strings, we not only need to change the record definition, but also all the files already written this way . Thus while it is the easiest to write, it is probably the hardest to change.

How to clip the client area of a form using regions

Problem/Question/Abstract:

I'm trying to produce a form that has transparent areas in it (no border or title with odd shape edges/ holes). I've successfully done this; the problem I'm having is the refreshing of the transparent areas. I have an idea form the conceptual point of what to do, but was hoping some could let me know if this sounds like it would work, and any technical information on how to do it.

I want to pass the WM_PAINT message that my form gets on to the window(s) underneath my form, so that those windows refresh themselves. Then, only after the window(s) beneath my form finish refreshing, I want to refresh my form (act on the WM_PAINT message in a normal manner).

Answer:

While the method you are attempting to use could work, it's much easier to use SetWindowRgn().

This API function will associate an HRGN with your window. This region will be used to determine the area your window is allowed to paint in:


procedure CutOutClient(pForm: TForm);
var
  rgnCenter: HRGN;
  rcWindow: TRect;
  rcClient: TRect;
begin
  GetWindowRect(pForm.Handle, rcWindow);
  Windows.GetClientRect(pForm.Handle, rcClient);
  MapWindowPoints(pForm.Handle, HWND_DESKTOP, rcClient, 2);
  OffsetRect(rcClient, -rcWindow.Left, -rcWindow.Top);
  rgnCenter := CreateRectRgnIndirect(rcClient);
  try
    SetWindowRgn(pForm.Handle, rgnCenter, IsWindowVisible(pForm.Handle));
  finally
    DeleteObject(rgnCenter);
  end;
end;


This procedure should clip the client area from your form. To extend this, you simply need to create a different region. See the CreateEllipticRgn, CreatePolygonRgn, CreateRectRgn, and CombineRgn (as well as a few others).

How to print the content of a TRichEdit centered on a page

Problem/Question/Abstract:

I have a TDBRichEdit component in D4 and I would like to allow the user to print the selected record centered on a page.

Answer:

It boils down to measuring the text height required for a given width of the printout. This can be done using the EM_FORMATRANGE message, which can also be used to print the formatted text. Here is an example that you can use as a starting point. It measures the text to be able to frame it on the page, you can use the calculated height to vertically center the text by adding to the top border. Printing rich edit contents using EM_FORMATRANGE and EM_DISPLAYBAND:

procedure TForm1.Button2Click(Sender: TObject);
var
  printarea: Trect;
  x, y: Integer;
  richedit_outputarea: TRect;
  printresX, printresY: Integer;
  fmtRange: TFormatRange;
begin
  Printer.beginDoc;
  try
    with Printer.Canvas do
    begin
      printresX := GetDeviceCaps(handle, LOGPIXELSX);
      printresY := GetDeviceCaps(handle, LOGPIXELSY);
      Font.Name := 'Arial';
      Font.Size := 14;
      Font.Style := [fsBold];
      {1 inch left margin / 1.5 inch top
                        margin / 1 inch right margin / 1.5 inch bottom margin}
      printarea := Rect(printresX, printresY * 3 div 2, Printer.PageWidth - printresX,
        Printer.PageHeight - printresY * 3 div 2);
      x := printarea.left;
      y := printarea.top;
      TextOut(x, y, 'A TRichEdit print example');
      y := y + TextHeight('Ag');
      Moveto(x, y);
      Pen.Width := printresY div 72; {1 point}
      Pen.Style := psSolid;
      Pen.Color := clBlack;
      LineTo(printarea.Right, y);
      Inc(y, printresY * 5 div 72);
      {Define a rectangle for the rich edit text.
                        The height is set to the maximum.
                        But we need to convert from device units to twips,
                  1 twip = 1/1440 inch or 1/20 point.}
      richedit_outputarea := Rect((printarea.left + 2) * 1440 div printresX, y * 1440
        div printresY,
        (printarea.right - 4) * 1440 div printresX, (printarea.bottom) * 1440 div
          printresY);
      {Tell rich edit to format its text to the printer.
                                First set up data record for message:}
      fmtRange.hDC := Handle; {printer handle}
      fmtRange.hdcTarget := Handle; {printer handle}
      fmtRange.rc := richedit_outputarea;
      fmtRange.rcPage := Rect(0, 0, Printer.PageWidth * 1440 div printresX,
        Printer.PageHeight * 1440 div printresY);
      fmtRange.chrg.cpMin := 0;
      fmtRange.chrg.cpMax := richedit1.GetTextLen - 1;
      {First measure the text, to find out how high the format rectangle will be.
                        The call sets fmtrange.rc.bottom to the actual height required,
                        if all characters in the selected
      range will fit into a smaller rectangle,}
      richedit1.Perform(EM_FORMATRANGE, 0, Longint(@fmtRange));
      {Draw a rectangle around the format rectangle}
      Pen.Width := printresY div 144; {0.5 points}
      Brush.Style := bsClear;
      Rectangle(printarea.Left, y - 2, printarea.right, fmtrange.rc.bottom * printresY
        div 1440 + 2);
      {Now render the text}
      richedit1.Perform(EM_FORMATRANGE, 1, Longint(@fmtRange));
      {and print it}
      richedit1.Perform(EM_DISPLAYBAND, 0, Longint(@fmtRange.rc));
      y := fmtrange.rc.bottom * printresY div 1440 + printresY * 5 div 72;
      {Free cached information}
      richedit1.Perform(EM_FORMATRANGE, 0, 0);
      TextOut(x, y, 'End of example.');
    end;
  finally
    Printer.EndDoc;
  end;
end;

How to retrieve the text of a single-line edit control

Problem/Question/Abstract:

How to retrieve the text of a single-line edit control

Answer:

Solve 1:

{ ... }
var
  FNEText: array[0..127] of Char;
begin
  SendMessage(Edit1.Handle, WM_GETTEXT, Sizeof(FNEText), Integer(@FNEText));
  { ... }

Solve 2:

{ ... }
var
  buffer: array[0..$10000] of Char;
  len: Integer;
begin
  buffer[0] := #0;
  len := SendMessage(hFocusWin, WM_GETTEXTLENGTH, 0, 0);
  if len > 0 then
    SendMessage(hFocusWin, WM_GETTEXT, len + 1, LPARAM(@buffer));
  memo1.SetTextBuf(buffer);
  { ... }

Reading a Field's Value into a TStrings Property

Problem/Question/Abstract:

Reading a Field's Value into a TStrings Property

Answer:

Any programming environment is not without its faults, and Delphi is no exception to this. And while I consider myself to be one of the biggest fans of Delphi, there are still things that are either missing or are so poorly implemented in it, that they make me want to pull my hair out! Of those "things" there are two components that make me rankle: The TDBLookupListBox and the TDBComboBox. On the surface, these components have the potential to be incredibly useful. Load values from a field from one table so they can be used in another. Unfortunately, most people, including myself, have had only marginal success with them. It's not because they don't work, it's just that I feel they're poorly implemented.

Typically, property names should give a good indication of what a property represents. For instance, it's very clear in DataSet components that DatabaseName actually means a database name. Unfortunately in the case of the DBLookup components, the property names are a bit misleading, and it makes using these components a bit unwieldy. For instance, both components have the properties, Field and DataField. If you didn't know any better, you'd think that Field is the lookup field and DataField is the field into which the lookup value is applied. Actually, the converse is true. Furthermore, while the DBLookup components offer incredible flexibility by allowing you specify different display fields in place of the actual data field that will be used for inserting the value, providing these introduce a bit of complexity that while useful, is poorly implemented by, yet again, confusing property names.

Don't get me wrong here. I actually use these components quite a bit becasue I understand how they work and have had a lot of practice using them various applications. But there are some applications where I don't really need lookup and insert capabilities, only lookup capabilities. After all, the DBLookup components are for data entry, and not all applications are data-entry applications. For instance, many of my applications are specifically geared towards data retrieval. But for ease of use, I employ a lot of list boxes and combo boxes based on lookup table data to aid in the selection criteria process. When I'm ready to execute a retrieval, I'm not interested in grabbing field values from a table, all I want to do is get the entered value in the edit boxes or the selected or checked item(s) in a list or combo directly.

So in these cases, I employ a simple list load mechanism that reads data from a table's field and inserts the values into some sort of TStrings property. Mind you, it doesn't have the flexibility of a DBLookup component, but its mere simplicity makes it a much more attractive alternative when doing pure reference types of applications. That said, you'll probably kick me for taking so long to lead into the code, which happens to be moronically simple.

Below are two procedures that I use to load TStrings types of properties. The first employs a TTable to get the values, the second employes a TQuery. I'll discuss the particulars following the code.

// ======================================================================
// This procedure will load a list box with values taken from a specific
// field in a TTable.
// ======================================================================

procedure DBLoadListTbl(dbSource, {database name}
  tblSource, {table name}
  fldName: string; {field name to load from}
  const LBox: TStrings); {List Box on Form}

var
  SourceTbl: TTable;
begin

  SourceTbl := TTable.Create(Application); {Create an instance of sourceTbl}

  with SourceTbl do
  begin
    Active := False;
    DatabaseName := dbSource;
    TableName := tblSource;
    try
      Open;
      First;
      while not EOF do
      begin
        LBox.Add(SourceTbl.FieldByName(fldName).AsString);
        Next;
      end;
    finally
      Free;
    end;
  end;
end;

// =======================================================================
// This is a variant on the procedure above. Instead, it uses a TQuery
// =======================================================================

procedure DBLoadListQry(tblSource, {table name}
  fldName: string; {field name to load from}
  const List: TStrings); {Any TStrings}
var
  qry: TQuery;
begin
  qry := TQuery.Create(nil);
  with qry do
  begin
    Active := False;
    DatabaseName := ExtractFilePath(tblSource);
    SQL.Add('SELECT DISTINCT d."' + fldName + '" ');
    SQL.Add('FROM "' + tblSource + '" d');
    try
      Open;
      while not EOF do
      begin
        List.Add(FieldByName(fldName).AsString);
        Next;
      end;
    finally
      Free;
    end;
  end;
end;

Now you might be wondering why in the world I have two procedures that perform almost identical tasks. The reason for this is that with the DBLoadListTbl procedure, there is a complete disregard for duplicate value checking. Simply put, the first procedure has the potential to include duplicate values. The second procedure, DBLoadListQry, on the other hand, employs a SELECT DISTINCT query to remove duplicates. I know, it could be argued that I could probably combine the two procedures into a single one that does duplicate checking, but why bother? While it would probably be much more elegant to do something like that, sometimes just sheer simplicity makes for a much more attractive path to follow. So rather than create a procedure that has a bunch of duplication checking logic, I employ two procedures: One that allows duplicates, another that disallows duplicates. Both of these calls are quick, painless, and don't require a lot thought to implement. And in today's world of short deadlines, I'll take the most simple road over the more complex, elegant solution any day.

Oracle and master-detail queries

Problem/Question/Abstract:

Oracle and master-detail queries

Answer:

Just the other day I was writing an application that had master-detail queries, using the TQuery component. The queries were made against an Oracle 8 database using BDE and Delphi 3, but the problem was also present on Oracle 7 and in different oracle set ups. The picture was the following:

QUERY1 (master):

SELECT
   A.NAME, A.CODE, B.AREA
FROM
   CLIENTS A, AREAS B
WHERE
   (A.AREACODE = B.CODE)

Note: CODE is CHAR(10)

QUERY2 (set as detail of QUERY1):

SELECT
   A.ORDERNUM, A.DATE, A.VALUE
FROM
   ORDERS A
WHERE
   (A.CLIENTCODE = :CODE)

Note: CLIENTCODE is CHAR(10)

The problem is that even 'though all the clients with a valid AREACODE would be listed, no order for that client would be listed, even if there were data in the ORDERS table for all the customers. The QUERY2 dataset was always empty (yes, it was Active).

FIXED QUERY2 (set as detail of QUERY1):

SELECT
   A.ORDERNUM, A.DATE, A.VALUE
FROM
   ORDERS A
WHERE
   (RTRIM(A.CLIENTCODE) = RTRIM(:CODE))

This fixed once and for all the problem, and all the orders for each customer were correctly returned by the query. It seemed that when the parameter was passed, it's data type was changed, or some padding was added to the field. Anyway, trimming both fields and comparing only the data part worked.

How to assign a TImage to a TBitmap at runtime

Problem/Question/Abstract:

Is it possible to assign a TImage.picture (a JPEG image) to a different TBitmap (created at runtime)? I want to copy the content of a TImage to another bitmap, but it seems to only works for .bmp files.

Answer:

I've done this without any problems. One thing to make sure is that the JPEG unit is in the uses clause. If I understand you correctly you want to do something like:

{ ... }
b := TBitmap.Create;
try
  b.Assign(Image1.Picture.Graphic);
  Image2.Picture.Graphic := b;
finally
  b.Free;
end;

Where the Image1 graphic is a TJPEGImage. This code works for me as long as the JPEG is in
the uses clause.

How to check if a folder contains subfolders

Problem/Question/Abstract:

How to check if a folder contains subfolders

Answer:

function HasSubDirs(dir: string): boolean;
var
  sr: TSearchRec;
begin
  result := false;
  dir := IncludeTrailingBackslash(dir);
  if FindFirst(dir + '*.*', faAnyfile, sr) = 0 then
  begin
    repeat
      result := (sr.attr and faDirectory <> 0) and (sr.name <> '.') and (sr.name <>
        '..');
    until
      result or (FindNext(sr) <> 0);
    FindClose(sr);
  end;
end;

TCollection The Class for Master Detail Relations

Problem/Question/Abstract:

Getting A master Detail Relation in a component on a way it's easely streamed.
Using a TStream Class Decendant

Answer:

The collection Class is one of my favorit when it comes to storing multiple Data with one component its even posible to include the Collection in its own item making it useful for recursion (The Collection Can have a item withs can hold a other collection.

If you want the standard Editor for Collections u have to use a TOwnedCollection i think its ijn the unit Classes from delphi 4 but if u have D3 u need to Make that class first like this

TOwnedCollection = class(TCollection)
private
  FOwner: TPersistent;
protected
  function GetOwner: TPersistent; override;
public
  // Fil in the AOwner in The Fowner proeprty on the Create Constructor .
  constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
end;

Heres a Example Of a collection That does that

unit Unit1;

interface

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

type
  TMyCollection = class(TOwnedCollection)

  end;

  TMyCollectionItem = class(TCollectionItem)
  private
    FANummer: Integer;
    FAString: string;
    FMoreCollections: TMyCollection;
    procedure SetANummer(const Value: Integer);
    procedure SetAString(const Value: string);
    procedure SetMoreCollections(const Value: TMyCollection);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
  published
    property AString: string read FAString write SetAString;
    property ANummer: Integer read FANummer write SetANummer;
    property MoreCollections: TMyCollection read FMoreCollections write
      SetMoreCollections;
  end;

  TCollectionWrapper = class(TComponent)

  private
    FCollection: TMyCollection;
    procedure SetCollection(const Value: TMyCollection);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

  published
    property Collection: TMyCollection read FCollection write SetCollection;
  end;

implementation

{ TMyCollectionItem }

constructor TMyCollectionItem.Create(Collection: TCollection);
begin
  inherited;
  FMoreCollections := TMyCollection.Create(self, TMyCollectionItem);
end;

destructor TMyCollectionItem.Destroy;
begin
  FMoreCollections.free;
  inherited;

end;

procedure TMyCollectionItem.SetANummer(const Value: Integer);
begin
  FANummer := Value;
end;

procedure TMyCollectionItem.SetAString(const Value: string);
begin
  FAString := Value;
end;

procedure TMyCollectionItem.SetMoreCollections(const Value: TMyCollection);
begin
  FMoreCollections := Value;
end;

{ TCollectionWrapper }

constructor TCollectionWrapper.Create(AOwner: TComponent);
begin
  inherited;
  FCollection := TMyCollection.Create(self, TMyCollectionItem);
end;

destructor TCollectionWrapper.Destroy;
begin
  FCollection.free;
  inherited;

end;

procedure TCollectionWrapper.SetCollection(const Value: TMyCollection);
begin
  FCollection := Value;
end;

end.

This is how you could addres it Run time

procedure TForm1.Button1Click(Sender: TObject);
var
  ACollection: TCollectionWrapper;
begin
  ACollection := TCollectionWrapper.Create(Self);
  try
    // Default add gives u a TCollectionItem So u need to cast it
    with TMyCollectionItem(ACollection.Collection.Add()) do
    begin
      AString := 'Hallo';
      ANummer := 5;
      MoreCollections.add;

    end;

  finally
    ACollection.Free;
  end;
end;

If you register this component u will be able to use the default Collection Editor Design time

Component Download: http://www.xs4all.nl/~suusie/Pieter/Programs/CollectionComponent.zip

Find the intersection of two polylines

Problem/Question/Abstract:

How to find the intersection of two polylines

Answer:

Solve 1:

You have to intersect each polygon segment set which has a collision of their overlapping rectangles defined by the start and end point of each segment except neigboring segments. That means m-1 * n-1 segments are possible. To make a fast overlapping (collision) set I use a xy hash tree based on quadtree decomposition of the segments. Here is the code for the line intersection:

{XYIntersect Container Intersection for 2 dimensional segments
XII/2001 TriplexWare; Written by A.Weidauer

Abstract: Representation for 2-dimensional segment intersections
Author: Alexander Weidauer (alex.weidauer@huckfinn.de)
Created: December 2001
Lastmod: December 2001

The Unit delivers a 2-dimensional segment intersection for several objects
represented by basic data types for I/O}

unit UXYIntersect;

interface

uses
  UConst; {Basic datatype definitions. See further down the page.)

{The function checks a possible segmentation of two segments. The first is defined by
the coordinate set S1( P1(x1, y1): P2(x2, y2)) and the second is
defined S2( P3(x3, y3): P4(x4, y4)) where P1, P2, P3, P4 be the points.
OutX and OutY represent the intersection coordinates and are only valid if
the function turns back the value TRUE. If the segments are paralell the flag
is set to TRUE and if the the segmets are paralell and overlapping eachother
then OutX, OutY keeping the heavy point of the 4 coordinates sets.
In this case you have to check the intervall borders.
The solution of the intersection is NOT a point, it is a SEGMENT again.}

function Isec(x1, y1, x2, y2, x3, y3, x4, y4: TDouble; var OutX, OutY: TDouble;
  var ParallelFlag: TBoolean): TBoolean;

implementation

function Isec(x1, y1, x2, y2, x3, y3, x4, y4: TDouble; var OutX, OutY: TDouble;
  var ParallelFlag: TBoolean): TBoolean;
var
  delta, rmu, l1, l2, l3: TDouble;
begin
  OutY := 0;
  OutX := 0;
  ParallelFlag := False;
  x2 := x2 - x1;
  y2 := y2 - y1;
  x4 := x4 - x3;
  y4 := y4 - y3;
  delta := x2 * y4 - y2 * x4;
  {First case segments are paralell !}
  if abs(delta) < 1 E - 8 then
  begin
    ParallelFlag := False;
    x2 := x2 + x1;
    x4 := x4 + x3;
    y2 := y2 + y1;
    y4 := y4 + y3;
    l1 := sqrt((x2 - x1) * (x2 - x1) + (y2 - y1) * (y2 - y1));
    l2 := sqrt((x3 - x1) * (x3 - x1) + (y3 - y1) * (y3 - y1));
    l3 := sqrt((x3 - x2) * (x3 - x2) + (y3 - y2) * (y3 - y2));
    if (l1 = l2 - l3) or (l1 = l2 + l3) then
    begin
      Result := true;
      Parallelflag := true;
      OutX := (x1 + x2 + x3 + x4) / 4;
      OutY := (y1 + y2 + y3 + y4) / 4;
    end
    else
      Result := False;
    Exit;
  end;
  {End of parallel case}
  rmu := ((x3 - x1) * y4 - (y3 - y1) * x4) / delta;
  if (rmu > 1) or (rmu < 0) then
  begin
    isec := False;
    Exit;
  end;
  OutX := x1 + RMU * x2;
  Outy := y1 + RMU * y2;
  x2 := x2 + x1;
  x4 := x4 + x3;
  y2 := y2 + y1;
  y4 := y4 + y3;
  if x1 > x2 then
    SwapDouble(x1, x2);
  if y1 > y2 then
    SwapDouble(y1, y2);
  if x3 > x4 then
    SwapDouble(x3, x4);
  if y3 > y4 then
    SwapDouble(y3, y4);
  {Rangecheck of the solution}
  if (outx > x2) or (outx < x1) or (outx > x4) or (outx < x3) or (outy > y2)
    or (outy < y1) or (outy > y4) or (outy < y3) then
  begin
    Result := False;
    exit;
  end;
  Result := True;
end;

end.

{Basic Datatype and file extention definitions
XII/2001TriplaxWare; Written by A.Weidauer

Abstract: Basic Datatype and file extention definitions
Author: Alexander Weidauer (alex.weidauer@huckfinn.de)
Created: December 2001
Lastmod: December 2001

The Unit delivers basic data types for I/O and their file extentions.}

unit UConst;

interface

const
  {registry destination set}
  cStorageName = 'Software\tsWB';
  {Maximal read buffer size for blocked bufferd reading}
  cMaxReadBuffer = 32000;
  {Maximal write buffer size for blocked bufferd writing}
  cMaxWriteBuffer = 32000;

type
  {Type encapsulation Boolean}
  TBoolean = Boolean;
  {Type encapsulation String}
  TString = string;
  {Type encapsulation Byte 8 Bit}
  TByte = Byte;
  {Type encapsulation Word 16 Bit}
  TWord = Word;
  {Type encapsulation LongWord 32 Bit}
  TLongWord = LongWord;
  {Type encapsulation SmallInt signed 8 Bit}
  TInt08 = SmallInt;
  {Type encapsulation Integer signed 16 Bit}
  TInt16 = ShortInt;
  {Type encapsulation Integer signed 32 Bit}
  TInt32 = LongInt;
  {Type encapsulation Integer signed 32 Bit as common integer}
  TInteger = TInt32;
  {Type encapsulation Integer signed 64 Bit}
  TInt64 = Int64;
  {Type encapsulation Single 4 Byte}
  TSingle = Single;
  {Type encapsulation Real 6 Byte}
  TReal = Real48;
  {Type encapsulation Double 8 Byte}
  TDouble = Double;
  {Type encapsulation Double 10 Byte}
  TExtended = Extended;
  {Swap data if a > b for String}
procedure SwapString(var a, b: TString);
{Swap data if a > b for TByte}
procedure SwapByte(var a, b: TByte);
{Swap data if a > b for TWord}
procedure SwapWord(var a, b: TWord);
{Swap data if a > b for TLongWord}
procedure SwapLongWord(var a, b: TLongWord);
{Swap data if a > b for TInt08}
procedure SwapInt08(var a, b: TInt08);
{Swap data if a > b for TInt16}
procedure SwapInt16(var a, b: TInt16);
{Swap data if a > b for TInt32}
procedure SwapInt32(var a, b: TInt32);
{Swap data if a > b for TInt64}
procedure SwapInt64(var a, b: TInt64);
{Swap data if a > b for single}
procedure SwapSingle(var a, b: TSingle);
{Swap data if a > b for double}
procedure SwapDouble(var a, b: TDouble);
{Swap data if a > b for Extended}
procedure SwapExtended(var a, b: TExtended);

implementation

procedure SwapString(var a, b: TString);
var
  r: TString;
begin
  r := a;
  a := b;
  b := r;
end;

procedure SwapByte(var a, b: TByte);
var
  r: TByte;
begin
  r := a;
  a := b;
  b := r;
end;

procedure SwapWord(var a, b: TWord);
var
  r: TWord;
begin
  r := a;
  a := b;
  b := r;
end;

procedure SwapLongWord(var a, b: TLongWord);
var
  r: TLongWord;
begin
  r := a;
  a := b;
  b := r;
end;

procedure SwapInt08(var a, b: TInt08);
var
  r: TInt08;
begin
  r := a;
  a := b;
  b := r;
end;

procedure SwapInt16(var a, b: TInt16);
var
  r: TInt16;
begin
  r := a;
  a := b;
  b := r;
end;

procedure SwapInt32(var a, b: TInt32);
var
  r: TInt32;
begin
  r := a;
  a := b;
  b := r;
end;

procedure SwapInt64(var a, b: TInt64);
var
  r: TInt64;
begin
  r := a;
  a := b;
  b := r;
end;

procedure SwapSingle(var a, b: TSingle);
var
  r: TSingle;
begin
  r := a;
  a := b;
  b := r;
end;

procedure SwapDouble(var a, b: TDouble);
var
  r: TDouble;
begin
  r := a;
  a := b;
  b := r;
end;

procedure SwapExtended(var a, b: TExtended);
var
  r: TExtended;
begin
  r := a;
  a := b;
  b := r;
end;

end.


Solve 2:

This function will return the list of points found on a line from (x1,y1) to (x2,y2).
The procedure will calculate the points in the direction the line is drawn. For the line (x1,y1)------ --(x2,y2) or the line (x2,y2)-------(x1,y1) the first point in the list is always (x1,y1) and the last point in the list is always (x2, y2).
Points are calculated along the axis with the most change so that as many points as possible are created for the line.

// The point object
TPointFill = class
  X: Integer;
  Y: Integer;
end;

// ----------------------------------------------------------------------------
// GetLinePoints
// ----------------------------------------------------------------------------

function GetLinePoints(X1, Y1, X2, Y2: Integer): TList;
var
  ChangeInX, ChangeInY, i, MinX, MinY, MaxX, MaxY, LineLength: Integer;
  ChangingX: Boolean;
  Point: TPointFill;
  ReturnList, ReversedList: TList;
begin
  ReturnList := TList.Create;
  ReversedList := TList.Create;

  // Get the change in the X axis and the Max & Min X values
  if X1 > X2 then
  begin
    ChangeInX := X1 - X2;
    MaxX := X1;
    MinX := X2;
  end
  else
  begin
    ChangeInX := X2 - X1;
    MaxX := X2;
    MinX := X1;
  end;

  // Get the change in the Y axis and the Max & Min Y values
  if Y1 > Y2 then
  begin
    ChangeInY := Y1 - Y2;
    MaxY := Y1;
    MinY := Y2;
  end
  else
  begin
    ChangeInY := Y2 - Y1;
    MaxY := Y2;
    MinY := Y1;
  end;

  // Find out which axis has the greatest change
  if ChangeInX > ChangeInY then
  begin
    LineLength := ChangeInX;
    ChangingX := True;
  end
  else
  begin
    LineLength := ChangeInY;
    ChangingX := false;
  end;

  // If the x's match then the line changes only on the Y axis
  if X1 = X2 then
  begin
    // Loop thru the points on the list, lowest to highest.
    for i := MinY to MaxY do
    begin
      Point := TPointFill.Create;
      Point.X := X1;
      Point.Y := i;
      ReturnList.Add(Point);
    end;

    // If the point was started on the right and went to the left then
                reverse the list.
    if Y1 > Y2 then
    begin
      ReversedList := ReversePointOrder(ReturnList);
      ReturnList := ReversedList;
    end;
  end
    // If the x's match then the line changes only on the Y axis
  else if Y1 = Y2 then
  begin
    // Loop thru the points on the list, lowest to highest.
    for i := MinX to MaxX do
    begin
      Point := TPointFill.Create;
      Point.X := i;
      Point.Y := Y1;
      ReturnList.Add(Point);
    end;

    // If the point was started on the bottom and went to the top then reverse the list.
    if X1 > X2 then
    begin
      ReversedList := ReversePointOrder(ReturnList);
      ReturnList := ReversedList;
    end;
  end
    // The line is on an angle
  else
  begin
    // Add the first point to the list.
    Point := TPointFill.Create;
    Point.X := X1;
    Point.Y := Y1;
    ReturnList.Add(Point);

    // Loop thru the longest axis
    for i := 1 to (LineLength - 1) do
    begin
      Point := TPointFill.Create;
      // If we are moving on the x axis then get the related Y point.
      if ChangingX then
      begin
        Point.y := Round((ChangeInY * i) / ChangeInX);
        Point.x := i;
      end
        // otherwise we are moving on the y axis so get the related X point.
      else
      begin
        Point.y := i;
        Point.x := Round((ChangeInX * i) / ChangeInY);
      end;

      // if y1 is smaller than y2 then we are moving in a Top to Bottom direction.
      // we need to add y1 to get the next y value.
      if Y1 < Y2 then
        Point.y := Point.Y + Y1
          // otherwise we are moving in a Bottom to Top direction.
        // we need to subtract y1 to get the next y value.
      else
        Point.Y := Y1 - Point.Y;

      // if X1 is smaller than X2 then we are moving in a Left to Right direction
      // we need to add x1 to get the next x value
      if X1 < X2 then
        Point.X := Point.X + X1
          // otherwise we are moving in a Right to Left direction
        // we need to subtract x1 to get the next x value.
      else
        Point.X := X1 - Point.X;

      ReturnList.Add(Point);
    end;
    // Add the second point to the list.
    Point := TPointFill.Create;
    Point.X := X2;
    Point.Y := Y2;
    ReturnList.Add(Point);
  end;
  Result := ReturnList;
end;

// ----------------------------------------------------------------------------
// ReversePointOrder
// ----------------------------------------------------------------------------

function ReversePointOrder(LinePointList: TList): TList;
var
  i: integer;
  NewPointList: TList;
  CurrentPointFill: TPointFill;
begin
  NewPointList := TList.Create;
  i := LinePointList.Count - 1;

  while i > -1 do
  begin
    CurrentPointFill := TPointFill(LinePointList.Items[i]);
    NewPointList.Add(CurrentPointFill);
    dec(i);
  end;

  Result := NewPointList;
end;

Create caption for TWinControl components

Problem/Question/Abstract:

In microsoft access I can see the Listbox there contains a window caption. how can I create my own components win a caption ?

Answer:

We must not forget that this code will work only in a TWinControl components.

Well, first of all we must declear the procedure of CreateParams in the public section...

Then we go to work !!!

Now you must add this line in the publised area if you wish to add some text to the caption:

property Caption;

Now for the code part:

unit ListboxTest;

interface

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

type
  TListboxTest = class(TListbox)
  private
    { Private declarations }
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    { Public declarations }
  published
    { Published declarations }
    property Caption stored True;
  end;

procedure Register;

implementation

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

procedure TListboxTest.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := Style or WS_CAPTION;
  end;
end;

end.

Now we have a caption for our ListBox... And the funny part is that i read while back that VB users payied mony for this kind of OCX component... :)

How to get a list of all registered typelibs

Problem/Question/Abstract:

Does anybody know how to get a list of all registered typelibs (like the list in the typelib import window in Delphi)? I found a place in the registry (HKCR\TypeLib\...) but a lot of libs are listed more then one time (up to 4 or 5 times) in that place. Do I have to grab all libs from this place? I have found no API (like EnumTypeLibs) that does this.

Answer:

procedure EnumTypeLibs(TypeLibNames: TStringList);
var
  f: TRegistry;
  keyNames, keyVersions, keyInfos: TStringList;
  keyName, keyVersion, keyInfo, tlName: string;
  i, j, k: Integer;
begin
  TypeLibNames.Clear;
  {TypeLibNames.Sorted := True;}
  keyNames := nil;
  keyVersions := nil;
  keyInfos := nil;
  f := TRegistry.Create;
  try
    keyNames := TStringList.Create;
    keyVersions := TStringList.Create;
    keyInfos := TStringList.Create;
    f.RootKey := HKEY_CLASSES_ROOT;
    if not f.OpenKey('TypeLib', False) then
      raise Exception.Create('TRegistry.Open');
    f.GetKeyNames(keyNames);
    f.CloseKey;
    for i := 0 to keyNames.Count - 1 do
    begin
      keyName := keyNames.Strings[i];
      if not f.OpenKey(Format('TypeLib\%s', [keyName]), False) then
        Continue;
      f.GetKeyNames(keyVersions);
      f.CloseKey;
      for j := 0 to keyVersions.Count - 1 do
      begin
        keyVersion := keyVersions.Strings[j];
        if not f.OpenKey(Format('TypeLib\%s\%s', [keyName, keyVersion]), False) then
          Continue;
        tlName := f.ReadString('');
        f.GetKeyNames(keyInfos);
        f.CloseKey;
        for k := 0 to keyInfos.Count - 1 do
        begin
          keyInfo := keyInfos.Strings[k];
{$B-}
          if (keyInfo = '') or (keyInfo[1] < '0') or (keyInfo[1] > '9') then
            Continue;
          if not f.OpenKey(Format('TypeLib\%s\%s\%s\win32', [keyName, keyVersion,
            keyInfo]), False) then
            Continue;
          f.CloseKey;
          TypeLibNames.Add(Format('%s ver.%s', [tlName, keyVersion]));
        end;
      end;
    end;
  finally
    f.Free;
    keyNames.Free;
    keyVersions.Free;
    keyInfos.Free;
  end;
end;

Paint a complete TTreeView on a canvas

Problem/Question/Abstract:

How to paint a complete TTreeView on a canvas

Answer:

I recently implemented a procedure to paint a TTreeView component to a canvas, including the images, state images and so on, and not only the visible nodes, but also those that do not fit in the client area.

unit TreePaint;

interface

uses
  Windows, Graphics, ComCtrls;

procedure TreeViewPaintTo(ATreeView: TTreeView; FullExpand: Boolean;
  ACanvas: TCanvas; X, Y: Integer);

implementation

procedure TreeViewPaintTo(ATreeView: TTreeView; FullExpand: Boolean;
  ACanvas: TCanvas; X, Y: Integer);

var
  OffsetX, OffsetY: Integer;

  procedure DrawButton(X, Y: Integer; Expanded: Boolean);
  var
    R: TRect;
  begin
    ACanvas.Pen.Color := clGray;
    ACanvas.Pen.Style := psSolid;
    ACanvas.Rectangle(X - 5, Y - 5, X + 4, Y + 4);
    ACanvas.Pixels[X + 1, Y - 1] := clBlack;
    ACanvas.Pixels[X, Y - 1] := clBlack;
    ACanvas.Pixels[X - 1, Y - 1] := clBlack;
    ACanvas.Pixels[X - 2, Y - 1] := clBlack;
    ACanvas.Pixels[X - 3, Y - 1] := clBlack;
    if (not Expanded) then
    begin
      ACanvas.Pixels[X - 1, Y + 1] := clBlack;
      ACanvas.Pixels[X - 1, Y] := clBlack;
      ACanvas.Pixels[X - 1, Y - 1] := clBlack;
      ACanvas.Pixels[X - 1, Y - 2] := clBlack;
      ACanvas.Pixels[X - 1, Y - 3] := clBlack;
    end;
  end;

  procedure DrawHorizLine(X, Y: Integer; HasButton: Boolean);
  begin
    if (HasButton) then
      X := X + 5;
    ACanvas.Pixels[X, Y] := clGray;
    ACanvas.Pixels[X + 2, Y] := clGray;
    ACanvas.Pixels[X + 4, Y] := clGray;
  end;

  procedure DrawVertLine(X, Y0, Y1: Integer; HasButton: Boolean);
  begin
    if (HasButton) then
      Y0 := Y0 + 5;
    while (Y0 <= Y1) do
    begin
      ACanvas.Pixels[X, Y0] := clGray;
      inc(Y0, 2);
    end;
  end;

  procedure TreeNodePaintTo(ATreeNode: TTreeNode; ACanvas: TCanvas);
  var
    FirstNode: Boolean;
    CurNode: TTreeNode;
    NewX, NewY, CurX, CurY, StateY, ImageY: Integer;
  begin
    CurNode := ATreeNode;
    FirstNode := True;
    while (CurNode <> nil) do
    begin
      if (not (CurNode.IsVisible or FullExpand)) then
        Exit;
      {Compute Start X and Y}
      NewX := X + (CurNode.Level * OffsetX);
      NewY := Y + (OffsetY div 2);
      {Line to sibling node}
      if (ATreeView.ShowLines) then
      begin
        if (not FirstNode) then
        begin
          if (ATreeView.ShowRoot or (CurNode.Level > 0)) then
            DrawVertLine(NewX - 1, CurY - (OffsetY div 2) + 1, NewY, True);
        end
        else
        begin
          FirstNode := False;
          {Line to parent node}
          if (CurNode.Parent <> nil) then
            DrawVertLine(NewX - 1, Y - (OffsetY div 2) + 1, NewY, True)
        end;
      end;
      {Update Sibling offsets}
      CurX := NewX;
      CurY := NewY;
      if (ATreeView.ShowRoot or (CurNode.Level > 0)) then
      begin
        if (ATreeView.ShowButtons) then
        begin
          {Draw the button}
          if (CurNode.HasChildren) then
          begin
            DrawButton(NewX, NewY, FullExpand or CurNode.Expanded);
            CurY := CurY + 9;
          end;
          if (ATreeView.ShowLines) then
            DrawHorizLine(NewX, NewY, CurNode.HasChildren);
        end
        else if (ATreeView.ShowLines) then
          DrawHorizLine(NewX, NewY, False);
      end;
      {Update X Offset}
      NewX := NewX + 9;
      {State Image}
      if (Assigned(ATreeView.StateImages)) then
      begin
        {Draw the State Image}
        StateY := Y + ((OffsetY - ATreeView.StateImages.Height) div 2);
        ATreeView.StateImages.Draw(ACanvas, NewX, StateY, CurNode.StateIndex);
        {Update X Offset}
        NewX := NewX + ATreeView.StateImages.Width;
      end;
      {Image}
      if (Assigned(ATreeView.Images)) then
      begin
        {Draw the Image}
        ImageY := Y + ((OffsetY - ATreeView.Images.Height) div 2);
        ATreeView.Images.Draw(ACanvas, NewX, ImageY, CurNode.ImageIndex);
        {Update X Offset}
        NewX := NewX + ATreeView.Images.Width;
      end;
      ACanvas.TextOut(NewX, Y, CurNode.Text);
      {Update Y Offset}
      Y := Y + OffsetY;
      {Paint Child Nodes}
      if (CurNode.GetFirstChild <> nil) then
        TreeNodePaintTo(CurNode.GetFirstChild, ACanvas);
      {Paint sibling nodes}
      CurNode := CurNode.GetNextSibling;
    end;
  end;
begin
  {Compute Offsets}
  OffsetX := 19;
  OffsetY := 5 * ACanvas.TextHeight('|') div 4;
  if (Assigned(ATreeView.StateImages)) and (ATreeView.StateImages.Height > OffsetY)
    then
    OffsetY := ATreeView.StateImages.Height;
  if (Assigned(ATreeView.Images)) and (ATreeView.Images.Height > OffsetY) then
    OffsetY := ATreeView.Images.Height;
  if (ATreeView.ShowRoot) then
    X := X + 10;
  TreeNodePaintTo(ATreeView.Items.GetFirstNode, ACanvas);
end;

end.

Filter Table,Query with Exception Handling

Problem/Question/Abstract:

This demonstrates how to filter a table with exception handling and also demonstrates how the overload directive can be used

Answer:

function FilterTable(Data: TQuery; Filter: string): string; overload;
function ExecuteSQL(Data: TQuery; F: TStrings): string;

function ExecuteSQL(Data: TQuery; F: TStrings): string;
var
  TSQL: TStrings;
begin
  try
    TSQL := TStringList.Create;
    TSQL.Assign(Data.SQL);
    try
      Result := Data.Bookmark;
      Data.Active := False;
      Data.SQL.Assign(F);
      Data.Active := True;
    except
      on EDBEngineError do
      begin
        Data.SQL.Assign(TSQL);
        TSQL.Free;
        TSQL := nil;
        Data.Active := True;
      end;
    end; //try except
  finally
    if TSQL <> nil then
      TSQL.Free;
  end;
end;

function FilterTable(Data: TTable; Filter: string): string;
begin
  try
    Result := Data.Bookmark;
    Data.Active := False;
    Data.Filtered := True;
    Data.FilterOptions := [foCaseInsensitive];
    Data.Filter := Filter;
    Data.Active := True;
  except
    on EDatabaseError do
    begin
      Data.Filter := '';
      Data.Active := True;
    end;
  end; //try except
end;

A few routines that can be used to clean up code.

How to open the Windows screen mode dialog

Problem/Question/Abstract:

Is there a way to open the default Windows dialog for screen settings (screen resolution, colors etc.) by a Delphi application?

Answer:

uses
  ShellAPI;

{ ... }
ShellExecute(HInstance, nil, PCHAR('rundll32.exe'), PCHAR('shell32.dll,
  Control_RunDLL desk.cpl, , 3') { 3 is the tab index }, NIL, 1);

How to save components to a file or stream

Problem/Question/Abstract:

I have a component TZzz (descends from TComponent) and I want to implement some saving/ restoring capabilities for it. Here's my point. I want to place a TZzz component in a form and export this object to a file. Later, I want import that file to another TZzz object in another form (only for copying the properties from one object to another). Any ideas?

Answer:

Here is a component I wrote which I use often. Simply derive from TPersistentComponent and you can then stream it in and out either directly to a stream or to a file as well. You will have to implement the FindMethod method yourself.

unit Unit1;

interface

uses
  Classes, Sysutils;

const
  cFileDoesNotExist = 'File Does Not Exist %0s';
  cDefaultBufSize = 4096;

type
  TPersistComponent = class(TComponent)

  private
    FStreamLoad: Boolean;
  protected
    property StreamLoad: Boolean read FSTreamLoad;
    procedure FindMethod(Reader: TReader; const MethodName: string; var Address:
      Pointer;
      var Error: Boolean); virtual;
  public
    procedure LoadFromFile(const FileName: string; const Init: Boolean = False);
      virtual;
    procedure SaveToFile(const FileName: string); virtual;
    procedure LoadFromStream(Stream: TStream); virtual;
    procedure SaveToStream(Stream: TStream); virtual;
  end;

implementation

procedure TPersistComponent.FindMethod(Reader: TReader; const MethodName: string;
  var Address: Pointer; var Error: Boolean);
begin
  Error := False;
end;

procedure TPersistComponent.LoadFromFile(const FileName: string; const Init: Boolean =
  False);
var
  FS: TFileStream;
begin
  if FileExists(Filename) then
  begin
    FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
    try
      LoadFromStream(FS);
    finally
      FS.Free;
    end;
  end
  else
    raise Exception.CreateFmt(cFileDoesNotExist, [FileName]);
end;

procedure TPersistComponent.LoadFromStream(Stream: TStream);
var
  Reader: TReader;
begin
  Reader := TReader.Create(Stream, cDefaultBufSize);
  try
    {Reader.OnFindMethod := FindMethod;}
    FStreamLoad := True;
    Reader.OnFindMethod := FindMethod;
    Reader.BeginReferences;
    Reader.Root := Owner;
    Reader.ReadComponent(Self);
    Reader.EndReferences;
    Loaded;
  finally
    FStreamLoad := False;
    Reader.Free;
  end;
end;

procedure TPersistComponent.SaveToFile(const FileName: string);
var
  FS: TFileStream;
begin
  FS := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(FS);
  finally
    FS.Free;
  end;
end;

procedure TPersistComponent.SaveToStream(Stream: TStream);
var
  Writer: TWriter;
begin
  Writer := TWriter.Create(Stream, cDefaultBufSize);
  try
    Writer.Root := Owner;
    Writer.WriteComponent(Self);
  finally
    Writer.Free;
  end;
end;

end.

How to get a list of all data-aware controls linked to a given TDataSource

Problem/Question/Abstract:

Is there a way to get a list of data-aware controls linked to a given TDataSource component? I need a solution that will work without knowing ahead of time what form to look in for the controls.

Answer:

Try something like the following. This code will scan all components on all forms and determine if the component has a DataSource property. If it does, the value of the DataSource property is assigned to the variable ThisDataSource.

for I := 0 to Screen.FormCount - 1 do
  if Screen.Forms[I] is TCustomForm then
    with Screen.Forms[I] as TCustomForm do
      for J := 0 to ComponentCount - 1 do
        if IsPublishedProp(Components[J], 'DataSource') then
        begin
          ThisDataSource := GetObjectProp(Components[J], 'DataSource') as TDataSource;
          if ThisDataSource = SomeOtherDataSource then
            {...}
        end;

How to disable and reenable the Windows start button

Problem/Question/Abstract:

How can I disable the Windows start button and prevent the user from accessing it by clicking on it or by pressing [CTRL] + [ESC] ?

Answer:

Solve 1:

To disable the Start button:

var
  h: hwnd;
begin
  h := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil);
  EnableWindow(h, false);
end;

But the user can still access the start menu by pressing [CTL] + [ESC] or the windows key. Even hiding the Start button doesn't work. But hiding the Start button and using the SetParent function seems to work:

var
  h: hwnd;
begin
  h := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil)
    ShowWindow(h, 0);
  Windows.SetParent(h, 0);
end;

To enable the Start button again:

var
  h: hwnd;
  TaskWindow: hwnd;
begin
  h := FindWindowEx(GetDesktopWindow, 0, 'Button', nil);
  TaskWindow := FindWindow('Shell_TrayWnd', nil);
  Windows.SetParent(h, TaskWindow);
  ShowWindow(h, 1);
end;

Furthermore, you could create your own Start button and "replace" it with your own.

var
  b: TButton; {or another button type that can hold a bitmap}
  h, Window: hwnd;
begin
  Window := FindWindow('Shell_TrayWnd', nil);
  b := TButton.Create(nil);
  b.ParentWindow := Window;
  b.Caption := 'Start';
  b.Width := 60;
  b.font.style := [fsbold];
end;


Solve 2:

procedure TForm1.Button1Click(Sender: TObject);
var
  Rgn: hRgn;
begin
  {Hide the start button}
  Rgn := CreateRectRgn(0, 0, 0, 0);
  SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), Rgn,
    true);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  {Turn the start button back on}
  SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), 0,
    true);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  {Disable the start button}
  EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil),
    false);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  {Enable the start button}
  EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil),
    true);
end;

Draw text alongside a curve

Problem/Question/Abstract:

How to draw text alongside a curve

Answer:

You need a free rotatable text and the exact measurement of fonts. I use the ATM metrix, but you can also try textwidth or textheight. I use this code under Windows NT to draw symbols along a polygon line.

procedure TDrawer.fOutSymbolXYW(w: Double; x, y: Integer; S: string);
var
  nx, ny, xw, xh: Integer;
  O, T: TXForm;
  sc, cHg, fHg: Double;
begin
  nx := 0;
  ny := 0;
  cHg := fFontMetrix.fY2 - fFontMetrix.fY1; {I use Adobe one}
  fHg := TextHeight(S);
  if fHG = 0 then
    Exit;
  Sc := cHg / fHg;
  xw := OperateFont(Textwidth(S));
  xh := OperateFont(SymbolHeight(S));
  case TextJust of
    tjCenterTop:
      begin
        nx := -xw div 2;
        ny := 0;
      end;
    tjCenterBottom:
      begin
        nx := -xw div 2;
        ny := -xh;
      end;
    tjCenterCenter:
      begin
        nx := -xw div 2;
        ny := -xh div 2;
      end;
    tjLeftTop:
      begin
        nx := 0;
        ny := 0;
      end;
    tjLeftCenter:
      begin
        nx := 0;
        ny := -xh div 2;
      end;
    tjLeftBottom:
      begin
        nx := 0;
        ny := -xh;
      end;
    tjRightCenter:
      begin
        nx := -xw;
        ny := -xh div 2;
      end;
    tjRightTop:
      begin
        nx := -xw;
        ny := 0;
      end;
    tjRightBottom:
      begin
        nx := -xw;
        ny := -xh;
      end;
  end;
  SetGraphicsMode(TheDraw.Handle, GM_Advanced);
  T.eM11 := 1 * Cos(w / 360 * Pi * 2);
  T.eM22 := 1 * Cos(w / 360 * Pi * 2);
  T.eM12 := 1 * Sin(w / 360 * Pi * 2);
  T.eM21 := 1 * -Sin(w / 360 * Pi * 2);
  T.eDX := X;
  T.eDY := Y;
  GetWorldTransform(TheDraw.Handle, O);
  ModifyWorldTransform(TheDraw.Handle, T, MWT_LEFTMULTIPLY);
  { TheDraw.Pen.Style := psClear;
  TheDraw.Rectangle(nx - 1, ny - 1, nx + xw + 3, ny + xh + 2); }
  TheDraw.TextOut(nx + OperateFont(FFontMetrix.fX1 / SC), ny -
    OperateFont(TextHeight(S)
    - SymbolHeight(S) + FFontMetrix.fY1 / sc), S);
  { SetPen(0, 200, 0, 0. 25, psSolid);
  TheDraw.Ellipse(nx - 1, ny - 1, nx + 1, ny + 1); }
  T.eM11 := 1;
  T.eM22 := 1;
  T.eM12 := 0;
  T.eM21 := 0;
  T.eDX := 0;
  T.eDY := 0;
  SetWorldTransform(TheDraw.Handle, O);
end;

procedure TDrawer.SymbolLine(Poly: TXYPointList; Distance: Double; Offset: Double;
  StartAngle: Double; R, G, B: Byte; Lib: string; CharSet: Byte; Size: Double; Style:
    TFontStyles;
  Sign: Char);
var
  i, Segment: Integer;
  PosX, PosY, TargetLength, CurrentLength: Double;
  {P, pxy: TXYpoint;}
  s, c: Double;
  Angle: Double;

  {Locates the angle of symbol at one linepoint}
  procedure LANGLE(j: Integer; var s, c: Double);
  var
    x1, x2, y1, y2, l: Double;
  begin
    x1 := Poly.Points[j].x;
    x2 := Poly.Points[j - 1].x;
    y1 := Poly.Points[j].y;
    y2 := Poly.Points[j - 1].y;
    l := sqrt(sqr(x2 - x1) + sqr(y2 - y1));
    s := (x1 - x2) / l;
    c := (y2 - y1) / l;
  end;

  {Llocates the angle of symbol between to lines linepoints}
  procedure SLANGLE(j: Integer; var s, c: Double);
  var
    x1, x2, y1, y2, l: Double;
  begin
    x1 := Poly.Points[j - 1].x;
    x2 := Poly.Points[j + 1].x;
    y1 := Poly.Points[j - 1].y;
    y2 := Poly.Points[j + 1].y;
    l := sqrt(sqr(x2 - x1) + sqr(y2 - y1));
    s := (x1 - x2) / l;
    c := (y2 - y1) / l;
  end;

  function Place(L: Double; var x, y: Double; var Pl: Double; var Index: integer;
    var s, c: Double): Boolean;
  var
    x1, x2, y1, y2: Real;
    l1, l2: Real;
    j: Integer;
  begin
    Place := False;
    if L < 0 then
      Exit;
    j := index;
    while (l >= Pl) and (j < Poly.MaxPoint) do
    begin
      inc(j);
      x1 := Poly.Points[j - 1].x;
      x2 := Poly.Points[j].x;
      y1 := Poly.Points[j - 1].y;
      y2 := Poly.Points[j].y;
      pl := pl + sqrt(sqr(x2 - x1) + sqr(y2 - y1));
    end;
    if not (l < Pl) and (j >= Poly.MaxPoint) then
      Exit;
    if (l = pl) then
    begin
      X := Poly.Points[j].X;
      Y := Poly.Points[j].Y;
      if j = Poly.MaxPoint then
        LAngle(j, s, c)
      else if j = 1 then
        LAngle(2, s, c)
      else
        SLAngle(j, s, c);
      Exit;
    end;
    x1 := Poly.Points[j - 1].x;
    x2 := Poly.Points[j].x;
    y1 := Poly.Points[j - 1].y;
    y2 := Poly.Points[j].y;
    l1 := sqrt(sqr(x2 - x1) + sqr(y2 - y1));
    if j < 3 then
      l2 := l
    else
      l2 := l - (Pl - l1);
    x := l2 / l1 * (x2 - x1) + Poly.Points[j - 1].x;
    y := l2 / l1 * (y2 - y1) + Poly.Points[j - 1].y;
    if j <> index then
      LANGLE(j, s, c);
    index := j;
    Place := True;
  end;

begin
  SetSymbols(R, G, B, LIB, Charset, Size, Style);
  if Distance = 0 then
    Distance := 1;
  CurrentLength := 0;
  TargetLength := Poly.PolyLength;
  Segment := 1;
  i := -1;
  if (Poly.MaxPoint < 2) or (Poly.PolyLength < Distance + Offset) then
    Exit;
  repeat
    Inc(i);
    if Place(Offset + Distance * i, PosX, PosY, CurrentLength, Segment, S, C) then
    begin
      Angle := ArcTan2(S, C) / 2 / Pi * 360;
      OutSymbolXYW(Angle + StartAngle, PosX, PosY, Sign);
    end;
  until
    Offset + Distance * i >= TargetLength;
end;

Rotate an ellipse

Problem/Question/Abstract:

How to draw a rotated Ellipse?

Answer:

I wrote a procedure "CentralRotatedEllipse" to rotate an ellipse. It works exactly enougth for simple graphics. The Ellipse is maked with two connected beziercurves. Rotatingpoint of the Ellipse is its centralpoint. The Parameter canvas for the Destinationcanvas, coordinates  like "common" Ellipse and in alpha the rotatingangle. The function "Rotate2DPoint" you have to put in your code too, its called by the CentralRotatedEllipse-Procedure.
And dont forget uses Math!

function Rotate2DPoint(P, Fix: TPoint; alpha: double): TPoint;
var
  sinus, cosinus: Extended;
begin
  SinCos(alpha, sinus, cosinus);
  P.x := P.x - Fix.x;
  P.y := P.y - Fix.y;
  result.x := Round(p.x * cosinus + p.y * sinus) + fix.x;
  result.y := Round(-p.x * sinus + p.y * cosinus) + Fix.y;
end;

procedure CentralRotatedEllipse(Canvas: TCanvas; x1, y1, x2, y2: Integer; alpha:
  Extended);
var
  PointList: array[0..6] of TPoint;
  f: TPoint;
  dk: Integer;
begin
  dk := Round(0.654 * Abs(y2 - y1));
  f.x := x1 + (x2 - x1) div 2;
  f.y := (y1 + (y2 - y1) div 2) - 1;
  PointList[0] := Rotate2DPoint(Point(x1, f.y), f, Alpha); // Startpoint
  PointList[1] := Rotate2DPoint(Point(x1, f.y - dk), f, Alpha);
  //Controlpoint of Startpoint first part
  PointList[2] := Rotate2DPoint(Point(x2 - 1, f.y - dk), f, Alpha);
  //Controlpoint of secondpoint first part
  PointList[3] := Rotate2DPoint(Point(x2 - 1, f.y), f, Alpha);
  // Firstpoint of secondpart
  PointList[4] := Rotate2DPoint(Point(x2 - 1, f.y + dk), f, Alpha);
  // Controllpoint of secondpart firstpoint
  PointList[5] := Rotate2DPoint(Point(x1, f.y + dk), f, Alpha);
  // Conrollpoint of secondpart endpoint
  PointList[6] := PointList[0]; // Endpoint of
  // Back to the startpoint
  PolyBezier(canvas.handle, Pointlist[0], 7);
end;

Example:

CentralRotatedEllipse(Canvas, 100, 100, 150, 300, DegToRad(45));
CentralRotatedEllipse(Canvas, 100, 100, 150, 300, DegToRad(90));

Angle always should be in Rad.

Making Any-Shaped Form ( The Hard-Code )

Problem/Question/Abstract:

Wel, this is a hard-coded application, ONLY for people interested in knowing more, it describes another way of doing starnge shaped forms !!

Answer:

Well, Declare these 2 sentences to your PROTECTED declaration

procedure EvEraseBkgnd(var M: tMessage); message WM_ERASEBKGND;
procedure EvNcHitTest(var M: tMessage); message WM_NCHITTEST;

Then Of Course, add them in the body code !!

procedure tForm1.EvEraseBkgnd(var M: tMessage);
begin
  { No Erase Window Background.... }
  M.Result := 1;
end;

procedure tForm1.EvNcHitTest(var M: tMessage);
begin
  inherited;
  { If Hit in Client Area then simulate hit in Caption Area }
  if M.Result = HTCLIENT then
    M.Result := HTCAPTION;
end;

make the following OnFormPaint Procedure..

procedure TForm1.FormPaint(Sender: TObject);
var
  Buffer: tBitmap;
begin
  Buffer := tBitmap.create;
  Buffer.LoadFromResourceName(hinstance, 'FORM');
  Bitblt(Canvas.handle, 0, 0,
    Buffer.width, Buffer.height,
    Buffer.canvas.handle, 0, 0,
    SrcCopy);
  Buffer.free;
end;

And On Your Form, Put Any Buttons Or TEdits Or Anything You Want To Add, Try Your Form, I think it is working just as it used to work all the time, that is true, this is not the secret, the big part is here

OnFormCreate Procedure Needs To Be Added :-))

procedure TForm1.FormCreate(Sender: TObject);
var
  Region1: array of tPoint;
  Region1hrgn: hRgn;
begin
  SetLength(Region1, 59);

  Region1[0].X := 12;
  Region1[0].Y := 6;
  Region1[1].X := 484;
  Region1[1].Y := 6;
  Region1[2].X := 484;
  Region1[2].Y := 7;
  Region1[3].X := 486;
  Region1[3].Y := 7;
  Region1[4].X := 486;
  Region1[4].Y := 8;
  Region1[5].X := 487;
  Region1[5].Y := 8;
  Region1[6].X := 487;
  Region1[6].Y := 9;
  Region1[7].X := 488;
  Region1[7].Y := 9;
  Region1[8].X := 488;
  Region1[8].Y := 10;
  Region1[9].X := 489;
  Region1[9].Y := 10;
  Region1[10].X := 489;
  Region1[10].Y := 12;
  Region1[11].X := 490;
  Region1[11].Y := 12;
  Region1[12].X := 490;
  Region1[12].Y := 285;
  Region1[13].X := 489;
  Region1[13].Y := 285;
  Region1[14].X := 489;
  Region1[14].Y := 287;
  Region1[15].X := 488;
  Region1[15].Y := 287;
  Region1[16].X := 488;
  Region1[16].Y := 288;
  Region1[17].X := 487;
  Region1[17].Y := 288;
  Region1[18].X := 487;
  Region1[18].Y := 289;
  Region1[19].X := 486;
  Region1[19].Y := 289;
  Region1[20].X := 486;
  Region1[20].Y := 290;
  Region1[21].X := 484;
  Region1[21].Y := 290;
  Region1[22].X := 484;
  Region1[22].Y := 291;
  Region1[23].X := 101;
  Region1[23].Y := 291;
  Region1[24].X := 100;
  Region1[24].Y := 290;
  Region1[25].X := 99;
  Region1[25].Y := 290;
  Region1[26].X := 98;
  Region1[26].Y := 289;
  Region1[27].X := 97;
  Region1[27].Y := 288;
  Region1[28].X := 96;
  Region1[28].Y := 287;
  Region1[29].X := 95;
  Region1[29].Y := 286;
  Region1[30].X := 95;
  Region1[30].Y := 284;
  Region1[31].X := 94;
  Region1[31].Y := 283;
  Region1[32].X := 94;
  Region1[32].Y := 200;
  Region1[33].X := 93;
  Region1[33].Y := 199;
  Region1[34].X := 93;
  Region1[34].Y := 198;
  Region1[35].X := 92;
  Region1[35].Y := 197;
  Region1[36].X := 91;
  Region1[36].Y := 196;
  Region1[37].X := 90;
  Region1[37].Y := 195;
  Region1[38].X := 89;
  Region1[38].Y := 194;
  Region1[39].X := 88;
  Region1[39].Y := 194;
  Region1[40].X := 87;
  Region1[40].Y := 193;
  Region1[41].X := 14;
  Region1[41].Y := 193;
  Region1[42].X := 13;
  Region1[42].Y := 192;
  Region1[43].X := 12;
  Region1[43].Y := 192;
  Region1[44].X := 11;
  Region1[44].Y := 191;
  Region1[45].X := 10;
  Region1[45].Y := 190;
  Region1[46].X := 9;
  Region1[46].Y := 189;
  Region1[47].X := 8;
  Region1[47].Y := 188;
  Region1[48].X := 8;
  Region1[48].Y := 187;
  Region1[49].X := 7;
  Region1[49].Y := 186;
  Region1[50].X := 7;
  Region1[50].Y := 184;
  Region1[51].X := 6;
  Region1[51].Y := 183;
  Region1[52].X := 6;
  Region1[52].Y := 12;
  Region1[53].X := 7;
  Region1[53].Y := 11;
  Region1[54].X := 7;
  Region1[54].Y := 10;
  Region1[55].X := 8;
  Region1[55].Y := 9;
  Region1[56].X := 9;
  Region1[56].Y := 8;
  Region1[57].X := 10;
  Region1[57].Y := 7;
  Region1[58].X := 11;
  Region1[58].Y := 7;

  Region1hrgn := CreatePolygonRgn(Region1[0], 59, 2);

  SetWindowRgn(Handle, Region1hrgn, True);
end;