Webcam con Delphi ( III )

Continuando con el proyecto de manejo de una webcam con Delphi os presento el procedimiento para detener la grabación de una secuencia de video:



Tenéis que crear un tButton llamado "PararVideo" y en el evento Onclick teclear lo siguiente:



PROCEDURE TForm1.PararVideoClick(Sender: TObject);

BEGIN

IF ventana <> 0 THEN

BEGIN

SendMessage(ventana, WM_CAP_STOP, 0, 0);

END;

END;







UNIT WEBCAM

============



unit Webcam;
interface
uses
Windows, Messages;
type
TWebcam = class
constructor Create(
const WindowName: String = '';
ParentWnd: Hwnd = 0;
Left: Integer = 0;
Top: Integer = 0;
Width: Integer = 0;
height: Integer = 0;
Style: Cardinal = WS_CHILD or WS_VISIBLE;
WebcamID: Integer = 0);
public
const
WM_Connect = WM_USER + 10;
WM_Disconnect = WM_USER + 11;
WM_GrabFrame = WM_USER + 60;
WM_SaveDIB = WM_USER + 25;
WM_Preview = WM_USER + 50;
WM_PreviewRate = WM_USER + 52;
WM_Configure = WM_USER + 41;
public
procedure Connect;
procedure Disconnect;
procedure GrabFrame;
procedure SaveDIB(const FileName: String = 'webcam.bmp');
procedure Preview(&on: Boolean = True);
procedure PreviewRate(Rate: Integer = 42);
procedure Configure;
private
CaptureWnd: HWnd;
end;
implementation
function capCreateCaptureWindowA(
WindowName: PChar;
dwStyle: Cardinal;
x,y,width,height: Integer;
ParentWin: HWnd;
WebcamID: Integer): Hwnd; stdcall external 'AVICAP32.dll';
{ TWebcam }
procedure TWebcam.Configure;
begin
if CaptureWnd <> 0 then
SendMessage(CaptureWnd, WM_Configure, 0, 0);
end;
procedure TWebcam.Connect;
begin
if CaptureWnd <> 0 then
SendMessage(CaptureWnd, WM_Connect, 0, 0);
end;
constructor TWebcam.Create(const WindowName: String; ParentWnd: Hwnd; Left, Top,
Width, height: Integer; Style: Cardinal; WebcamID: Integer);
begin
CaptureWnd := capCreateCaptureWindowA(PChar(WindowName), Style, Left, Top, Width, Height,
ParentWnd, WebcamID);
end;
procedure TWebcam.Disconnect;
begin
if CaptureWnd <> 0 then
SendMessage(CaptureWnd, WM_Disconnect, 0, 0);
end;
procedure TWebcam.GrabFrame;
begin
if CaptureWnd <> 0 then
SendMessage(CaptureWnd, WM_GrabFrame, 0, 0);
end;
procedure TWebcam.Preview(&on: Boolean);
begin
if CaptureWnd <> 0 then
if &on then
SendMessage(CaptureWnd, WM_Preview, 1, 0)
else
SendMessage(CaptureWnd, WM_Preview, 0, 0);
end;
procedure TWebcam.PreviewRate(Rate: Integer);
begin
if CaptureWnd <> 0 then
SendMessage(CaptureWnd, WM_PreviewRate, Rate, 0);
end;
procedure TWebcam.SaveDIB(const FileName: String);
begin
if CaptureWnd <> 0 then
SendMessage(CaptureWnd, WM_SaveDIB, 0, Cardinal(PChar(FileName)));
end;
end.

 

=================

EJEMPLO DE USO

===============

 

en el evento OnCreate:

... 

  private
{ Private declarations }
public
{ Public declarations }
camera: TWebcam;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
camera := TWebcam.Create('WebCaptured', Panel1.Handle, 0, 0,
1000, 1000);
end;

 

 

 

ENCENDIDO Y APAGADO DE LA CAMARA:

================================= 

procedure TForm1.Button1Click(Sender: TObject);
const
str_Connect = 'Encender la camara';
str_Disconn = 'Apagar la camara';
begin
if (Sender as TButton).Caption = str_Connect then begin
camera.Connect;
camera.Preview(true);
Camera.PreviewRate(4);
(Sender as TButton).Caption:=str_Disconn;
end
else begin
camera.Disconnect;
(Sender as TButton).Caption:=str_Connect;
end;
end;




