Redes neuronales con Delphi - Neural net with Delphi

En este post os presento el componente TFFNN que os ayudará a realizar redes neuronales.
Utiliza el algoritmo de retropropagación o propagación hacia atrás de los errores (en inglés backpropagation), método usado habitualmente para el entrenamiento de redes.

Se puede descargar desde aquí

www.datalandsoftware.com/files/ffnn.zip

Descomprimimos el componente sobre una carpeta llamada (p.ej) "redes neuronales" y desde nuestro Delphi accedemos a
File->Open

Seleccionamos FFNNPackage.dpk de la carpeta "redes neuronales" y pulsamos "Abrir"

En el ProjectGroup1 hacemos clic con el botón derecho del ratón sobre FNNPackage.bpl y activamos el menú "Install"




Con lo que se instalará el componente TFFNN en la pestaña "Dataland" de la paleta de componentes.
Guardamos y cerramos el ProjectGroup1 con File->Save All, y después File->Close.
Ahora vamos a crear una nueva aplicación de prueba:
File->New-> VCL Forms Application - Delphi for Win32


Arrastramos de la paleta de componentes (pestaña "dataland") "TFFNN" a nuestro Form, creamos un TMemo, y 4 botones (Entrenar, Mostrar, Cargar patrón de entrenamiento, Guardar patrón de entrenamiento)





Después tendremos que indicar los parámetros de nuestra red neuronal:
InputCount (Nº de entradas)=1
InputMax (Máximo número de entradas)=8
InputMin (Mínimo número de entradas)=-1
OutputCount (Nº de salidas)=1
OutputMax (Máximo número de salidas)=10
OutputMin (Mínimo número de salidas)=9
En NLayers indicaremos el número de capas de nuestra red (En este caso tendrá sólo una capa) y el número de neuronas de cada capa=2
Hay que indicar que cuanto mayor sea el número de capas y de neuronas más tiempo tardará la red en conseguir un entrenamiento óptimo.


OBJETIVO DE LA RED
Es la simulación de la función: y= 10 + x


DEFINICIÓN DE BOTONES:
Botón "Cargar patrón de entrenamiento":
FFNN1.LoadFromFile('redneural1.txt');

Botón "Guardar patrón de entrenamiento":
FFNN1.SaveToFile('redneural1.txt');

RedNeural1.txt es un fichero de texto con los parámetros y variables de nuestra red neuronal, que no hay que modificar bajo ningún concepto.

Botón "Entrenar":

procedure TForm1.EntrenarClick(Sender: TObject);
var
i: Integer;
begin
for i:=1 to 10000 do begin

