Delphi Magic

How to retrieve an InterBase Blob in Delphi using SavetoFile

There are several ways of retrieving InterBase Blob data within Delphi.
This example uses the SaveToFile method.

* Put TDatabase, TQuery, TDatasource and TDBGrid on the form.
* set the Tdatabase's fields as follow:
> Alias name to the BDE Alias.
> DatabaseName to something you wish.
> Connected to true
* Set the TQuery fields as follow:
> SQL to the sql statement to be executed, ie select * from
table1
> DatabaseName to the same name you've named in the
previouse step.

* Set the TDatasource field DataSet to the name
of the Tquery component. Default is query1.
* Set the TDBGrid field DataSource to the name of
the TDataSource component. Defualt is Datasource1.
* Go back to TQuery component and double click.
* Right click on the blank space on the windows said
"form1.query". And choose add fields.
* Select all the fields in the list and added.
* Drop a TButton on the form.
* Double click on the Tbutton.
* Add the following lines between begin and end;

procedure TForm1.Button1Click(Sender: TObject);
begin
query1image.savetofile('c:testimage.jpg');
end;

Note: image is the field name defined as blob.
And c:testimage.jpg is where the location of the
image file to be created.

* Save the project/form/unit. and Run.
* Click on the Button will retrieve a blob entry and create file image.jpg.

Web: http://delphi.about.com

How to insert an InterBase BLOb in Delphi using LoadFromFile

This is one way of inserting BLOB in Delphi. There are several ways
to accomplish this task. This example is just one way of doing it.
This example is using the LoadFromFile method.

Create a table in InterBase with a field that can store non-text Blobs:

create table table1 (images blob sub_type 0);

-------------------------------------------------------------------------------------------------
* Put TQuery and a Button on the form.

* Set the TQuery's properties:
> Alias name to the BDE Alias pointing to the database.
> SQL to the sql statement to be executed,
i.e. select images from table1
> RequestLive to True.
> Active to true.
* Go back to TQuery component and double click which will bring up a window
titled "form1.query".

* Right click on the blank space of form1.query and choose add fields.

* Select images in the list and add.

* Double click on the TButton.

* Add the following lines

procedure TForm1.Button1Click(Sender: TObject);
begin
query1.append;
query1images.loadfromfile('c:testimage.bmp');
query1.post;
end;

Note: images is the field name defined as blob.
And c:testimage.bmp is where the location of the
image file to be inserted.

* Save the project/form/unit and Run.

* Click on the Button will insert a blob entry.

To verify the Blob is inserted:

* Drop a Tdatasource and TDBImage component on the form.

* Set the properties of Tdatasource:
> Dataset to "query1"

* Set the properties of TDBImage:
>Datasource to "datasource1"
>Datafield to images

* Save the project and run. You should see the images displayed.

Note: By default, DBImage will only display bitmaps.

Web: http://delphi.about.com

Print a canvas



uses
  Printers;

procedure PrintCanvas(TextToPrint: string);
begin
  with Printer do
  begin
    BeginDoc;
    Canvas.TextOut(5, 50, TexttoPrint);
    EndDoc;
  end;
end;

Detect Printer status



function TestPrinterStatus(LPTPort: Word): Byte;
var
  Status: byte;
  CheckLPT: word;
begin
  Status := 0;
  if (LPTPort >= 1) and (LPTPort <= 3) then
  begin
    CheckLPT := LPTPort - 1;
    asm
      mov dx, CheckLPT;
      mov al, 0;
      mov ah, 2;
      int 17h;
      mov &Status, ah;
    end;
  end;
  Result := Status;
end;


{
  Pass in the LPT port number you want to check & get the following back:
  01h - Timeout
  08h - I/O Error
  10h - Printer selected
  20h - Out of paper
  40h - Printer acknowledgement
  80h - Printer not busy (0 if busy)

  Note:
  This function doesn't work under NT, it gives an access violation
  from the DOS interrupt call.
}

Autor: Colombo Gianluca
Homepage: http://www.digitstudios.com

Get the available printers

uses
printers;

ComboBox1.Items.Assign(Printer.Printers);

List print-jobs in a printer-queue



uses
  Winspool, Printers;