CAPTURA DE LA FOTO

==================

procedure TForm1.Button2Click(Sender: TObject);
var
PanelDC: HDC;
begin
if not Assigned(Image1.Picture.Bitmap) then
Image1.Picture.Bitmap := TBitmap.Create
else
begin
Image1.Picture.Bitmap.Free;
Image1.picture.Bitmap := TBitmap.Create;
end;
Image1.Picture.Bitmap.Height := Panel1.Height;
Image1.Picture.Bitmap.Width := Panel1.Width;
Image1.Stretch := True;
PanelDC := GetDC(Panel1.Handle);
try
BitBlt(Image1.Picture.Bitmap.Canvas.Handle,
0,0,Panel1.Width, Panel1.Height, PanelDC, 0,0, SRCCOPY);
finally
ReleaseDC(Handle, PanelDC);
end;
end;

 




Webcam con Delphi ( II )

A continuación os muestro nuevas utilidades para usar una webcam con Delphi.



ALMACENAR UNA SECUENCIA DE VIDEO

Nuevos componentes del form:



tSaveDialog,Definición de propiedades:

- Name = Guardar



tButtonDefinición de propiedades:

- Name = BtnAlmacenarVideo

- Caption = AlmacenarVideo



En el Evento Onclic del tButton poner





PROCEDURE TForm1.BtnAlmacenarVideoClick(Sender: TObject);
BEGIN
IF Ventana <> 0 THEN
BEGIN
Guardar.Filter := 'Fichero AVI (*.avi)*.avi';
Guardar.DefaultExt := 'avi';
Guardar.FileName := 'FicheroAvi';
IF Guardar.Execute THEN
BEGIN
SendMessage(Ventana, WM_CAP_FILE_SET_CAPTURE_FILEA, 0,
Longint(pchar(Guardar.Filename)));
SendMessage(Ventana, WM_CAP_SEQUENCE, 0, 0);
END;
END;
END;







GUARDAR UNA FOTO DE LA VENTANA DE CAPTURA

Añadir un tButton



tButtonDefinición de propiedades:

- Name = BtnGuardarImagen

- Caption = Guardar Imagen



Código del Botón





PROCEDURE TForm1.BtnGuardarImagenClick(Sender: TObject); 
BEGIN
IF Ventana <> 0 THEN
BEGIN
Guardar.FileName := 'Captura de la imagen';
Guardar.DefaultExt := 'bmp';
Guardar.Filter := 'Fichero Bitmap (*.bmp)*.bmp';
IF Guardar.Execute THEN
SendMessage(Ventana, WM_CAP_SAVEDIB, 0,
longint(pchar(Guardar.FileName)));
END;
END;







Webcam con Delphi (I)


A continuación os presento el software que os permitirá manejar vuestra Webcam con Delphi.



Primeramente tenéis que instalar en vuestro sistema el software "Microsoft Video for Windows SDK " que contiene la librería Avicap32.dll.

Dentro de las funciones que contiene utilizaremos "capCreateCaptureWindowA" para inicializar el driver y capturar la imagen.

Después para manejar la ventana de captura tendremos que usar la función "SendMessage" lo que facilita y simplifica muchísimo el trabajo a los programadores.




Ahora vamos con el programa:



Como variables globales añadimos:



Ventana: hwnd; //Handle de la ventana de captura



En la sección "const" escribimos:





WM_CAP_START = WM_USER;

WM_CAP_STOP = WM_CAP_START + 68;

WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10;

WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11;

WM_CAP_SAVEDIB = WM_CAP_START + 25;

WM_CAP_GRAB_FRAME = WM_CAP_START + 60;

WM_CAP_SEQUENCE = WM_CAP_START + 62;

WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20;

WM_CAP_EDIT_COPY = WM_CAP_START + 30;

WM_CAP_SET_PREVIEW = WM_CAP_START + 50;

WM_CAP_SET_PREVIEWRATE = WM_CAP_START + 52;





En la sección "implementation":