FFNN1.Input[1]:=i mod 7; //Pone la entrada
FFNN1.DesiredOutput[1]:=func( i mod 7 ); //Pone lo que queremos que salga
FFNN1.BackProp; //Entrena la red con este par de valores(In, Out).
{ Cuando se usan vectores: Input, Output y DesiredOutput usan índices entre 1 y Count (Input[1], Input[2], Output[1]...
Los índices: Input[0], Output[0] y DesiredOutput[0] son reservados por la aplicación }
end;
end;

Quizás en este caso no sea necesario llegar a que el índice del bucle "i" llegue a 10000 ya que lo que se hace es que cuando el valor del error cuadrático medio sea menor que 0,01 (P.ej) se detenga el cálculo.
El Error cuadrático medio se calcula desde FFNN1.GetAvgError



Botón "Mostrar":

procedure TForm1.MostrarClick(Sender: TObject);
var
r, t: Real;
i: Integer;
begin
for i:=0 to 6 do begin
r:=i;
FFNN1.Input[1]:=r; //Pone un valor a la neurona de entrada nº 1
FFNN1.CalcOut; //Calcula la salida de la red neuronal. Después de esta linea podremos leer la salida
t:=FFNN1.Output[1];
FFNN1.DesiredOutput[1]:=func( i ); //Calculamos el valor que deseamos tenga en la salida
Memo1.Lines.Add(Format('%f %f %f %f', [r, t, FFNN1.GetAvgError, FFNN1.GetMaxError]));
//Ambos errores son los mismos ya que tenemos 1 output (Avg = Max)
end;
end;

function TForm1.func(x: Real): Real;
begin
//Entrenamos a la red para reproducir esta función
Result:=10 + x;
end;


Abajo os muestro los resultados después de entrenar a la red, como véis los resultados obtenidos se parecen bastante a los esperados con lo que podemos afirmar que la red ha sido entrenada correctamente.
Ahora debemos guardar los parámetros de la red con FFNN1.SaveToFile('redneural1.txt'), de tal forma que la próxima vez que queramos simular la función y=10+x no sea necesario entrenarla ya que bastaría con cargar el patrón de red previamente guardado con FFNN1.LoadFromFile('redneural1.txt').


Links relacionados:
Redes Neuronales y Bolsa
( Predicción de cotizaciones usando redes neuronales )
http://delphimagic.blogspot.com/2008/10/redes-neuronales-y-bolsa-prediccin-de.html




Como hacer hablar a Delphi - How to make Delphi to speak

Para que nuestras aplicaciones en Delphi puedan "hablar" lo primero que tenemos que hacer es guardar en la paleta "Additional" todos los componentes de la librería "Microsoft Speech Object Library" de la siguiente forma:

Ir a File->New-> Package Delphi for win 32

en el menú Component->Import Component y seleccionar "Import a type library"




Pulsar "Next>>" y en la relación de librerías registradas en tu sistema seleccionar

"Microsoft Speech Object Library" y pulsar "Next"

En la ventana siguiente indicar en Palette Page el item "additional" que es donde se guardarán cada uno de los componentes de esta librería

En la ventana siguiente marca "Add unit to ...."

y pulsa el botón "Finish"

Ahora vamos a cambiar el nombre al Package1.bpl y lo llamaremos SAPI.BPL


Pulsamos con el botón derecho del ratón sobre SAPI.BPL y ejecutamos el menú

"Compile" y después "Install"

Con lo que tendremos en la paleta "Additional" todos los componentes de la librería Microsoft Speech Object Library


Para que nuestra aplicación pueda reproducir voces (por ahora en inglés)

Tenemos que arrastrar el componente TSpVoice de la paleta "Additional" a nuestro Form y crear un botón con el siguiente código



procedure TForm1.Button1Click(Sender: TObject);

begin

spvoice1.Speak('hello who are you',0)

end;

How to convert a web app to use AJAX using D4PHP

How to update a MySQL DB with AJAX using D4PHP

Some Code Editor and Refactoring features in CodeGear Delphi

GRN and CodeGear Delphi: King of Languages

CodeGear C++ Builder... True RAD

ECO VCL.NET development with CodeGear RAD Studio

Build a Wordpad-like application with Delphi

Create the Interbase tables

Background

Next, create the table structures. This can be achieved in several ways. The easiest way is to take a simple text file, fill in the table structure, and "import" the structure to InterBase using IBConsole, as explained below. There is a separate section covering "Importing database changes using a SQL file" which will be of interest when you need to carry out the Importing process for the second time.

A simple text file has been provided with this guide (Tables.SQL) with illustrative file layouts. Change the layout(s) to the layout(s) you require, and import the structure into InterBase. You can change it easily later. Those who don't feel comfortable with what they are doing might want to see Creating tables - Tips, prior to "doing it".

Do it!

To create the tables:

Open "Tables.SQL" in any text editor (eg. Notepad, Delphi)


Change the file location within the "Connect" statement to the location to which you saved the Database


Change the "user" and "password" to the username and password used to create the database


Change the Table layout to the layout you want. (Want help with Datatypes? See InterBase Datatypes)


Save the file (Latest changes not used by InterBase? See Creating tables - Tips )


In the program IBConsole, click "Query, Load script"


Find the SQL file you saved, and click "Open".


Click "Query, Execute"


If you want the confirmation and/or the error messages to appear in the IBConsole window, click the "No" button. If you prefer them to be saved to disc in a simple text file, click the "Yes" button and give the program a file name and location to which the results will be written.


If successful - you will be told (well done!). (Failure? See Handling SQL script errors)

Web http://www.ibphoenix.com

Opening and closing a Database from Delphi

In the BDE, the Database is closed for you when you exit the program. This is not so with the InterBase Express components.
The solution is to have a IBDatabase1.close statement in the Form.OnClose event (or similar). If you forget to close the Database explicitly, it stays "open". If you try to open a database that is already open, using the TIBDatabase component, you get an error message. The solution is always to check with the database is open before opening it
(eg. of Delphi : if not (IBTransaction1.connected) then IBTransaction1.open; ) and closed before closing it (eg. of Delphi : if (IBTransaction1.connected) then IBTransaction1.close; - Note that when you close a database, the Transaction and any other component "connected" to that Database is also disconnected for you, whether you intended it or not.)

web http://www.ibphoenix.com

Creating indexes on Interbase

Indexes allow InterBase to locate data (dramatically) more quickly. An index has two key components to it - the field(s) that you will want to search on and whether the field(s) are unique (e.g. a Reference number will probably need to be unique, but you may well need to accommodate several people sharing a birth date or a last name).

One particular type of index that is usually needed is an index on the Field(s) which uniquely identify a record within a table (e.g. the unique reference number given to each record, or a Social Security ID, or a post code and House number/name combination within an Address table). This is called the Primary key. Those who don't feel comfortable with what they are doing might want to see Creating indexes - Tips, prior to "doing it".

Do it!
Creating the Primary Key

Open your "table.SQL" file.


Add a line at the bottom of the definition, immediately before the final ")", and add the phrase (with the comma in front)
, PRIMARY KEY (field)
where field is the name of the field(s) you want as the primary key, eg:
, PRIMARY KEY (REF) or another example: , PRIMARY KEY (LASTNAME, FIRSTNAME, POSTCODE)


If you have already created your table, see Creating indexes - Tips
Creating other Indexes

Open the "Indexes.SQL" file


Add a new index with the syntax (don't forget the semi-colon at the end):
CREATE INDEX NAME ON ANIMALS(NAME);
where "Animals" is the name of the table, and "Name" is the field on which to index (sort)

Web: http://www.ibphoenix.com

How to use IBDataset with a DataModule

Steps:
1 .- a Cree First Data Module, which will contain all components DB (querys, tables etc.). Ok
2 .- in the data block put the IBDataBase which will be used solely to be used throughout your application (the only other non habra ok)
3. Module in the same data (DataModule) put the IBQuerys the IBUpdates and IBTransaction .. OK
in IBQuery.SQL there you can put your select * from table (eye code but not under the inspector objects) ok.
4 .- then put the IBUpdateSQL connected to that query ok ..
5 .- then add your form unity Module data you created, so that they can gain access to components put in DataModule ok. (Uses name of the unit)
6 .- as you put the following components:
DataSource which connects to the IBQuery ok, then put a DBEdit this connect to the DataSource and then select the field you want to display in DBEdit (DataSource properties and DataField respectively)
7. There are other components as DBGrid and DBNavigator lso which connect like the DBEdit ok.
Well this is Oriented Programming to objects and thus do not have to do this to me mention:
With IBDataset1 do
Try
DisableControls;
SelectSQL.Add ( 'Select *');
SelectSQL.Add ( 'FROM products');
SelectSQL.Add ( 'where Name =' + Combobox1.Text);
Edit1.Text: = FloatToStr (IBDataset1.Fields.Fields [3]. AsFloat);
Finally
EnableControls;
End;

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/


Relacionados

Rotación de un octaedro
Modelado 3D con Delphi

Funciones relacionadas con la geometria
Funciones estadisticas, xml en Delphi

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/

Links relacionados:
Rotación de un octaedro
Modelado 3D con Delphi

Download a Jpeg Image to Bimap

uses Jpeg, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP;

{ .... }

function DownloadJPGToBitmap(const URL : string; ABitmap: TBitmap): Boolean;
var
idHttp: TIdHTTP;
ImgStream: TMemoryStream;
JpgImage: TJPEGImage;
begin
Result := False;
ImgStream := TMemoryStream.Create;
try
idHttp := TIdHTTP.Create(nil);
try
idHttp.Get(URL, ImgStream);
finally
idHttp.Free;
end;
ImgStream.Position := 0;
JpgImage := TJPEGImage.Create;
try
JpgImage.LoadFromStream(ImgStream);
ABitmap.Assign(JpgImage);
finally
Result := True;
JpgImage.Free;
end;
finally
ImgStream.Free;
end;
end;


// Example:
// Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
begin
DownloadJPGToBitmap('http://www.sample.com/test.jpg', Image1.Picture.Bitmap);
end;

Autor: Thomas Stutz

Retrieve all image links from an HTML document

uses mshtml, ActiveX, COMObj, IdHTTP, idURI;

{ .... }

procedure GetImageLinks(AURL: string; AList: TStrings);
var
IDoc: IHTMLDocument2;
strHTML: string;
v: Variant;
x: Integer;
ovLinks: OleVariant;
DocURL: string;
URI: TidURI;
ImgURL: string;
idHTTP: TidHTTP;
begin
AList.Clear;
URI := TidURI.Create(AURL);
try
DocURL := 'http://' + URI.Host;
if URI.Path <> '/' then
DocURL := DocURL + URI.Path;
finally
URI.Free;
end;
Idoc := CreateComObject(Class_HTMLDocument) as IHTMLDocument2;
try
IDoc.designMode := 'on';
while IDoc.readyState <> 'complete' do
Application.ProcessMessages;
v := VarArrayCreate([0, 0], VarVariant);
idHTTP := TidHTTP.Create(nil);
try
strHTML := idHTTP.Get(AURL);
finally
idHTTP.Free;
end;
v[0] := strHTML;
IDoc.Write(PSafeArray(System.TVarData(v).VArray));
IDoc.designMode := 'off';
while IDoc.readyState <> 'complete' do
Application.ProcessMessages;
ovLinks := IDoc.all.tags('IMG');
if ovLinks.Length > 0 then
begin
for x := 0 to ovLinks.Length - 1 do
begin
ImgURL := ovLinks.Item(x).src;
// The stuff below will probably need a little tweaking
// Deteriming and turning realtive URLs into absolute URLs
// is not that difficult but this is all I could come up with
// in such a short notice.
if (ImgURL[1] = '/') then
begin
// more than likely a relative URL so
// append the DocURL
ImgURL := DocURL + ImgUrl;
end
else
begin
if (Copy(ImgURL, 1, 11) = 'about:blank') then
begin
ImgURL := DocURL + Copy(ImgUrl, 12, Length(ImgURL));
end;
end;
AList.Add(ImgURL);
end;
end;
finally
IDoc := nil;
end;
end;


// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
GetImageLinks('http://delphimagic.blogspot.com', Memo1.Lines);
end;

Connect/Disconnect network drives

//we could use the standard dialog to have the user do it
procedure TForm1.Button1Click(Sender: TObject);
begin
WNetConnectionDialog(Handle, RESOURCETYPE_DISK)
end;
//we can use the same to connect a printer
procedure TForm1.Button1Click(Sender: TObject);
begin
WNetConnectionDialog(Handle, RESOURCETYPE_PRINT)
end;
//or we can do this by code
procedure TForm1.Button2Click(Sender: TObject);
var
NetResource: TNetResource;
begin
{ fill out TNetResource record structure }
NetResource.dwType := RESOURCETYPE_DISK;
NetResource.lpLocalName := 'S:';
NetResource.lpRemoteName := '\\myserver\public';
NetResource.lpProvider := '';
{ map our network drive using our TNetResource record structure }
if (WNetAddConnection2(NetResource,
'', {Password (if needed) or empty}
'', {User name (if needed) or empty}
CONNECT_UPDATE_PROFILE) <> NO_ERROR) then
raise Excepcion.Create('unable to map drive')
//there are other constants to check the error
//ERROR_ACCESS_DENIED, ERROR_ALREADY_ASSIGNED, etc
end;
//to disconnect it simply...
procedure TForm1.Button2Click(Sender: TObject);
begin
if WNetCancelConnection2('S:', 0, TRUE) <> NO_ERROR then
raise Exception.create('Error disconnecting map drive');
//of course there are also some other constants to check why the error
//occurred: ERROR_DEVICE_IN_USE, ERROR_NOT_CONNECTED, etc
end;

Author: Eber Irigoyen
Product: Delphi 2.x (or higher)

Implement Net Send

function NetSend(dest, Source, Msg: string): Longint; overload;
type
TNetMessageBufferSendFunction = function(servername, msgname, fromname: PWideChar;
buf: PWideChar; buflen: Cardinal): Longint; stdcall;
var
NetMessageBufferSend: TNetMessageBufferSendFunction;
SourceWideChar: PWideChar;
DestWideChar: PWideChar;
MessagetextWideChar: PWideChar;
Handle: THandle;
begin
Handle := LoadLibrary('NETAPI32.DLL');
if Handle = 0 then
begin
Result := GetLastError;
Exit;
end;
@NetMessageBufferSend := GetProcAddress(Handle, 'NetMessageBufferSend');
if @NetMessageBufferSend = nil then
begin
Result := GetLastError;
Exit;
end;
MessagetextWideChar := nil;
SourceWideChar := nil;
DestWideChar := nil;
try
GetMem(MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);
GetMem(DestWideChar, 20 * SizeOf(WideChar) + 1);
StringToWideChar(Msg, MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);
StringToWideChar(Dest, DestWideChar, 20 * SizeOf(WideChar) + 1);
if Source = '' then
Result := NetMessageBufferSend(nil, DestWideChar, nil,
MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1)
else
begin
GetMem(SourceWideChar, 20 * SizeOf(WideChar) + 1);
StringToWideChar(Source, SourceWideChar, 20 * SizeOf(WideChar) + 1);
Result := NetMessageBufferSend(nil, DestWideChar, SourceWideChar,
MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);
FreeMem(SourceWideChar);
end;
finally
FreeMem(MessagetextWideChar);
FreeLibrary(Handle);
end;
end;
function NetSend(Dest, Msg: string): Longint; overload;
begin
Result := NetSend(Dest, '', Msg);
end;
function NetSend(Msg: string): Longint; overload;
begin
Result := NetSend('', '', Msg);
end;
Example:
procedure TForm1.Button1Click(Sender: TObject);
const
NERR_BASE = 2100;
NERR_NameNotFound = NERR_BASE + 173;
NERR_NetworkError = NERR_BASE + 36;
NERR_Success = 0;
var
Res: Longint;
sMsg: string;
begin
Res := NetSend('LoginName', 'Your Message...');
case Res of
ERROR_ACCESS_DENIED: sMsg :=
'user does not have access to the requested information.';
ERROR_INVALID_PARAMETER: sMsg := 'The specified parameter is invalid.';
ERROR_NOT_SUPPORTED: sMsg := 'This network request is not supported.';
NERR_NameNotFound: sMsg := 'The user name could not be found.';
NERR_NetworkError: sMsg := 'A general failure occurred in the network hardware.';
NERR_Success: sMsg := 'Message sent!';
end;
ShowMessage(sMsg);
end;

Checking for a LAN connection


To check for a LAN connection, various things can be done, like checking for your user name, or retrieving logon information from the registry, but they can all fail if you consider a dock able notebook. The following function searches for actual existing connections.


const
MAX_NEIGHBORS = 20;
function NetAvailable: Boolean;
var
NetRes: array[0..MAX_NEIGHBORS] of TNetResource;
NNError,
hEnum,
EntryCount,
NetResLen: DWORD;
loop1: Integer;
begin
hEnum := 0;
Result := FALSE;
try
NNError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, nil, hEnum);
if NNError = NO_ERROR then
begin
while NNError <> ERROR_NO_MORE_ITEMS do
begin
EntryCount := 1;
NetResLen := SizeOf(NetRes);
NNError := WNetEnumResource(hEnum, EntryCount, @NetRes, NetResLen);
if (NNError = NO_ERROR) then
begin
for loop1 := 1 to EntryCount do
begin
if Pos('Microsoft', NetRes[0].lpProvider) = 1 then
begin
Result := TRUE;
Break
end
end
end
else
begin
Break
end
end;
WNetCloseEnum(hEnum)
// close enum
end
except
on exception do
begin
ShowMessage('Network Neighborhood Detection Failed.')
end;
end
end;

how to transfer an object over a socket

In my project, I have to be able to transfer an object between clients and servers. I have tried to write some codes. Unluckily, there is always an exception "out of memory while expanding memory stream". I dont know why. Hope someone can help me. thanks. By the way, I use Indy to build connections.

unit Data;
interface
uses
Classes;
Type
TData = class(TComponent)
private
FStr : String;
public
constructor Create(AnOwner : TComponent); override;
destructor Destroy; override;
published
property Str : String read FStr write FStr;
end;
implementation
constructor TData.Create(AnOwner : TComponent);
begin
inherited Create(AnOwner);
FStr := 'It is created!!!';
end;
destructor TData.Destroy;
begin
inherited Destroy;
end;
end.
??????????????????????????????????????????????????????????????????????
implementation
{$R *.dfm}
uses
Data;
procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPServer1.Active := true;
end;
procedure TForm1.IdTCPServer1Connect(AThread: TIdPeerThread);
begin
Button1.Caption := 'a client';
end;
procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
var
FData : TData;
FStream : TMemoryStream;
begin
FData := TData.Create(nil);
FStream := TMemoryStream.Create;
AThread.Connection.ReadStream(FStream);
FStream.ReadComponent(FData); // Here the exception comes up!!!
Edit1.Text := FData.Str;
FStream.Free;
FData.Free;
end;
end.

????????????????????????????????????????????????????????????????????
implementation
uses Data;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPClient1.Connect();
Button1.Caption := 'OK';
end;
procedure TForm1.Button2Click(Sender: TObject);
var
FData : TData;
FStream : TMemoryStream;
begin
FData := TData.Create(nil);
FStream := TMemoryStream.Create;
FStream.WriteComponent(FData);
IdTCPClient1.WriteStream(FStream);
FStream.Free;
FData.Free;
end;
end.


Author: Mohammad Qermezkon
Product: Delphi 2.x (or higher)

Search for shared folders in a network


How to search for shared folders in a network


You will need a listbox, a radiogroup with 3 radio buttons and of course a button. It takes a while depending on the size of your network.
procedure TForm1.EnumNetResources(List: TStrings);

procedure EnumFunc(NetResource: PNetResource);
var
Enum: THandle;
Count, BufferSize: DWORD;
Buffer: array[0..16384 div SizeOf(TNetResource)] of TNetResource;
i: Integer;
begin
if WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, NetResource,
Enum) = NO_ERROR then
try
Count := $FFFFFFFF;
BufferSize := SizeOf(Buffer);
while WNetEnumResource(Enum, Count, @Buffer, BufferSize) = NO_ERROR do
for i := 0 to Count - 1 do
begin
case RadioGroup1.ItemIndex of
0:
begin {Network Machines}
if Buffer[i].dwType = RESOURCETYPE_ANY then
List.Add(Buffer[i].lpRemoteName);
end;
1:
begin {Shared Drives}
if Buffer[i].dwType = RESOURCETYPE_DISK then
List.Add(Buffer[i].lpRemoteName);
end;
2:
begin {Printers}
if Buffer[i].dwType = RESOURCETYPE_PRINT then
List.Add(Buffer[i].lpRemoteName);
end;
end;
if (Buffer[i].dwUsage and RESOURCEUSAGE_CONTAINER) > 0 then
EnumFunc(@Buffer[i])
end;
finally
WNetCloseEnum(Enum);
end;
end;