function GetCurrentPrinterHandle: THandle;
var
  Device, Driver, Port: array[0..255] of Char;
  hDeviceMode: THandle;
begin
  Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
  if not OpenPrinter(@Device, Result, nil) then
    RaiseLastWin32Error;
end;

function SavePChar(p: PChar): PChar;
const
  error: PChar = 'Nil';
begin
  if not Assigned(p) then
    Result := error
  else
    Result := p;
end;

procedure TForm1.Button1Click(Sender: TObject);
type
  TJobs  = array [0..1000] of JOB_INFO_1;
  PJobs = ^TJobs;
var
  hPrinter: THandle;
  bytesNeeded, numJobs, i: Cardinal;
  pJ: PJobs;
begin
  hPrinter := GetCurrentPrinterHandle;
  try
    EnumJobs(hPrinter, 0, 1000, 1, nil, 0, bytesNeeded,
      numJobs);
    pJ := AllocMem(bytesNeeded);
    if not EnumJobs(hPrinter, 0, 1000, 1, pJ, bytesNeeded,
      bytesNeeded, numJobs) then
      RaiseLastWin32Error;

    memo1.Clear;
    if numJobs = 0 then
      memo1.Lines.Add('No jobs in queue')
    else
      for i := 0 to Pred(numJobs) do
        memo1.Lines.Add(Format('Printer %s, Job %s, Status (%d): %s',
          [SavePChar(pJ^[i].pPrinterName), SavePChar(pJ^[i].pDocument),
          pJ^[i].Status, SavePChar(pJ^[i].pStatus)]));
  finally
    ClosePrinter(hPrinter);
  end;
end;

Autor: P. Below
Homepage: http://www.teamb.com

Check, if the current printer prints in color



uses
  Printers, WinSpool;

procedure TForm1.Button1Click(Sender: TObject);
var
  Dev, Drv, Prt: array[0..255] of Char;
  DM1: PDeviceMode;
  DM2: PDeviceMode;
  Sz: Integer;
  DevM: THandle;
begin
  Printer.PrinterIndex := -1;
  Printer.GetPrinter(Dev, Drv, Prt, DevM);
  DM1 := nil;
  DM2 := nil;
  Sz  := DocumentProperties(0, 0, Dev, DM1^, DM2^, 0);
  GetMem(DM1, Sz);
  DocumentProperties(0, 0, Dev, DM1^, DM2^, DM_OUT_BUFFER);
  if DM1^.dmColor > 1 then
    label1.Caption := Dev + ': Color'
  else
    label1.Caption := Dev + ': Black and White';
  if DM1^.dmFields and DM_Color <> 0 then
    Label2.Caption := 'Printer supports color printing'
  else
    Label2.Caption := 'Printer does not support color printing';
  FreeMem(DM1);
end;

Autor: Michael Winter

Determine the minimum margins for a printer



uses
  Printers;

type
  TMargins = record
    Left,
    Top,
    Right,
    Bottom: Double
end;

procedure GetPrinterMargins(var Margins: TMargins);
var
  PixelsPerInch: TPoint;
  PhysPageSize: TPoint;
  OffsetStart: TPoint;
  PageRes: TPoint;
begin
  PixelsPerInch.y := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
  PixelsPerInch.x := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
  Escape(Printer.Handle, GETPHYSPAGESIZE, 0, nil, @PhysPageSize);
  Escape(Printer.Handle, GETPRINTINGOFFSET, 0, nil, @OffsetStart);
  PageRes.y := GetDeviceCaps(Printer.Handle, VERTRES);
  PageRes.x := GetDeviceCaps(Printer.Handle, HORZRES);
  // Top Margin
  Margins.Top := OffsetStart.y / PixelsPerInch.y;
  // Left Margin
  Margins.Left := OffsetStart.x / PixelsPerInch.x;
  // Bottom Margin
  Margins.Bottom := ((PhysPageSize.y - PageRes.y) / PixelsPerInch.y) -
    (OffsetStart.y / PixelsPerInch.y);
  // Right Margin
  Margins.Right := ((PhysPageSize.x - PageRes.x) / PixelsPerInch.x) -
    (OffsetStart.x / PixelsPerInch.x);
end;