FUNCTION capCreateCaptureWindowA(lpszWindowName: PCHAR; dwStyle: longint; x: integer; y: integer; nWidth: integer; nHeight: integer; ParentWin: HWND; nId: integer): HWND; STDCALL EXTERNAL 'AVICAP32.DLL';





Es la llamada a la librería externa Avicap32.dll



Elementos de la interface:



-Botón "iniciar" (Al pulsarlo empezará la captura de la imagen procedente de la Webcam)



-Botón "detener" (Para parar la captura de la imagen)



-Control de Imagen "tImage" (lo llamaremos "Image1")







El código que se incluirá dentro de los botones es el siguiente:



Botón "Iniciar"

PROCEDURE TForm1.Button1Click(Sender: TObject);
BEGIN
Ventana := capCreateCaptureWindowA('Ventana de captura',
WS_CHILD OR WS_VISIBLE, image1.Left, image1.Top, image1.Width,
image1.Height, form1.Handle, 0);
IF Ventana <> 0 THEN
BEGIN
TRY
SendMessage(Ventana, WM_CAP_DRIVER_CONNECT, 0, 0);
SendMessage(Ventana, WM_CAP_SET_PREVIEWRATE, 40, 0);
SendMessage(Ventana, WM_CAP_SET_PREVIEW, 1, 0);
EXCEPT
RAISE;
END;
END
ELSE
BEGIN
MessageDlg('Error al conectar Webcam', mtError, [mbok], 0);
END;
END;



Botón "Detener"







PROCEDURE TForm1.Button2Click(Sender: TObject);
BEGIN
IF Ventana <> 0 THEN
BEGIN
SendMessage(Ventana, WM_CAP_DRIVER_DISCONNECT, 0, 0);
Ventana := 0;
END;
END;



En el evento Onclose deberemos hacer una llamada al procedimiento incluido en el botón "Detener".

Y eso es todo por ahora, en posteriores artículos iremos añadiendo más utilidades.











Calcular el PageRank con Delphi

A continuación os presento cómo calcular el pagerank de una página web con Delphi.

¿ QUÉ ES PAGERANK ?

Es una marca registrada y patentada por Google el 9 de enero de 1999 que ampara una familia de algoritmos utilizados para asignar de forma numérica la relevancia de los documentos (o páginas web) indexados por un motor de búsqueda

El algoritmo inicial lo podemos encontrar en el documento original donde sus creadores presentaron el prototipo de Google: “The Anatomy of a Large-Scale Hypertextual Web Search Engine"

INSTALACIÓN DEL COMPONENTE

1) Descargar el archivo prfree.zip desde http://www.irnis.net/files/prfree.zip
2) Crear una carpeta llamada “pagerank” y descomprimir allí el archivo anterior
3) Abrir la carpeta “pagerank”
4) Para los que tengan Delphi 2007 hacer clic sobre la carpeta “delphi10”
5) Abrir el archivo “pagerank_d10.dpk”



6) Con el botón derecho del ratón hacer clic sobre el item “pagerank_d10.bpl”
Sobre el menú emergente activar los items “Compilar” e “Instalar”
Si todo va bien tendréis en la paleta de componentes llamada “Internet” dos nuevos componentes llamados tPageRank y tPageRankControl

CÓDIGO DEL PROGRAMA

Ahora ya estamos en condiciones de crear nuestra aplicación Delphi.

En el Form colocar los controles tPageRank y tPageRankControl así como un tButton y un tEdit (aquí escribiremos la URL de la página web de la cual queremos conocer su page rank)

En la propiedad Linkage-PageRank del componente tPageRankControl asignar el valor "PageRank1"


En el “uses” de la unit añadir WinInet.

DESCRIPCIÓN DE PROCEDIMIENTOS Y FUNCIONES


En el método “Onclick” del botón poner el siguiente código

procedure TMainForm.Button1Click(Sender: TObject);
begin
PageRank1.Page := URLEdit.Text;
PageRank1.NonBlock := true;
PageRank1.UpdatePageRank;
PageRankControl1.ShowText := true;
PageRankControl1.BarWidth := 7;
end;


En el evento OnGetRank del componente tPageRank guardar el siguiente código:


function Tform1.PageRank1GetRank(const URL: string; var Rank: string): Boolean;
var
Root, Connect, Request: HINTERNET;
I, L, RetVal: Longword;
S, Server, Document: string;
P: Pointer;
begin
Result := FALSE; if UpperCase(Copy(URL, 1, 7)) <> 'HTTP://' then Exit;

I := 8; L := Length(URL); while (I <= L) and (URL[I] <> '/') do Inc(I);
if I > L then Exit;

Server := Copy(URL, 8, I - 8); Document := Copy(URL, I, L - I + 1);

RetVal := InternetAttemptConnect(0);
if RetVal <> ERROR_SUCCESS then RaiseError(RetVal);

Root := InternetOpen(nil, INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

if Root = nil then RaiseError(Windows.GetLastError);
try
Connect := InternetConnect(Root, PChar(Server), INTERNET_DEFAULT_HTTP_PORT,
nil, nil, INTERNET_SERVICE_HTTP, 0, 0);

if Connect = nil then RaiseError(Windows.GetLastError);
try
Request := HttpOpenRequest(Connect, nil, PChar(Document), nil, nil,
nil, INTERNET_FLAG_PRAGMA_NOCACHE or INTERNET_FLAG_RELOAD, 0);

if Request = nil then RaiseError(Windows.GetLastError);
try
SetLength(S, 1024);
repeat
if not HttpSendRequest(Request, nil, 0, nil, 0) then RaiseError(Windows.GetLastError);
RetVal := InternetErrorDlg(GetDesktopWindow(), Request, GetLastError,
FLAGS_ERROR_UI_FILTER_FOR_ERRORS or
FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS or
FLAGS_ERROR_UI_FLAGS_GENERATE_DATA, P);
if RetVal = ERROR_CANCELLED then Exit;
until RetVal = ERROR_SUCCESS;

Rank := '';
repeat
SetLength(S, 1024);
if not InternetReadFile(Request, PChar(S), 1024, L)
then RaiseError(Windows.GetLastError);
SetLength(S, L); Rank := Rank + S
until L (menor que) 1024;
Result := TRUE
finally
InternetCloseHandle(Request);
end
finally
InternetCloseHandle(Connect)
end
finally
InternetCloseHandle(Root)
end
end;


Añadir el siguiente procedimiento para gestión de errores:


procedure TForm1.RaiseError(Error: LongWord);
var
S: string;
I: LongWord;
begin
I := 1024; SetLength(S, I);
if Error = ERROR_INTERNET_EXTENDED_ERROR then
repeat
if InternetGetLastResponseInfo(Error, PChar(S), I) then Break;
if GetLastError = ERROR_INSUFFICIENT_BUFFER then SetLength(S, I) else Break;
until FALSE
else FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_FROM_HMODULE,
Pointer(GetModuleHandle('wininet.dll')), Error, 0, PChar(S), I, nil);
S := PChar(S) + ' (' + IntToStr(Error) + ')';
if PageRank1.NonBlock then
MessageBox(0, PChar(S), nil, MB_ICONERROR or MB_OK or MB_TASKMODAL);
raise Exception.Create(S);
end;



Ahora ya podremos ejecutar nuestra aplicación, que quedará de la siguiente forma:



Buscar en Google con Delphi

A continuación os presento cómo hacer búsquedas en la web utilizando la API de Google Search desde un programa en Delphi.


PASOS PREVIOS

- Ir a http://www.google.com/apis/
- Descargar el Kit de desarrollo
- Crear una cuenta en Google
- Escribir tu programa usando la clave de licencia proporcionada por Google

DENTRO DE DELPHI

1) Crear un Form incorporando un objeto tEdit, tMemo, tButton.

2) En el Uses añadir la unit GoogleSearch

Descargar la unit desde aquí: http://JJavierPareja.googlepages.com/GoogleSearch.dcu

3) En el evento onclic del tButton incluir el siguiente código:


PROCEDURE TForm1.Button1Click(Sender: TObject);

VAR
NumeroDeResultadosDelaBusqueda : Integer;
Resultados: GoogleSearchResult;
i: Integer;

BEGIN