begin
EnumFunc(nil);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Listbox1.Clear;
Screen.Cursor := crHourglass;
EnumNetResources(ListBox1.Items);
Screen.Cursor := crDefault;
end;

Finding all computers in a workgroup


var
Computer: array[1..500] of string[25];
ComputerCount: Integer;


procedure FindAllComputers(Workgroup: string);
var
EnumHandle: THandle;
WorkgroupRS: TNetResource;
Buf: array[1..500] of TNetResource;
BufSize: Integer;
Entries: Integer;
Result: Integer;
begin
ComputerCount := 0;
Workgroup := Workgroup + #0;
FillChar(WorkgroupRS, SizeOf(WorkgroupRS), 0);
with WorkgroupRS do
begin
dwScope := 2;
dwType := 3;
dwDisplayType := 1;
dwUsage := 2;
lpRemoteName := @Workgroup[1];
end;
WNetOpenEnum(RESOURCE_GLOBALNET,
RESOURCETYPE_ANY,
0,
@WorkgroupRS,
EnumHandle);
repeat
Entries := 1;
BufSize := SizeOf(Buf);
Result :=WNetEnumResource(EnumHandle,Entries,@Buf,BufSize);
if (Result = NO_ERROR) and (Entries = 1) then
begin
Inc(ComputerCount);
Computer[ComputerCount] := StrPas(Buf[1].lpRemoteName);
end;
until (Entries <> 1) or (Result <> NO_ERROR);
WNetCloseEnum(EnumHandle);
end; { Find All Computers }