function InchToCm(Pixel: Single): Single;
// Convert inch to Centimeter
begin
  Result := Pixel * 2.54
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Margins: TMargins;
begin
 GetPrinterMargins(Margins);
 ShowMessage(Format('Margins: (Left: %1.3f, Top: %1.3f, Right: %1.3f, Bottom: %1.3f)',
  [InchToCm(Margins.Left),
   InchToCm(Margins.Top),
   InchToCm(Margins.Right),
   InchToCm(Margins.Bottom)]));
end;

Autor: Thomas Stutz

Implement Print/Page Setup/etc ... with TWebBrowser

TWebBrowser can use native IE API to print and do other things.
Implement on a Form a TWebBrowser component, and a button to print.
The code attached to this button is as follow :




procedure TForm.OnClickPrint(Sender: TObject);
begin
  WebBrowser.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER);
end;

You can replace "OLECMDID_PRINT" by other possibilities :

OLECMDID_OPEN OLECMDID_NEW OLECMDID_SAVE
OLECMDID_SAVEAS OLECMDID_SAVECOPYAS OLECMDID_PRINT
OLECMDID_PRINTPREVIEW OLECMDID_PAGESETUP OLECMDID_SPELL
OLECMDID_PROPERTIES OLECMDID_CUT OLECMDID_COPY
OLECMDID_PASTE OLECMDID_PASTESPECIAL OLECMDID_UNDO
OLECMDID_REDO OLECMDID_SELECTALL OLECMDID_CLEARSELECTION
OLECMDID_ZOOM OLECMDID_GETZOOMRANGE OLECMDID_UPDATECOMMANDS

OLECMDID_REFRESH OLECMDID_STOP OLECMDID_HIDETOOLBARS
OLECMDID_SETPROGRESSMAX OLECMDID_SETPROGRESSPOS
OLECMDID_SETPROGRESSTEXT

OLECMDID_SETTITLE OLECMDID_SETDOWNLOADSTATE OLECMDID_STOPDOWNLOAD

OLECMDID_FIND OLECMDID_ONTOOLBARACTIVATED OLECMDID_DELETE

OLECMDID_HTTPEQUIV OLECMDID_ENABLE_INTERACTION OLECMDID_HTTPEQUIV_DONE

OLECMDID_ONUNLOAD OLECMDID_PROPERTYBAG2 OLECMDID_PREREFRESH

Autor: Franck BRUNET
Homepage: http://beastcorp.free.fr

Find the port of a named printer device




{You need this Code to get the Port for a Printer.}

uses registry;