NumeroDeResultadosDelaBusqueda:=10;
Resultados := GetGoogleSearchPort.doGoogleSearch('1WpiIaxr+k+hbyYbRLZOJfg7X9NgI837',
Edit1.Text, 0, NumeroDeResultadosDelaBusqueda, True, '', True, 'lang_es', 'latin1', 'latin1');
label1.Caption := Format('%d resultados en %.2n segundos',
[Resultados.estimatedTotalResultsCount, Resultados.searchTime]);
FOR i := Low(Resultados.resultElements) TO High(Resultados.resultElements) DO
BEGIN
Memo1.lines.add('');
Memo1.lines.add('====================================');
Memo1.lines.add('');
Memo1.lines.add(IntToStr(Succ(i)));
Memo1.lines.add(Resultados.resultElements[i].title);
Memo1.lines.add(Resultados.resultElements[i].URL);
Memo1.lines.add(Resultados.resultElements[i].cachedSize);
END
END;


Ahora ya se puede iniciar el programa.

- Teclear el texto a buscar dentro de la caja de texto (P. ej. "Museos de España" )y pulsar el botón.

Si todo es correcto se mostrará unos resultados similares a los que os aparecería al utilizar el buscador Google desde una página web, pero dentro de vuestra propia aplicación.




INFORMACIÓN COMPLEMENTARIA:

Google Search API es una librería que te permite embeber la búsqueda Google en tus aplicaciones.

El número de resultados de cada búsqueda tiene que ser de 10 o menor.

El uso de Google API es gratuito (por lo que yo sé) pero se necesita una clave personal que te permite 1000 búsquedas por día, además tiene que ser para un uso no comercial. Para usar esta clave necesitas registrarte con un email y un password. Se te enviará un e-mail para verificar tu dirección de correo. Después de que hayas recibido el mensaje y clickeado en el link que contiene, recibirás un segundo mensaje con tu "Google Search Key". Esta clave hay que incluirla en el código fuente de tu aplicación como ves en el ejemplo superior.


Los parámetros del procedimiento doGoogleSearch son:

Key: Es el “Licence Key”.
Q: Es la consulta.
Star: Posición del primer elemento a partir del cual solicitamos la búsqueda.
MaxResults: Número máximo de elementos que contendrá la respuesta.
Filter: Indica si se debe realizar la búsqueda filtrando los elementos similares a otros mostrados.
Restrict: Permite restringir la búsqueda a un almacén de búsqueda determinado.
SafeSearch: Permite filtrar contenidos no aptos para menores.
lr. Restringe la búsqueda a un idioma determinado.
ie. Codificación de entrada.
oe. Codificación de salida





Utilizar Google Maps en Delphi

Para utilizar Google Maps en tus aplicaciones Delphi, tienes que proceder de la siguiente forma:

1) Inicia una nueva aplicación VCL

2) Pon un botón en tu form, y en el evento asociado “OnClick” pon el siguiente código:

procedure TForm1.Button1Click(Sender: TObject);

var

Doc2: IHTMLDocument2;

begin

with WebBrowser1.Document as IHTMLDocument2 do

with parentWindow do

execScript('createMapMarker("31.05173494","-122.03160858", "Marcador de prueba")', 'JavaScript');

end;


En el uses hay que añadir la unit MSHTML en Delphi 2007

3) Pon un control TWebBrowser

4) En el evento OnCreate del Form pon el siguiente código

WebBrowser1.Navigate('http://www.stevetrefethen.com/files/googlemap.htm');



Al ejecutar este programa lo que hace es generar un marcador en la posición indicada con el texto “Marcador de prueba”




REQUISITOS PREVIOS

Tienes que solicitar a Google una “Google Maps Api Key”, te pedirá además un dominio para asociarlo a la clave.

Una vez que la recibas, tienes que incluirla en la página web donde quieras mostrar un mapa.

Además tienes que saber que la Api Key va asociada directamente al dominio, de tal forma que si la pones en una página web con otro dominio distinto Google Maps no funcionará.

Para hacer pruebas, circula por Internet una Api Key para el dominio localhost.



Como proteger tu codigo

Los crackers utilizan desensambladores que permiten ver el código de una forma más clara, para ello ponen breakpoints (típicamente en llamadas de windows o mensajes) y modifican el código antes del siguiente salto.

Por tanto para dificultar el desensamblado, lo que hacemos es insertar código ASM en nuestros procedimientos