Author: Erwin Molendijk

Disable the mouse wheel

Is there any way to disable the mouse wheel for a particular application or form?

Answer:

You can use a handler for the Application.OnMessage event to filter out messages (e.g WM_MOUSEWHEEL) before any control in your application sees them. Note that this will not work with all mouse drivers. There are some that can be configured to not post the standard wheel messages but to send WM_VSCROLL messages instead if the control under the mouse has scrollbars. This "compatibility mode" is there to make the wheel usable with applications that do not have wheel support build in.

procedure TMainForm.FormCreate(Sender: TObject);
begin
Application.OnMessage := AppMessage;
end;
procedure TMainform.Appmessage(var Msg: TMsg; var Handled: Boolean);
begin
Handled := msg.Message = WM_MOUSEWHEEL;
end;

If you only want to do this for a specific form class you would modify this method to

procedure TMainform.Appmessage(var Msg: TMsg; var Handled: Boolean);
begin
Handled := (msg.Message = WM_MOUSEWHEEL) and
(Screen.Activeform is TMySpecialFormclass);
end;

Author: Peter Below

Remote port scanner


Ever needed to test open ports on your machine?


Answer:
You can write a small utility for this purpose in Delphi, using sockects... here's my approach.
Use this code under you own risk, I present this article for educational purposes only, I take no responsability for the use of it.
I'll put a link to the whole demo, here's the unit, I'm sure you can recreate the form and run this:
unit PortScanU;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ScktComp;
type
TMainForm = class(TForm)
LblIPAddress: TLabel;
IPAddressE: TEdit;
lblScanRange: TLabel;
MinPortE: TEdit;
lblPorttoport: TLabel;
MaxPortE: TEdit;
StatusL: TLabel;
ActivityLB: TListBox;
StartBtn: TButton;
WSsocket: TClientSocket;
StopBtn: TButton;
OpenOnlyCB: TCheckBox;
procedure StartBtnClick(Sender: TObject);
procedure WSsocketConnect(Sender: TObject; Socket: TCustomWinSocket);
procedure WSsocketError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure StopBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
PortX, MaxPort: Integer;
IsRunning: Boolean;
procedure SetStuffOnOff(const St: Boolean);
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.dfm}
procedure TMainForm.SetStuffOnOff(const St: Boolean);
begin
IsRunning := St;
StopBtn.Enabled := St;
StartBtn.Enabled := not St;
if not (St) then
begin
ActivityLB.Items.Add('Done Scanning ' + IPAddressE.text);
StatusL.Caption := 'Status:'
end
end;
procedure TMainForm.StartBtnClick(Sender: TObject);
begin
ActivityLB.Items.Clear;
PortX := StrToInt(MinPortE.text);
MaxPort := StrToInt(MaxPortE.text);
wsSocket.Address := IPAddressE.text;
wsSocket.Port := PortX;
wsSocket.Active := True;
SetStuffOnOff(True);
ActivityLB.Items.Add('Beginning scan: ' + IPAddressE.text)
end;
procedure TMainForm.WSsocketConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
//socket connection made
//port must be open!
ActivityLB.Items.Add('PORT: ' + inttostr(PortX) + '; OPEN!');
//try next port...
wsSocket.Active := False;
PortX := PortX + 1;
wsSocket.Port := PortX;
StatusL.Caption := 'Scanning port:[' + IntToStr(PortX) + ']';
if (IsRunning) then
if (PortX > MaxPort) then
SetStuffOnOff(False)
else
wsSocket.Active := True //test the new port
end;
procedure TMainForm.WSsocketError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
//connection failed....
ErrorCode := 0; //handle the error
if not (OpenOnlyCB.Checked) then
ActivityLB.Items.Add('Port: ' + inttostr(PortX) + '; Closed.');
//try next port
wsSocket.Active := False; //close it
PortX := PortX + 1; //new port to check
wsSocket.Port := PortX; //put the port in the socket
StatusL.Caption := 'Scanning port:[' + IntToStr(PortX) + ']';
if (IsRunning) then
if (PortX > MaxPort) then
SetStuffOnOff(False)
else
wsSocket.Active := True //test the new port
end;
procedure TMainForm.StopBtnClick(Sender: TObject);
begin
SetStuffOnOff(False);
wssocket.Active := False;
ActivityLB.Items.Add('Stoped scan; port ' + inttostr(PortX) + '!')
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
IsRunning := False
end;
end.