function Get_Printerport(Printername: String): string;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  with Reg do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
     if OpenKey('\System\CurrentControlSet\Control\Print\printers\' + Printername + '\', True) then
       if ValueExists('port') then
       Result := Readstring('port');
      CloseKey;
  end;
end;

Determine printers port and name




{ .... }

TYPE
   TPrinterDevice = CLASS {type definition NOT interfaced by Printers.pas}
      Driver, Device, Port: STRING;
   END;

{ .... }

USES Printers;

{ .... }

FUNCTION GetCurrentPrinterPort: STRING;
BEGIN
   Result := TPrinterDevice(Printer.Printers.Objects[Printer.PrinterIndex]).Port;
END;

{The exact printer's name known to Windows for use in API calls can be obtained by:}

FUNCTION GetCurrentPrinterName: STRING;
BEGIN
   Result := TPrinterDevice(Printer.Printers.Objects[Printer.PrinterIndex]).Device;
END;


// Example:

PROCEDURE TForm1.Button1Click(Sender: TObject);
BEGIN
   Label1.Caption := GetCurrentPrinterPort;
   Label2.Caption := GetCurrentPrinterName;
END;

Autor: Mad Byte

Get the name of the default printer




UNIT printers;


BEGIN
  //...
   Printer.PrinterIndex := -1;
   DefaultPrnName := Printer.Printers.Strings[Printer.PrinterIndex];
  //...
END;

Convert Hexadecimal to Integer



FUNCTION HexToInt(S: STRING): LongInt;
CONST
   DecDigits: SET OF '0'..'9' = ['0'..'9'];
   HexVals: ARRAY[0..$F] OF Integer = (0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
      $A, $B, $C, $D, $E, $F);
   UpCaseHexLetters: SET OF 'A'..'F' = ['A'..'F'];
   LowCaseHexLetters: SET OF 'a'..'f' = ['a'..'f'];
   varv: LongInt;
   i: integer; LookUpIndex: integer;
BEGIN
   IF length(S) <= 8 THEN
   BEGIN
      v := 0;
      FOR i := 1 TO length(S) DO
      BEGIN
{$R-}
         v := v SHL 4;
{$R+}
         IF S[i] IN DecDigits THEN
         BEGIN
            LookUpIndex := Ord(S[i]) - Ord('0'); END
         ELSE
         BEGIN
            IF S[i] IN UpCaseHexLetters THEN
            BEGIN
               LookUpIndex := Ord(S[i]) - Ord('A') + $A;
            END
            ELSE
            BEGIN
               IF S[i] IN LowCaseHexLetters THEN
               BEGIN
                  LookUpIndex := Ord(S[i]) - Ord('a') + $A;
               END ELSE BEGIN LookUpIndex := 0;
               END;
            END;
         END;
         v := v OR HexVals[LookUpIndex];
      END;
      result := v;
   END
   ELSE
   BEGIN
      result := 0;
   END;
END;

Disable images in Internet Explorer

If you want to disable images in Internet Explorer, leaving only text and Flash animations try the following:


Uses Registry;

procedure DisplayImagesIE(show : boolean);
const
DisplayImages = 'Display Inline Images';
var
    sTmp : string;
begin
with TRegistry.Create do
begin
RootKey := HKEY_CURRENT_USER;
OpenKey ('\Software\Microsoft\Internet Explorer\Main', True);
if show then
sTmp := 'yes'
else
sTmp := 'no';
WriteString (DisplayImages, sTmp);
Free;
end { with TRegistry.Create };
end;

Call the function:

DisplayImagesIE(false);

Get the Internet Explorer typed urls

uses registry;

procedure ShowTypedUrls(Urls: TStrings);
var
Reg: TRegistry;
S: TStringList;
i: Integer;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('Software\Microsoft\Internet Explorer\TypedURLs', False) then
begin
S := TStringList.Create;
try
reg.GetValueNames(S);
for i := 0 to S.Count - 1 do
begin
Urls.Add(reg.ReadString(S.Strings[i]));
end;
finally
S.Free;
end;
Reg.CloseKey;
end;
finally
Reg.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowTypedUrls(ListBox1.Items);
end;

How to Get NS, MX, SOA of a Domain with Indy

if you want to get the name server, mail server and SOA of a IP with the indy vcl try this:

Put a TidDnsResolver Component an a tTMemo in a Form

PROCEDURE TForm1.CheckDNS(Dominio:ansistring);
VAR
i, j: integer;

BEGIN
memoresult.clear;
idDNSResolver.Active := False;
idDNSResolver.QueryResult.Clear;
idDNSResolver.host := eddns.text; // your dns-server

WITH idDNSResolver DO //qtNS
BEGIN
Active := true;
QueryResult.Clear;
QueryRecords := [qtNS];
resolve(dominio);
memoresult.lines.add('========== NS ');
FOR i := 0 TO QueryResult.Count - 1 DO
BEGIN
IF QueryResult[i].RecType = qtNS THEN
BEGIN
memoResult.Lines.Append(' Host : ' + (QueryResult[i] AS tNSRecord).HostName);
memoResult.Lines.Append(' Name : ' + (QueryResult[i] AS tNSRecord).Name);
memoResult.Lines.Append(' TTL : ' + IntToStr((QueryResult[i] AS tNSRecord).TTL));
END;
END;
Active := False;
END;

WITH idDNSResolver DO //qtSOA
BEGIN
Active := true;
QueryResult.Clear;
QueryRecords := [qtSOA];
resolve(dominio);
memoresult.lines.add('========== SOA ');
FOR i := 0 TO QueryResult.Count - 1 DO
BEGIN
IF QueryResult[i].RecType = qtSOA THEN
BEGIN
memoResult.Lines.Append(' Domain Name: ' + (QueryResult[i] AS TSOARecord).Primary);
memoResult.Lines.Append(' Responsable: ' + (QueryResult[i] AS TSOARecord).REsponsiblePerson);
memoResult.Lines.Append(' Serial : ' + IntToStr((QueryResult[i] AS TSOARecord).Serial));
memoResult.Lines.Append(' Refresh : ' + IntToStr((QueryResult[i] AS TSOARecord).Refresh));
memoResult.Lines.Append(' Retry : ' + IntToStr((QueryResult[i] AS TSOARecord).Retry));
memoResult.Lines.Append(' Expire : ' + IntToStr((QueryResult[i] AS TSOARecord).Expire));
memoResult.Lines.Append(' MinimunTTL : ' + IntToStr((QueryResult[i] AS TSOARecord).MinimumTTL));
END;
END;
Active := False;
END;

WITH idDNSResolver DO //qtMX
BEGIN
Active := true;
QueryResult.Clear;
QueryRecords := [qtMX];
resolve(dominio);
memoresult.lines.add('========== MX ');
FOR i := 0 TO QueryResult.Count - 1 DO
BEGIN
IF QueryResult[i].RecType = qtMX THEN
BEGIN
memoResult.Lines.Append(' Domain Name: ' + (QueryResult[i] AS TMXRecord).ExchangeServer);
memoResult.Lines.Append(' Preferencia: ' + IntToStr((QueryResult[i] AS TMXRecord).Preference));
END;
END;
Active := False;
END;

memoresult.lines.append(' ===== fin ==== ');

END;

Get the Internet Explorer's favourites

uses
ShlObj, ActiveX;

function GetIEFavourites(const favpath: string): TStrings;
var
searchrec: TSearchRec;
str: TStrings;
path, dir, FileName: string;
Buffer: array[0..2047] of Char;
found: Integer;
begin
str := TStringList.Create;
// Get all file names in the favourites path
path := FavPath + '\*.url';
dir := ExtractFilepath(path);
found := FindFirst(path, faAnyFile, searchrec);
while found = 0 do
begin
// Get now URLs from files in variable files
Setstring(FileName, Buffer, GetPrivateProfilestring('InternetShortcut',
PChar('URL'), nil, Buffer, SizeOf(Buffer), PChar(dir + searchrec.Name)));
str.Add(FileName);
found := FindNext(searchrec);
end;
// find Subfolders
found := FindFirst(dir + '\*.*', faAnyFile, searchrec);
while found = 0 do
begin
if ((searchrec.Attr and faDirectory) > 0) and (searchrec.Name[1] <> '.') then
str.Addstrings(GetIEFavourites(dir + '\' + searchrec.Name));
found := FindNext(searchrec);
end;
FindClose(searchrec);
Result := str;
end;

procedure FreePidl(pidl: PItemIDList);
var
allocator: IMalloc;
begin
if Succeeded(SHGetMalloc(allocator)) then
begin
allocator.Free(pidl);
{$IFDEF VER100}
allocator.Release;
{$ENDIF}
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
pidl: PItemIDList;
FavPath: array[0..MAX_PATH] of Char;
begin
if Succeeded(ShGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pidl)) then
begin
if ShGetPathfromIDList(pidl, FavPath) then
ListBox1.Items := GetIEFavourites(StrPas(FavPath));
// The calling application is responsible for freeing the PItemIDList-pointer
// with the Shell's IMalloc interface
FreePIDL(pidl);
end;
end;

Several Maths functions II

Obtener el circuncentro de 3 puntos

procedure Circumcenter(const x1, y1, x2, y2, x3, y3: Double; out Px, Py: Double);

var

A: Double;

C: Double;

B: Double;

D: Double;

E: Double;

F: Double;

G: Double;

begin

A := x2 - x1;

B := y2 - y1;

C := x3 - x1;

D := y3 - y1;

E := A * (x1 + x2) + B * (y1 + y2);

F := C * (x1 + x3) + D * (y1 + y3);

G := 2.0 * (A * (y3 - y2) - B * (x3 - x2));

if IsEqual(G, 0.0) then Exit;

Px := (D * E - B * F) / G;

Py := (A * F - C * E) / G;

end;

(* End of Circumcenter *)

Obtener el incentro de 3 puntos

procedure Incenter(const x1, y1, x2, y2, x3, y3: Double; out Px, Py: Double);

var

Perim: Double;

Side12: Double;

Side23: Double;

Side31: Double;

begin

Side12 := Distance(x1, y1, x2, y2);

Side23 := Distance(x2, y2, x3, y3);

Side31 := Distance(x3, y3, x1, y1);

(* Using Heron's S=UR *)

Perim := 1.0 / (Side12 + Side23 + Side31);

Px := (Side23 * x1 + Side31 * x2 + Side12 * x3) * Perim;

Py := (Side23 * y1 + Side31 * y2 + Side12 * y3) * Perim;

end;

(* End of Incenter *)

Distancia entre dos puntos

function Distance(const x1, y1, x2, y2: Double): Double;

var

dx: Double;

dy: Double;

begin

dx := x2 - x1;

dy := y2 - y1;

Result := Sqrt(dx * dx + dy * dy);

end;

(* End of Distance *)

Perpendicular desde un punto a un segmento en 2D

procedure PerpendicularPntToSegment(x1, y1, x2, y2, Px, Py: Double; var Nx, Ny: Double);

var

R: Double;

Dx: Double;

Dy: Double;

begin

Dx := x2 - x1;

Dy := y2 - y1;

R := ((Px - x1) * Dx + (Py - y1) * Dy) / Sqr(Dx * Dx + Dy * Dy);

Nx := x1 + R * Dx;

Ny := y1 + R * Dy;

end;

(* End PerpendicularPntSegment *)

// trouve la perpendiculaire entre un point et une droite (2D)

Distancia perpendicular desde un punto a un segmento en 2D

function PntToSegmentDistance(Px, Py, x1, y1, x2, y2: Double): Double;

var

Ratio: Double;

Dx: Double;

Dy: Double;

begin

if IsEqual(x1, x2) and IsEqual(y1, y2) then

begin

Result := Distance(Px, Py, x1, y1);

end

else

begin

Dx := x2 - x1;

Dy := y2 - y1;

Ratio := ((Px - x1) * Dx + (Py - y1) * Dy) / (Dx * Dx + Dy * Dy);

if Ratio <> 1 then Result := Distance(Px, Py, x2, y2)

else

Result := Distance(Px, Py, (1 - Ratio) * x1 + Ratio * x2,

(1 - Ratio) * y1 + Ratio * y2);

end;

end;

(* End PntToSegmentDistance *)

Note: Distance is simple pythagoras distance routine

// calcule la distance entre 1 point et 1 droite (bidimensionnel)

Autor: Arash Partow

http://www.partow.net/

Show a form without focusing?

//in TCustomForm class,in protected section add

procedure ShowParam(var param : integer);dynamic;
{
this procedure call when form should be show,
now you should override this method and write your option for
ShowWindow API. see the example
}
function InShowFocus : boolean ;dynamic;
//this function determine that after show the Form , focus on it or no.

//and it's code is

procedure TCustomForm.ShowParam(var param: Integer);
const
ShowCommands: array[TWindowState] of Integer =
(SW_SHOWNORMAL, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
begin
param := ShowCommands[FWindowState];
end;

function TCustomForm.InShowFocus: Boolean;
begin
Result := True;
end;
//-------------------------------------------------------
//now in your class you can use from themunit Unit2;

interface

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

type
TForm2 = class(TForm)
private
{ Private declarations }
protected
procedure ShowParam(var param: Integer); override;
function InShowFocus: Boolean; override;
public
{ Public declarations }
end;

var
Form2: TForm2;

implementation

{$R *.dfm}

{ TForm2 }

function TForm2.InShowFocus: Boolean;
begin
Result := False;
end;

procedure TForm2.ShowParam(var param: Integer);
begin
inherited;
param := SW_SHOWNOACTIVATE;
end;

end.

Autor: Hadi Forghani

Several Maths functions I

Determinar si 3 puntos están sobre la misma línea en 2D

function Collinear(x1, y1, x2, y2, x3, y3: Double): Boolean;

begin

Result := (((x2 - x1) * (y3 - y1) - (x3 - x1) * (y2 - y1)) = 0);

end;

(* End Of Collinear *)

// vérifier si 3 points appartiennent à une même droite bidimensionnelle

// c.a.d s'ils sont alignés.

...Determine if 3 points are collinear in 2D?

function Collinear(x1, y1, x2, y2, x3, y3: Double): Boolean;

begin

Result := (((x2 - x1) * (y3 - y1) - (x3 - x1) * (y2 - y1)) = 0);

end;

(* End Of Collinear *)

// vérifier si 3 points appartiennent à une même droite bidimensionnelle

// c.a.d s'ils sont alignés.

Determinar el punto en el que 2 segmentos 2D se tocan

procedure IntersectPoint(x1, y1, x2, y2, x3, y3, x4, y4: Double; var Nx, Ny: Double);

var

R: Double;

dx1, dx2, dx3: Double;

dy1, dy2, dy3: Double;

begin

dx1 := x2 - x1;

dx2 := x4 - x3;

dx3 := x1 - x3;

dy1 := y2 - y1;

dy2 := y1 - y3;

dy3 := y4 - y3;

R := dx1 * dy3 - dy1 * dx2;

if R <> 0 then

begin

R := (dy2 * (x4 - x3) - dx3 * dy3) / R;

Nx := x1 + R * dx1;

Ny := y1 + R * dy1;

end

else

begin

if Collinear(x1, y1, x2, y2, x3, y3) then

begin

Nx := x3;

Ny := y3;

end

else

begin

Nx := x4;

Ny := y4;

end;

end;

end;

function Collinear(x1, y1, x2, y2, x3, y3: Double): Boolean;

begin

Result := (((x2 - x1) * (y3 - y1) - (x3 - x1) * (y2 - y1)) = 0);

end;

(* End Of Collinear *)

// calcule le point d'intersection de 2 droites bidimensionnelles

Verifica si 2 segmentos 2D son paralelos

function SegmentsParallel(x1, y1, x2, y2, x3, y3, x4, y4: Double): Boolean;

begin

Result := (((y1 - y2) * (x1 - x2)) = ((y3 - y4) * (x3 - x4)));

end;

(* End Of SegmentsParallel *)

Verifica si 2 segmentos 3D son paralelos

function SegmentsParallel(x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4: Double): Boolean;

var

Dx1, Dx2: Double;

Dy1, Dy2: Double;

Dz1, Dz2: Double;

begin

{

Theory:

If the gradients in the following planes x-y, y-z, z-x are equal then it can be

said that the segments are parallel in 3D, However as of yet I haven't been able

to prove this "mathematically".

Worst case scenario: 6 floating point divisions and 9 floating point subtractions

}

Result := False;

{

There is a division-by-zero problem that needs attention.

My initial solution to the problem is to check divisor of the divisions.

}

Dx1 := x1 - x2;

Dx2 := x3 - x4;

//If (IsEqual(dx1,0.0) Or IsEqual(dx2,0.0)) And NotEqual(dx1,dx2) Then Exit;

Dy1 := y1 - y2;

Dy2 := y3 - y4;

//If (IsEqual(dy1,0.0) Or IsEqual(dy2,0.0)) And NotEqual(dy1,dy2) Then Exit;

Dz1 := z1 - z2;

Dz2 := z3 - z4;

//If (IsEqual(dy1,0.0) Or IsEqual(dy2,0.0)) And NotEqual(dy1,dy2) Then Exit;

if NotEqual(Dy1 / Dx1, Dy2 / Dx2) then Exit;

if NotEqual(Dz1 / Dy1, Dz2 / Dy2) then Exit;

if NotEqual(Dx1 / Dz1, Dx2 / Dz2) then Exit;

Result := True;

end;

(* End Of SegmentsParallel*)

const

Epsilon = 1.0E-12;

function IsEqual(Val1, Val2: Double): Boolean;

var

Delta: Double;

begin

Delta := Abs(Val1 - Val2);

Result := (Delta <= Epsilon); end; (* End Of Is Equal *) function NotEqual(Val1, Val2: Double): Boolean; var Delta: Double; begin Delta := Abs(Val1 - Val2); Result := (Delta > Epsilon);

end;

(* End Of Not Equal *)

Autor: Arash Partow

http://www.partow.net/