Las declaraciones condicionales ASM que insertan código son de este tipo:



JMP aquí

DB byte,byte,byte,byte ; datos basura



Lo que vamos a realizar es un archivo que se insertará en nuestro programa, que genere complejidad en el conjunto de instrucciones ASM, pero que sea transparente a nuestra aplicación.



----- Este es el archivo include: AsmParam.inc: ------

{$IFDEF Param4}

{$UNDEF Param1}

{$UNDEF Param2}

{$UNDEF Param3}

{$UNDEF Param4}

{$ENDIF}

{$IFDEF Param3}

{$IFNDEF Param4}

asm

DB $EB,$06,$55,$44,$55,$03,$a8,$09;

end;

{$DEFINE Param4}

{$ENDIF}

{$ENDIF}

{$IFDEF Param2}

{$IFNDEF Param3}

{$IFNDEF Param4}

asm

DB $EB,$04,$75,$13,$a2,$14;

end;

{$DEFINE Param3}

{$ENDIF}

{$ENDIF}

{$ENDIF}

{$IFNDEF Param1}

{$IFNDEF Param2}

{$IFNDEF Param3}

{$IFNDEF Param4}

asm

DB $EB,$04,$55,$03,$a7,$44;

end;

{$DEFINE Param2}

{$ENDIF}

{$ENDIF}

{$ENDIF}

{$ENDIF}

;

---- Fin del archivo include----





Una vez que tenemos este archivo se inserta entre las líneas de código del evento Onclic de un botón.

El procedimiento se ejecuta normalmente, con la diferencia de que en este caso se incluye un montón de código basura.



procedure TForm1.Button1Click(Sender: TObject);

begin

{$I AsmParam.inc}

ShowMessage('1');

{$I AsmParam.inc}

ShowMessage('2');

{$I AsmParam.inc}

ShowMessage('3');

{$I AsmParam.inc}

ShowMessage('4');

{$I AsmParam.inc}

ShowMessage('1');

end;

Esto puede convertir el desensamblado en una pesadilla incluso con procedimientos simples como Showmessage. El archivo ".inc" puede ser mejorado para producir código aleatorio.

Redes Neuronales y Bolsa - Neural Networks and financial markets


Ahora que en todos los medios de comunicación se habla de la Bolsa, creo que podría ser interesante utilizar el componente TFFNN del que os hablé hace unos días para que veáis cómo se puede utilizar para predecir un valor de una serie temporal basándose en datos anteriores.


Supongamos que tenemos las cotizaciones de cierre de Telefónica, S.A. (p.ej. 1000 valores) y queremos saber cual será el valor de cierre del día N sabiendo la cotización del día N-1, N-2, N-3, N-4 y N-5



Lo primero que hay que hacer es:

Asignar los parámetros de la red neuronal


FFNN1.InputCount:=6 //Son 5 valores + el valor a predecir
FFNN1.OutputCount:=1
FFNN1.InputMax := MAX; //Valor máximo de la serie de cotizaciones
FFNN1.InputMin := MIN; //Valor mínimo de la serie de cotizaciones
FFNN1.OutputMax := MAX; //Valor máximo de la serie de cotizaciones
FFNN1.OutputMin := MIN; ;//Valor mínimo de la serie de cotizaciones






El "Valor máximo" y el "Valor mínimo" es el valor máximo y mínimo de los 1000 valores que componen la serie ( No de los 5 valores )


CÓDIGO PARA ENTRENAR LA RED






VecesQueSeRepite := 1; NumsALeer := 6;
//Este bucle se repetirá 5000 veces o
//hasta que el error sea menor que 0.001
REPEAT

//Bucle que sirve para leer las cotizaciones y
//entrenar la red
REPEAT

//Puntero: Es un apuntador a la serie de valores que salta de 6 en 6
//FicheroEntrada: tStringlist que almacena las 1000 cotizaciones de Telefónica
//NumsLeidos:VAR Array de 6 valores de tipo real
//NoSePuedenLeerMasNumeros:Variable Booleana que se pone a TRUE
//al llegar al final del Fichero de Entrada
//Lee las cotizaciones de Telefónica de 6 en 6
LeeNNums(Puntero, ficheroEntrada, NumsLeidos,
NoSePuedenLeerMasNumeros);