as you can see, the idea is pretty easy...


set the address
set the port
try to activate the socket
and check if it went good
next port, repeat steps


note:to test ports on your local machine you need to set IPAddressE.Text:='localhost'

Author: Eber Irigoyen
Product: Delphi 2.x (or higher)

Enumerating Network Connections

How to detecting current network connections?

Answer:

From the MS-DOS prompt, you can enumerate the network connections (drives) by using the following command:

net use

Programmatically, you would call WNetOpenEnum() to start the enumeration of connected resources and WNetEnumResources() to continue the enumeration.

The following sample code enumerates the network connections:

Sample Code
procedure TForm1.Button1Click(Sender: TObject);
var
i, dwResult: DWORD;
hEnum: THANDLE;
lpnrDrv,
lpnrDrvLoc: PNETRESOURCE;
s: string;
const
cbBuffer: DWORD = 16384;
cEntries: DWORD = $FFFFFFFF;
begin
dwResult := WNetOpenEnum(RESOURCE_CONNECTED,
RESOURCETYPE_ANY,
0,
nil,
hEnum);
if (dwResult <> NO_ERROR) then
begin
ShowMessage('Cannot enumerate network drives.');
Exit;
end;
s := '';
repeat
lpnrDrv := PNETRESOURCE(GlobalAlloc(GPTR, cbBuffer));
dwResult := WNetEnumResource(hEnum, cEntries, lpnrDrv, cbBuffer);
if (dwResult = NO_ERROR) then
begin
s := 'Network drives:'#13#10;
lpnrDrvLoc := lpnrDrv;
for i := 0 to cEntries - 1 do
begin
if lpnrDrvLoc^.lpLocalName <> nil then
s := s + lpnrDrvLoc^.lpLocalName + #9 + lpnrDrvLoc^.lpRemoteName + #13#10;
Inc(lpnrDrvLoc);
end;
end
else if dwResult <> ERROR_NO_MORE_ITEMS then
begin
s := s + 'Cannot complete network drive enumeration';
GlobalFree(HGLOBAL(lpnrDrv));
break;
end;
GlobalFree(HGLOBAL(lpnrDrv));
until (dwResult = ERROR_NO_MORE_ITEMS);
WNetCloseEnum(hEnum);
if s = '' then
s := 'No network connections.';
ShowMessage(s);
end;


Author: Igor Siticov
Product: Delphi 3.x (or higher)

Read video modes

Put a TMemo in a Form

Procedure TForm1.VideoModes;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add( Format( 'Screen: %dx%d ', [Screen.Width, Screen.Height] ) );
Memo1.Lines.Add( Format( 'Desktop: x: %d y: %d With: %d Height: %d', [Screen.DesktopLeft, Screen.DesktopTop, Screen.DesktopWidth, Screen.DesktopHeight] ) );
Memo1.Lines.Add( Format( 'Work area: x: %d y: %d With: %d Height: %d', [Screen.WorkAreaLeft, Screen.WorkAreaTop, Screen.WorkAreaWidth, Screen.WorkAreaHeight] ) );
end;

Disable XP Firewall

procedure DisableFirewall;

var SCM, hService: LongWord;

sStatus: TServiceStatus;

begin

SCM := OpenSCManager( nil, nil, SC_MANAGER_ALL_ACCESS );

hService := OpenService( SCM, PChar( 'SharedAccess' ), SERVICE_ALL_ACCESS );

ControlService( hService, SERVICE_CONTROL_STOP, sStatus );

CloseServiceHandle( hService );

end;

Conversions between units of measurement

You must use the units
ConvUtils and StdConvs

Convert (value: Double; FromUnit, ToUnit: TConvType): Double;