//Almacena en la red 5 cotizaciones procedentes del array "NumsLeidos"
FOR i := 1 TO NumsALeer - 1 DO
FFNN1.Input[i] := NumsLeidos[i];
FFNN1.DesiredOutput[1] := NumsLeidos[NumsALeer];
FFNN1.BackProp; //Entrena la red con el par (In, Out).

UNTIL NoSePuedenLeerMasNumeros;


//Vuelve a tomar los datos de entrada de la red ya entrenada y
//calcula el valor de salida
Puntero := Numvalores DIV 2;
NoSePuedenLeerMasNumeros := false;
REPEAT

//coge las cotizaciones de Telefónica de 6 en 6
LeeNNums(Puntero, FicheroEntrada, NumsLeidos,
NoSePuedenLeerMasNumeros);
FOR i := 1 TO NumsALeer - 1 DO
FFNN1.Input[i] := NumsLeidos[i];
FFNN1.calcOut;
rdo := FFNN1.output[1];
FFNN1.DesiredOutput[1] := NumsLeidos[NumsALeer];
Error := FFNN1.GetMaxError;

UNTIL NOT NoSePuedenLeerMasNumeros;


Inc(VecesQueSeRepite);
UNTIL (VecesQueSeRepite > 5000) OR (Error<0 .001="">



MOSTRAR RESULTADOS




Ahora una vez que hemos terminado de entrenar la red podemos crear un form con 6 cajas de texto.
En 5 de ellas teclearemos cotizaciones diarias de Telefónica y en la sexta caja tendremos el valor predicho por la red neuronal.

El código sería este:



VAR


ValorPredichoPorLaRedNeuronal:Real;

begin

FFNN1.Input[1] := strtofloat(edit1.text);

FFNN1.Input[2] := strtofloat(edit2.text);

FFNN1.Input[3] := strtofloat(edit3.text);

FFNN1.Input[4] := strtofloat(edit4.text);

FFNN1.Input[5] := strtofloat(edit5.text);

ffnn1.calcOut;

ValorPredichoPorLaRedNeuronal := ffnn1.output[1];

Edit6.text:= FloatToStr( ValorPredichoPorLaRedNeuronal )

end;






MEJORAS
- Se puede entrenar el sistema con las cotizaciones de más empresas para mejorar la predicción,


-Es conveniente normalizar los valores antes de introducirlos en la red neuronal.


-Se puede aumentar el número de capas (FFNN1.NLayers) y el número de neuronas de cada capa para ver en qué momento tenemos la mejor estimación.

-Si utilizáis un tchart para ir visualizando los valores calculados en cada iteración se puede ver gráficamente cómo poco a poco se va ajustando la curva de valores calculados respecto a la curva de valores reales (es impresionante)





Marketing para la venta de software online

Después de haber desarrollado un buen proyecto de software en Delphi, una de las opciones que tenemos es intentar obtener un rendimiento económico que nos compense por el tiempo y el esfuerzo invertido en su programación, desarrollo y puesta a punto.

Ahí es donde interviene el marketing (mercadotecnia).

Marketing según la R.A.E. es el conjunto de principios y prácticas que buscan el aumento del comercio, especialmente de la demanda.

Pues bien, hace unos días di con este video de una charla que dio Wil Shipley, cofundador de delicious monster, donde se tratan con mucha profundidad y detalle aspectos esenciales en el proceso de venta de software para mac online, aunque creo que se puede aplicar a casi cualquier producto intangible que se venda en internet.

Lamentablemente hay que saber inglés y disponer de una hora y media para verlo entero, pero vale la pena, Wil es gracioso y toca temas intersantes, como la creación del “hype”, como NO combatir la piratería, como anunciarse, etc.

Video: Monster marketing por Wil Shipley

Vía: Cocoia blog


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').


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

GRN and CodeGear Delphi: King of Languages



Some Code Editor and Refactoring features in CodeGear Delphi

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/





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/



Simulación del movimiento de los electrones en un campo electrico

Espectacular simulación realizada con OpenGL del movimiento de los electrones cuando atraviesan un campo eléctrico. Como muestra la image...