Example:

Convert inch to centimeters


VAR inch, cnetimeters: Double;
BEGIN
inch: = 21;
Centimeters: Convert = (inch, auSquareInches, auSquareCentimeters);
Memo.Lines.Add(Format('%8.4f inch of area = %8.4f centimeters of area ', [inch, centimeters]));

Convert Decimal to Roman Number


FUNCTION DecToRoman(Decimal: LongInt): STRING;
CONST Numbers: ARRAY[1..13] OF Integer = (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);
Roman: ARRAY[1..13] OF STRING = ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');
VAR
i: Integer;
BEGIN
Result := '';
FOR i := 13 DOWNTO 1 DO
WHILE (Decimal >= Numbers[i]) DO
BEGIN
Decimal := Decimal - Numbers[i];
Result := Result + Roman[i];
END;
END;

Convert Integer to Binary


FUNCTION IntToBin(value, digits: integer): STRING;
VAR
resultado: STRING;
i: integer;
BEGIN
IF digitos > 32 THEN
digitos := 32;
Resultado := '';
i := 0;
WHILE i < digitos DO
BEGIN
IF ((1 SHL i) AND valor) > 0 THEN
Resultado := '1' + resultado
ELSE
Resultado := '0' + resultado;
inc(i);
END;
Result := resultado;
END;



Other function


FUNCTION IntToBin(Value: LongInt; Size: Integer): STRING;
VAR
i: Integer;
BEGIN
Result := '';
FOR i := Size - 1 DOWNTO 0 DO
Result := Result + Chr(48 + Integer((Value AND (1 SHL i)) <> 0));
END;