Excelente post de Neftalí -Germán Estévez- sobre codificación geográfica para aquellos que quieran utilizar Google Maps en sus aplicaciones Delphi. Es de lo mejor que he visto en Internet en Español sobre este tema.
El link es:
http://neftali.clubdelphi.com/?p=335
Integración con Google Maps:
http://neftali.clubdelphi.com/?p=380
Obtener las modificaciones que un usuario realiza sobre el Mapa y trasladarlas a nuestro programa en delphi:
http://neftali.clubdelphi.com/?p=413
Osciloscopio en tiempo real
Aquí os dejo un link interesante para montaros vuestro osciloscopio programado en Delphi.
Es un componente de dibujo en tiempo real y un osciloscopio virtual.
Tiene ejemplos de código para Cpp, Visual, Mathworks y por supuesto Delphi.
Se puede descargar desde aquí:
http://www.oscilloscope-lib.com/oscilloscope_DLL.zip
Página principal:
http://www.oscilloscope-lib.com/
Es un componente de dibujo en tiempo real y un osciloscopio virtual.
Tiene ejemplos de código para Cpp, Visual, Mathworks y por supuesto Delphi.
Se puede descargar desde aquí:
http://www.oscilloscope-lib.com/oscilloscope_DLL.zip
Página principal:
http://www.oscilloscope-lib.com/
Crea espectaculares fractales con Delphi
Aquí tienen un fantástico programa "Apophisys" para visualizar espectaculares imágenes fractales.
Con este software podrán editar, crear y renderizar fractales. Viene con muchísimos ejemplos prediseñados, a cada cual más original, pudiéndose modificar diferentes parámetros (color, gradiente, posición de la cámara, perspectiva, escala, etc.) para conseguir nuevos efectos.
Con este software podrán editar, crear y renderizar fractales. Viene con muchísimos ejemplos prediseñados, a cada cual más original, pudiéndose modificar diferentes parámetros (color, gradiente, posición de la cámara, perspectiva, escala, etc.) para conseguir nuevos efectos.
Se puede descargar desde aquí, (con código fuente incluido)
http://sourceforge.net/projects/apophysis/
Links relacionados:
The fractal flame algorithm http://flam3.com/flame.pdf
Ahorrar energía con Delphi
A continuación os presento una serie de funciones para ahorrar energía en vuestros equipos.
//pasar monitor a modo de ahorro de energía
procedure modoAhorroDeEnergia;
begin SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 1);
end;
//apagar monitor
procedure apagarMonitor;
begin SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 2);
end;
//Encender monitor:
procedure encenderMonitor;
begin SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);
end;
//Apagar equipo (requiere permisos administrativos)
PROCEDURE apagarEquipo;
begin
IF NOT (ExitWindowsEx(EWX_SHUTDOWN + EWX_FORCE, 0)) then
showmessage('No puedo apagar el equipo');
end;
//Reiniciar equipo
PROCEDURE ReiniciarEquipo;
begin
IF NOT (ExitWindowsEx(EWX_REBOOT, 0)) then
showmessage('No puedo reiniciar el equipo');
end;
//Devuelve TRUE si el sistema puede Hibernar
FUNCTION TForm1.SystemCanHibernate(): boolean;
RESOURCESTRING
rsDll = 'powrprof.dll';
rsFunc = 'IsPwrHibernateAllowed';
TYPE
TFunc = FUNCTION: boolean; stdcall;
VAR
func: TFunc;
hDll: THandle;
BEGIN
result := false;
hDll := LoadLibrary(PChar(rsDll));
IF (hDll <> 0) THEN
TRY
@func := GetProcAddress(hDll, PChar(rsFunc));
result := Assigned(func) AND func();
FINALLY
FreeLibrary(hDll);
END;
END;
//Devuelve TRUE si el sistema puede ser suspendido
FUNCTION tform1.SystemCanSuspend(): boolean;
RESOURCESTRING
rsDll = 'powrprof.dll';
rsFunc = 'IsPwrSuspendAllowed';
TYPE
TFunc = FUNCTION: boolean; stdcall;
VAR
func: TFunc;
hDll: THandle;
BEGIN
result := false;
hDll := LoadLibrary(PChar(rsDll));
IF (hDll <> 0) THEN
TRY
@func := GetProcAddress(hDll, PChar(rsFunc));
result := Assigned(func) AND func();
FINALLY
FreeLibrary(hDll);
END;
END;
//pasar monitor a modo de ahorro de energía
procedure modoAhorroDeEnergia;
begin SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 1);
end;
//apagar monitor
procedure apagarMonitor;
begin SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 2);
end;
//Encender monitor:
procedure encenderMonitor;
begin SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);
end;
//Apagar equipo (requiere permisos administrativos)
PROCEDURE apagarEquipo;
begin
IF NOT (ExitWindowsEx(EWX_SHUTDOWN + EWX_FORCE, 0)) then
showmessage('No puedo apagar el equipo');
end;
//Reiniciar equipo
PROCEDURE ReiniciarEquipo;
begin
IF NOT (ExitWindowsEx(EWX_REBOOT, 0)) then
showmessage('No puedo reiniciar el equipo');
end;
//Devuelve TRUE si el sistema puede Hibernar
FUNCTION TForm1.SystemCanHibernate(): boolean;
RESOURCESTRING
rsDll = 'powrprof.dll';
rsFunc = 'IsPwrHibernateAllowed';
TYPE
TFunc = FUNCTION: boolean; stdcall;
VAR
func: TFunc;
hDll: THandle;
BEGIN
result := false;
hDll := LoadLibrary(PChar(rsDll));
IF (hDll <> 0) THEN
TRY
@func := GetProcAddress(hDll, PChar(rsFunc));
result := Assigned(func) AND func();
FINALLY
FreeLibrary(hDll);
END;
END;
//Devuelve TRUE si el sistema puede ser suspendido
FUNCTION tform1.SystemCanSuspend(): boolean;
RESOURCESTRING
rsDll = 'powrprof.dll';
rsFunc = 'IsPwrSuspendAllowed';
TYPE
TFunc = FUNCTION: boolean; stdcall;
VAR
func: TFunc;
hDll: THandle;
BEGIN
result := false;
hDll := LoadLibrary(PChar(rsDll));
IF (hDll <> 0) THEN
TRY
@func := GetProcAddress(hDll, PChar(rsFunc));
result := Assigned(func) AND func();
FINALLY
FreeLibrary(hDll);
END;
END;
OCR con Delphi
Aquí tenéis un OCR (Optical Character Recognition) en Delphi, que traduce lo que se ha tecleado o escrito en formato de imagen (como un bitmap) dentro de un fichero editable (texto), viene con código fuente (freeware y licencia open source)
Tiene la capacidad de aprender patrones desde un tipo y tamaño de font determinado utilizando una red neural con el algoritmo de backpropagación.
Hay que tener encuenta que el OCR no ha sido entrenado, por lo que lo primero que hay que hacer es entrenarlo para que pueda reconocer el texto.
Para ello hay que abrir la ventana "Process->Training...", seleccionar los patrones desde los fonts disponibles y el tamaño de letra (Manteniendo pulsado shift o Ctrl se seleccionan varios items), o también se puede dibujar con el ratón un patrón, y para finalizar pulsar el botón "Add Training Pairs".
Cuando estén todos items definidos (podemos probar p.ej. con los números "1,2,3,4")
pulsamos el botón "Train".
El botón "Test" prueba la red. (Es conveniente pulsarlo para ver el tanto por ciento de coincidencia del patrón con el dato de prueba)
Ventana de entrenamiento:
Seleccionar el Font, Char y Size y después pulsar "Add Training Pairs"
Ventana para teclear los datos:
Escribir con el ratón en la parte superior alguno de los números seleccionado en la pantalla anterior (con cuidado de imitar el font y su tamaño) y después activar el menú "Process->Recognize"
En la parte inferior de la ventana aparecen los caracteres reconocidos por el programa.
Tiene la capacidad de aprender patrones desde un tipo y tamaño de font determinado utilizando una red neural con el algoritmo de backpropagación.
Hay que tener encuenta que el OCR no ha sido entrenado, por lo que lo primero que hay que hacer es entrenarlo para que pueda reconocer el texto.
Para ello hay que abrir la ventana "Process->Training...", seleccionar los patrones desde los fonts disponibles y el tamaño de letra (Manteniendo pulsado shift o Ctrl se seleccionan varios items), o también se puede dibujar con el ratón un patrón, y para finalizar pulsar el botón "Add Training Pairs".
Cuando estén todos items definidos (podemos probar p.ej. con los números "1,2,3,4")
pulsamos el botón "Train".
El botón "Test" prueba la red. (Es conveniente pulsarlo para ver el tanto por ciento de coincidencia del patrón con el dato de prueba)
Ventana de entrenamiento:
Seleccionar el Font, Char y Size y después pulsar "Add Training Pairs"
Ventana para teclear los datos:
Escribir con el ratón en la parte superior alguno de los números seleccionado en la pantalla anterior (con cuidado de imitar el font y su tamaño) y después activar el menú "Process->Recognize"
En la parte inferior de la ventana aparecen los caracteres reconocidos por el programa.
En este caso la coincidencia ha sido del 100 por ciento.
Descargar el programa con su código fuente:
Pruebas realizadas con Delphi 7
El programa utiliza el componente TBackProp
Autor: Theo Zacharias (theo_yz@yahoo.com)
Descripción : TBackProp es una clase que encapsula un objeto de red neuronal backpropagation
Eventos: OnTraining, OnTrainingFinish
Propiedades: ErrorThreshold (r/w), InputLayer (r/w),
InputPatternHeight (r/o), InputPatternWidth (r/o),
KnownSymbol (r/o), LearningRate (r/w), MaxEpoch (r/w),
Modified (r/o), NHiddenNeuron (r/o), NInputNeuron (r/o),
NNeuronError (r/o), NOutputNeuron (r/o), NTrainingEpoch (r/o),
NTrainingNeuron (r/o), NTrainingPair (r/o), OutputLayer (r/o),
StopTraining (r/w), TargetClassificationError (r/w),
TargetPatternHeight (r/o), TargetPatternWidth (r/0),
TargetSquaredError (r/o), TrainingError (r/o),
WeightsInitFactor (r/w)
Métodos: : AddTrainingPairs, Apply, GetResult, NewKnowledge,
OpenKnowledge, Retrain, SaveKnowledge, Train
Descargar el componente tBackProp
Calcular el enésimo número de fibonacci
{
Fibonacci integers are defined as:
Fibonacci Zahlen sind wie folgt definiert:
fib[n+2] = fib[n+1] + fib[n];
fib[1] = 1;
fib[0] = 1;
Example/Beispiel: fib[4] = fib[3] + fib[2] = fib[2] + fib[1] + fib[1] + fib[0] =
fib[1] + fib[0] + fib[1] + fib[1] + fib[0] = 5
}
function fibit(n: Integer): Integer;
var
a, b, i, temp: Integer;
begin
temp := 1;
a := 1;
b := 1;
for i := 1 to n - 1 do
begin
temp := a + b;
a := b;
b := temp;
end;
Result := temp;
end;
function fibrec(n: Integer): Integer;
var
temp: Integer;
begin
temp := 0;
if (n = 0) then temp := 1;
if (n = 1) then temp := 1;
if (n > 1) then temp := fibrec(n - 1) + fibrec(n - 2);
Result := temp;
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(fibit(10)));
ShowMessage(IntToStr(fibrec(10)));
end;
Autor: Dev4u.ch
Homepage: http://www.dev4u.ch
Fibonacci integers are defined as:
Fibonacci Zahlen sind wie folgt definiert:
fib[n+2] = fib[n+1] + fib[n];
fib[1] = 1;
fib[0] = 1;
Example/Beispiel: fib[4] = fib[3] + fib[2] = fib[2] + fib[1] + fib[1] + fib[0] =
fib[1] + fib[0] + fib[1] + fib[1] + fib[0] = 5
}
function fibit(n: Integer): Integer;
var
a, b, i, temp: Integer;
begin
temp := 1;
a := 1;
b := 1;
for i := 1 to n - 1 do
begin
temp := a + b;
a := b;
b := temp;
end;
Result := temp;
end;
function fibrec(n: Integer): Integer;
var
temp: Integer;
begin
temp := 0;
if (n = 0) then temp := 1;
if (n = 1) then temp := 1;
if (n > 1) then temp := fibrec(n - 1) + fibrec(n - 2);
Result := temp;
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(fibit(10)));
ShowMessage(IntToStr(fibrec(10)));
end;
Autor: Dev4u.ch
Homepage: http://www.dev4u.ch
Obtener punto 3 de un triángulo equilátero desde los otros 2
procedure CreateEquilateralTriangle(x1, y1, x2, y2: Double; var x3, y3: Double);
const
Sin60 = 0.86602540378443864676372317075294;
const
Cos60 = 0.50000000000000000000000000000000;
begin
{ Translate for x1,y1 to be origin }
x2 := x2 - x1;
y2 := y2 - y1;
{ Rotate 60 degrees and translate back }
x3 := ((x2 * Cos60) - (y2 * Sin60)) + x1;
y3 := ((y2 * Cos60) + (x2 * Sin60)) + y1;
end;
(* End Of Create Equilateral Triangle *)
Autor: Arash Partow
Homepage: http://www.partow.net
const
Sin60 = 0.86602540378443864676372317075294;
const
Cos60 = 0.50000000000000000000000000000000;
begin
{ Translate for x1,y1 to be origin }
x2 := x2 - x1;
y2 := y2 - y1;
{ Rotate 60 degrees and translate back }
x3 := ((x2 * Cos60) - (y2 * Sin60)) + x1;
y3 := ((y2 * Cos60) + (x2 * Sin60)) + y1;
end;
(* End Of Create Equilateral Triangle *)
Autor: Arash Partow
Homepage: http://www.partow.net
Ángulo creado por 3 segmentos 3D
function VertexAngle(x1, y1, z1, x2, y2, z2, x3, y3, z3: Double): Double;
var
Dist: Double;
begin
(* Quantify coordinates *)
x1 := x1 - x2;
x3 := x3 - x2;
y1 := y1 - y2;
y3 := y3 - y2;
z1 := z1 - z2;
z3 := z3 - z2;
(* Calculate Lay Distance *)
Dist := (x1 * x1 + y1 * y1 + z1 * z1) * (x3 * x3 + y3 * y3 + z3 * z3);
if IsEqual(Dist, 0) then Result := 0.0
else
Result := ArcCos((x1 * x3 + y1 * y3 + z1 * z3) / sqrt(Dist)) * _180DivPI;
end;
(* End Of VertexAngle *)
var
Dist: Double;
begin
(* Quantify coordinates *)
x1 := x1 - x2;
x3 := x3 - x2;
y1 := y1 - y2;
y3 := y3 - y2;
z1 := z1 - z2;
z3 := z3 - z2;
(* Calculate Lay Distance *)
Dist := (x1 * x1 + y1 * y1 + z1 * z1) * (x3 * x3 + y3 * y3 + z3 * z3);
if IsEqual(Dist, 0) then Result := 0.0
else
Result := ArcCos((x1 * x3 + y1 * y3 + z1 * z3) / sqrt(Dist)) * _180DivPI;
end;
(* End Of VertexAngle *)
Ángulo creado por 2 segmentos 2D
function VertexAngle(x1, y1, x2, y2, x3, y3: Double): Double;
var
Dist: Double;
begin
(* Quantify coordinates *)
x1 := x1 - x2;
x3 := x3 - x2;
y1 := y1 - y2;
y3 := y3 - y2;
(* Calculate Lay Distance *)
Dist := (x1 * x1 + y1 * y1) * (x3 * x3 + y3 * y3);
if Dist = 0 then Result := 0.0
else
Result := ArcCos((x1 * x3 + y1 * y3) / sqrt(Dist)) * _180DivPI;
end;
(* End Of VertexAngle *)
Autor: Arash Partow
Homepage: http://www.partow.net
var
Dist: Double;
begin
(* Quantify coordinates *)
x1 := x1 - x2;
x3 := x3 - x2;
y1 := y1 - y2;
y3 := y3 - y2;
(* Calculate Lay Distance *)
Dist := (x1 * x1 + y1 * y1) * (x3 * x3 + y3 * y3);
if Dist = 0 then Result := 0.0
else
Result := ArcCos((x1 * x3 + y1 * y3) / sqrt(Dist)) * _180DivPI;
end;
(* End Of VertexAngle *)
Autor: Arash Partow
Homepage: http://www.partow.net
Conversor MPEG4 a AVI con Delphi
MP4Cam2AVI es un conversor de archivos con formato MPEG4 a AVI, muy útil para los que tengan cámaras mpeg4.También soporta los formatos MJPEG y H263.
Viene con código fuente y licencia GNU.
Se puede descargar desde aquí:
http://sourceforge.net/projects/mp4cam2avi/
Cosas que se pueden hacer:
- Convertir y unir videos MPEG-4 ASP desde tu cámara a un único video DivX-compatible MPEG-4 para ser visto en un PC o DVD-MPEG4 player, preservando la calidad original;
- Modo Batch para convertir varios ficheros secuencialmente;
- Convierte películas*.MP4 (MPEG4 ASP) desde Nero Recode a un formato AVI compatible para un reproductor DVD-MPEG4;
- Convierte películas MJPEG desde cámaras de fotos a un DivX-AVI compatible MPEG-4 con un clic;
- Convierte videos H.264 (MPEG-4 AVC) *.MP4 al formato H.264 AVI, que podrán ser editables con VirtualDub y reproducibles con Windows Media Player (H.264 VfW se necesitará el codec(p.ej. el último FFDShow);
- Comprueba los clips MPEG-4 ASP/MJPEG antes de la conversión usando vista previa;
- Edita clips antes de la conversión usando timeline;
- Corrige el audio/video lag de algunas cámaras como el modelo Minolta A200
- Incorpora un filtro pasa-bajo (viene perfecto para la Sanyo Xacti C1)
Formatos de cámaras soportados:
MPEG4-AVC camcorders:
Sanyo: CG65
Casio: EX-V7, EX-S880, Z1200
Others: Aiptek GO-HD
MPEG4-ASP camcorders:
Sanyo: VPC-Ñ1, C4, C40, C5, C6, HD-1, HD-2
Olympus: C770 Movie
Sony: Sony DSC-M1, M2
Pentax: OptioMX, MX4, S5n, S5z, S6, A10
Samsung: Digimax V40, V50, V70, V700, V800, U-CA5, L85, VP-MX10A
Casio: EX-P505, EX-Z750, EX-Z850, EX-S500, EX-S600
Kodak V603, Z612, Z760, Z1275
Photo cameras with H.263 video:
Kodak DX4530
Photo cameras with MOV MJPEG video
Canon Tx1, Kodak LS753, Minolta A2, Minolta Dimage Z3, Nikon Coolpix 5200, Nikon 8400, Nikon E8800, Panasonic FX7, Panasonic FZ-1, Panasonic TZ5, Pentax 750Z, Olympus C-5000/C-5050/C-8080, Olympus mini digital, Pentax Optio X, Sanyo Xacti J1, Fuji S7000.
Formatos de entrada:
File type: *.MP4, *.MOV, *.AVI, *.3GP
(3gp support is experimental, no AMR audio)
Video: MPEG4 ASP, MPEG-4 AVC, MJPEG, H.263, Sorenson Video 3
Audio: AAC, PCM, u-Law, ADPCM, MP3
Formatos de salida:
File types: *.AVI
Video: Source video or XviD MPEG-4 ASP
Audio: Source audio, PCM or MP3
Viene con código fuente y licencia GNU.
Se puede descargar desde aquí:
http://sourceforge.net/projects/mp4cam2avi/
Cosas que se pueden hacer:
- Convertir y unir videos MPEG-4 ASP desde tu cámara a un único video DivX-compatible MPEG-4 para ser visto en un PC o DVD-MPEG4 player, preservando la calidad original;
- Modo Batch para convertir varios ficheros secuencialmente;
- Convierte películas*.MP4 (MPEG4 ASP) desde Nero Recode a un formato AVI compatible para un reproductor DVD-MPEG4;
- Convierte películas MJPEG desde cámaras de fotos a un DivX-AVI compatible MPEG-4 con un clic;
- Convierte videos H.264 (MPEG-4 AVC) *.MP4 al formato H.264 AVI, que podrán ser editables con VirtualDub y reproducibles con Windows Media Player (H.264 VfW se necesitará el codec(p.ej. el último FFDShow);
- Comprueba los clips MPEG-4 ASP/MJPEG antes de la conversión usando vista previa;
- Edita clips antes de la conversión usando timeline;
- Corrige el audio/video lag de algunas cámaras como el modelo Minolta A200
- Incorpora un filtro pasa-bajo (viene perfecto para la Sanyo Xacti C1)
Formatos de cámaras soportados:
MPEG4-AVC camcorders:
Sanyo: CG65
Casio: EX-V7, EX-S880, Z1200
Others: Aiptek GO-HD
MPEG4-ASP camcorders:
Sanyo: VPC-Ñ1, C4, C40, C5, C6, HD-1, HD-2
Olympus: C770 Movie
Sony: Sony DSC-M1, M2
Pentax: OptioMX, MX4, S5n, S5z, S6, A10
Samsung: Digimax V40, V50, V70, V700, V800, U-CA5, L85, VP-MX10A
Casio: EX-P505, EX-Z750, EX-Z850, EX-S500, EX-S600
Kodak V603, Z612, Z760, Z1275
Photo cameras with H.263 video:
Kodak DX4530
Photo cameras with MOV MJPEG video
Canon Tx1, Kodak LS753, Minolta A2, Minolta Dimage Z3, Nikon Coolpix 5200, Nikon 8400, Nikon E8800, Panasonic FX7, Panasonic FZ-1, Panasonic TZ5, Pentax 750Z, Olympus C-5000/C-5050/C-8080, Olympus mini digital, Pentax Optio X, Sanyo Xacti J1, Fuji S7000.
Formatos de entrada:
File type: *.MP4, *.MOV, *.AVI, *.3GP
(3gp support is experimental, no AMR audio)
Video: MPEG4 ASP, MPEG-4 AVC, MJPEG, H.263, Sorenson Video 3
Audio: AAC, PCM, u-Law, ADPCM, MP3
Formatos de salida:
File types: *.AVI
Video: Source video or XviD MPEG-4 ASP
Audio: Source audio, PCM or MP3
Usar archivos pdf con Delphi
Para trabajar con archivos pdf dentro de tu aplicación Delphi tienen que seguir los siguientes pasos:
1) Asegurarte que tienes la última versión del programa "Adobe Acrobar Reader" (Se puede descargar gratuitamente desde la página de Adobe
2) Abrir Delphi e Importar el control ActiveX Adobe Acrobat
Menú Component->Import ActiveX Control...
Pulsa el botón "Install..." y aparecerá en la carpeta "Samples" un componente llamado TPdf.
3) Ahora ya podemos crear una nueva aplicación con un TButton, TOpenDialog y TPDF
Dentro del método Onclic del Tbutton pondremos el siguiente código:
OpenDialog1.Filter := 'PDF Files (*.pdf)*.pdf';
if OpenDialog1.Execute then Pdf1.src := OpenDialog1.FileName;
No olvidar que hay que redimensionar el componente tpdf para poder visualizar correctamente el documento pdf.
Se pueden añadir botones con las funciones: gotoFirstPage, gotoLastPage, setZoom(percent: Single) para ir a la primera, última página o para establecer un zoom.
1) Asegurarte que tienes la última versión del programa "Adobe Acrobar Reader" (Se puede descargar gratuitamente desde la página de Adobe
2) Abrir Delphi e Importar el control ActiveX Adobe Acrobat
Menú Component->Import ActiveX Control...
Pulsa el botón "Install..." y aparecerá en la carpeta "Samples" un componente llamado TPdf.
3) Ahora ya podemos crear una nueva aplicación con un TButton, TOpenDialog y TPDF
Dentro del método Onclic del Tbutton pondremos el siguiente código:
OpenDialog1.Filter := 'PDF Files (*.pdf)*.pdf';
if OpenDialog1.Execute then Pdf1.src := OpenDialog1.FileName;
No olvidar que hay que redimensionar el componente tpdf para poder visualizar correctamente el documento pdf.
Se pueden añadir botones con las funciones: gotoFirstPage, gotoLastPage, setZoom(percent: Single) para ir a la primera, última página o para establecer un zoom.
Videos sobre Delphi 2009
Aquí tienen un video sobre el funcionamiento de diferentes componentes de la VCL de Delphi 2009.
La primera parte es una presentación en inglés durante unos minutos para luego empezar la narración en Español.
Otros videos:
- Desarrollo de aplicaciones multi-hilo con Delphi
- Centralizando acciones com ActionManager
- Compitiendo a nivel internacional con Delphi 2009
- Centralizando acciones com ActionManager
- Compitiendo a nivel internacional con Delphi 2009
Componente para manipulacion de imagenes en Delphi
Aquí tienen un impresionante componente llamado " TEffects " para manipulación de imágenes en Delphi.
Con él se pueden realizar efectos que se ven en programas de retoque fotográfico o edición de imágenes como Corel Paintshop o Adobe Photoshop.
Notas de instalación
El uso de los ejemplos necesita previamente la instalación de las siguientes unit.
que deben ser instaladas en el siguiente orden
- MemUtils
- ExactTimer
- Waiter
- GrayBitmap
- Shape
- Effects
- GraphUtils
- FunThings
Entre otras cosas se pueden implementar los siguientes temas:
(Copiado de la página del autor)
Adjusts color information
Inverts colors
Filters colors
Rotate image to any degree
Adjusts channel colors
Fills channels
Implements transparency effect
Implements blur effect
Implements rough blur effect
Implements pixelization effect
Uploads and extracts a data of any type into a single image at binary level (cryptography)
A few fun things are in TGraphUtils and TFunThings units. These units include:
TBitmapConvertor is intended for conversions between TBitmap class and TSmallBitmap structure (TSmallBitmap is type of dynamic array that represents 32 bit image of any size)
TCustomTextConvertor is abstract class that contains base code for conversion from bitmap into colored text
TCustomTextDrawer is one more abstract class with a code for drawing of colored text on a display device context
TTextConvertor converts image into html document
TTextDrawer is descendant of TCustomTextDrawer class
TDesktopDrawer is descendant of TCustomTextDrawer class which draws text directly on the desktop.
Link de descarga del Componente:
Trucos sobre tWebBrowser ( II )
A continuación tenéis más procedimientos relacionados con el componente tWebBrowser:
CREAR UN tWebBrowser EN RUNTIME
procedure TForm1.Button1Click(Sender: TObject);
var
wb: TWebBrowser;
begin
wb := TWebBrowser.Create(Form1);
TWinControl(wb).Name := 'MyWebBrowser';
TWinControl(wb).Parent := Form1;
wb.Align := alClient;
// TWinControl(wb).Parent := TabSheet1; ( To put it on a TabSheet )
wb.Navigate('http://delphimagic.blogspot.com');
end;
DESHACER, REHACER, SELECCIONAR TODO
Añadir
uses ActiveX;
y al final de la unit
initialization
OleInitialize(nil);
finalization
OleUninitialize;
// Deshacer
procedure TForm1.Button2Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_UNDO, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
//Rehacer
procedure TForm1.Button3Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_REDO, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
// Seleccionar todo
procedure TForm1.Button4Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_SELECTALL, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
GUARDAR TODAS LAS IMÁGENES
uses
UrlMon;
function DownloadFile(SourceFile, DestFile: string): Boolean;
begin
try
Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0,
nil) = 0;
except
Result := False;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
k, p: Integer;
Source, dest, ext: string;
begin
for k := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do
begin
Source := WebBrowser1.OleObject.Document.Images.Item(k).Src;
p := LastDelimiter('.', Source);
ext := UpperCase(Copy(Source, p + 1, Length(Source)));
if (ext = 'GIF') or (ext = 'JPG') then
begin
p := LastDelimiter('/', Source);
dest := ExtractFilePath(ParamStr(0)) + Copy(Source, p + 1,
Length(Source));
DownloadFile(Source, dest);
end;
end;
end;
HACER UN ZOOM DE UNA PÁGINA
procedure TForm1.Button1Click(Sender: TObject);
begin
//75% del tamaño original
WebBrowser1.OleObject.Document.Body.Style.Zoom := 0.75;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
//Tamaño original
WebBrowser1.OleObject.Document.Body.Style.Zoom := 1;
end;
COMPROBAR QUE LA PÁGINA ES SEGURA (SSL)
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
begin
if Webbrowser1.Oleobject.Document.Location.Protocol = 'https:' then
label1.Caption := 'Página segura'
else
label1.Caption := 'Página no segura';
end;
COMPROBAR QUE LA PÁGINA SE ENCUENTRA EN EL DISCO LOCAL
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
begin
if Webbrowser1.Oleobject.Document.Location.Protocol = 'file:' then
begin
label1.Caption := 'El archivo está en el disco local'
end;
end;
CREAR UN tWebBrowser EN RUNTIME
procedure TForm1.Button1Click(Sender: TObject);
var
wb: TWebBrowser;
begin
wb := TWebBrowser.Create(Form1);
TWinControl(wb).Name := 'MyWebBrowser';
TWinControl(wb).Parent := Form1;
wb.Align := alClient;
// TWinControl(wb).Parent := TabSheet1; ( To put it on a TabSheet )
wb.Navigate('http://delphimagic.blogspot.com');
end;
DESHACER, REHACER, SELECCIONAR TODO
Añadir
uses ActiveX;
y al final de la unit
initialization
OleInitialize(nil);
finalization
OleUninitialize;
// Deshacer
procedure TForm1.Button2Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_UNDO, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
//Rehacer
procedure TForm1.Button3Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_REDO, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
// Seleccionar todo
procedure TForm1.Button4Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_SELECTALL, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
GUARDAR TODAS LAS IMÁGENES
uses
UrlMon;
function DownloadFile(SourceFile, DestFile: string): Boolean;
begin
try
Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0,
nil) = 0;
except
Result := False;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
k, p: Integer;
Source, dest, ext: string;
begin
for k := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do
begin
Source := WebBrowser1.OleObject.Document.Images.Item(k).Src;
p := LastDelimiter('.', Source);
ext := UpperCase(Copy(Source, p + 1, Length(Source)));
if (ext = 'GIF') or (ext = 'JPG') then
begin
p := LastDelimiter('/', Source);
dest := ExtractFilePath(ParamStr(0)) + Copy(Source, p + 1,
Length(Source));
DownloadFile(Source, dest);
end;
end;
end;
HACER UN ZOOM DE UNA PÁGINA
procedure TForm1.Button1Click(Sender: TObject);
begin
//75% del tamaño original
WebBrowser1.OleObject.Document.Body.Style.Zoom := 0.75;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
//Tamaño original
WebBrowser1.OleObject.Document.Body.Style.Zoom := 1;
end;
COMPROBAR QUE LA PÁGINA ES SEGURA (SSL)
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
begin
if Webbrowser1.Oleobject.Document.Location.Protocol = 'https:' then
label1.Caption := 'Página segura'
else
label1.Caption := 'Página no segura';
end;
COMPROBAR QUE LA PÁGINA SE ENCUENTRA EN EL DISCO LOCAL
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
begin
if Webbrowser1.Oleobject.Document.Location.Protocol = 'file:' then
begin
label1.Caption := 'El archivo está en el disco local'
end;
end;
Trucos sobre tWebBrowser
tWebBrowser es un componente de Delphi que nos permite incorporar un visualizador de páginas web dentro de nuestras aplicaciones. Depende de la habilidad de nosotros el que podamos realizar un "Internet Explorer", "Firefox", "Opera"...
En este y posteriores artículos os mostraré algunos trucos interesantes:
PROCEDIMIENTOS SOBRE IMPRESIÓN DE PÁGINAS
IMPRIME UNA PÁGINA SIN VENTANA DE DIÁLOGO
procedure TForm1.Button1Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER,
vaIn, vaOut);
end;
IMPRIME UNA PÁGINA CON VENTANA DE DIÁLOGO
procedure TForm1.Button1Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER,
vaIn, vaOut);
end;
IMPRIME UNA VISTA PREVIA DE LA PÁGINA
procedure TForm1.Button1Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINTPREVIEW,
OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;
MUESTRA LA VENTANA "CONFIGURAR IMPRESORA"
procedure TForm1.Button1Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PAGESETUP, OLECMDEXECOPT_PROMPTUSER,
vaIn, vaOut);
end;
PROCEDIMIENTOS PARA EL MANEJO DEL CLIPBOARD
añadir
uses ActiveX
initialization
OleInitialize(nil);
finalization
OleUninitialize;
COPIA EL TEXTO SELECCIONADO AL CLIPBOARD
procedure TForm1.Button1Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_COPY, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
CORTA EL TEXTO SELECCIONADO AL CLIPBOARD
procedure TForm1.Button1Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_CUT, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
BORRA EL TEXTO SELECCIONADO
procedure TForm1.Button1Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_DELETE, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
COMPROBAR QUE EL COMANDO "COPY" ESTÁ ACTIVO
procedure TForm1.Button1Click(Sender: TObject);
begin
if Webbrowser1.OleObject.Document.queryCommandEnabled('Copy') then
ShowMessage('Copy está activo');
end;
PROCEDIMIENTOS PARA IMPLEMENTAR LOS BOTONES "Siguiente, Anterior, Stop"
procedure TForm1.ButtonBackClick(Sender: TObject);
begin
WebBrowser1.GoBack
end;
procedure TForm1.ButtonForwardClick(Sender: TObject);
begin
WebBrowser1.GoForward
end;
procedure TForm1.ButtonCancelClick(Sender: TObject);
begin
WebBrowser1.Stop;
end;
VARIOS
IR A UNA PÁGINA WEB
WebBrowser.Navigate( URL.Text );
REEMPLAZAR LAS IMÁGENES DE UNA PÁGINA WEB
procedure TForm1.Button1Click(Sender: TObject);
var
li: Word;
begin
// Busca todas las imágenes de una página
for li := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do
// y las cambia por "MiImagen.gif"
WebBrowser1.OleObject.Document.Images.Item(0).Src := 'c:\MiImagen.gif';
end;
OCULTA LAS BARRAS DE SCROLL
procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.OleObject.Document.Body.Style.OverflowX := 'hidden';
WebBrowser1.OleObject.Document.Body.Style.OverflowY := 'hidden';
end;
GRABA UNA PÁGINA HTML EN UN ARCHIVO
uses
ActiveX, MSHTML_TLB, SHDocVw_TLB,
ComCtrls, OleCtrls;
procedure TForm1.Button1Click(Sender: TObject);
var
HTMLDocument: IHTMLDocument2;
PersistFile: IPersistFile;
begin
HTMLDocument := WebBrowser1.Document as IHTMLDocument2;
PersistFile := HTMLDocument as IPersistFile;
PersistFile.Save(StringToOleStr('c:\MiPaginaWeb.html'), System.True);
end;
DESACTIVA LOS MENUS POPUP
Poner un componente tApplicationEvents en el form y en el evento onMessage poner lo siguiente
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
begin
if (Msg.Message = WM_RBUTTONDOWN) or (Msg.Message = WM_RBUTTONDBLCLK) then
begin
if IsChild(Webbrowser1.Handle, Msg.hwnd) then
begin
// Muestra tu propio popup o lo que tú quieras
Handled := True;
end;
end;
end;
OTRO MÉTODO PARA DESACTIVAR LAS VENTANAS EMERGENTES
En el evento OnNewWindow2 poner lo siguiente:
procedure TForm1.WebBrowserNewWindow2(Sender: TObject;var ppDisp: IDispatch; var Cancel: WordBool);
begin
Cancel := True;
end;
En este y posteriores artículos os mostraré algunos trucos interesantes:
PROCEDIMIENTOS SOBRE IMPRESIÓN DE PÁGINAS
IMPRIME UNA PÁGINA SIN VENTANA DE DIÁLOGO
procedure TForm1.Button1Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER,
vaIn, vaOut);
end;
IMPRIME UNA PÁGINA CON VENTANA DE DIÁLOGO
procedure TForm1.Button1Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER,
vaIn, vaOut);
end;
IMPRIME UNA VISTA PREVIA DE LA PÁGINA
procedure TForm1.Button1Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINTPREVIEW,
OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;
MUESTRA LA VENTANA "CONFIGURAR IMPRESORA"
procedure TForm1.Button1Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PAGESETUP, OLECMDEXECOPT_PROMPTUSER,
vaIn, vaOut);
end;
PROCEDIMIENTOS PARA EL MANEJO DEL CLIPBOARD
añadir
uses ActiveX
initialization
OleInitialize(nil);
finalization
OleUninitialize;
COPIA EL TEXTO SELECCIONADO AL CLIPBOARD
procedure TForm1.Button1Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_COPY, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
CORTA EL TEXTO SELECCIONADO AL CLIPBOARD
procedure TForm1.Button1Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_CUT, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
BORRA EL TEXTO SELECCIONADO
procedure TForm1.Button1Click(Sender: TObject);
begin
try
WebBrowser1.ExecWB(OLECMDID_DELETE, OLECMDEXECOPT_PROMPTUSER);
except
end;
end;
COMPROBAR QUE EL COMANDO "COPY" ESTÁ ACTIVO
procedure TForm1.Button1Click(Sender: TObject);
begin
if Webbrowser1.OleObject.Document.queryCommandEnabled('Copy') then
ShowMessage('Copy está activo');
end;
PROCEDIMIENTOS PARA IMPLEMENTAR LOS BOTONES "Siguiente, Anterior, Stop"
procedure TForm1.ButtonBackClick(Sender: TObject);
begin
WebBrowser1.GoBack
end;
procedure TForm1.ButtonForwardClick(Sender: TObject);
begin
WebBrowser1.GoForward
end;
procedure TForm1.ButtonCancelClick(Sender: TObject);
begin
WebBrowser1.Stop;
end;
VARIOS
IR A UNA PÁGINA WEB
WebBrowser.Navigate( URL.Text );
REEMPLAZAR LAS IMÁGENES DE UNA PÁGINA WEB
procedure TForm1.Button1Click(Sender: TObject);
var
li: Word;
begin
// Busca todas las imágenes de una página
for li := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do
// y las cambia por "MiImagen.gif"
WebBrowser1.OleObject.Document.Images.Item(0).Src := 'c:\MiImagen.gif';
end;
OCULTA LAS BARRAS DE SCROLL
procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.OleObject.Document.Body.Style.OverflowX := 'hidden';
WebBrowser1.OleObject.Document.Body.Style.OverflowY := 'hidden';
end;
GRABA UNA PÁGINA HTML EN UN ARCHIVO
uses
ActiveX, MSHTML_TLB, SHDocVw_TLB,
ComCtrls, OleCtrls;
procedure TForm1.Button1Click(Sender: TObject);
var
HTMLDocument: IHTMLDocument2;
PersistFile: IPersistFile;
begin
HTMLDocument := WebBrowser1.Document as IHTMLDocument2;
PersistFile := HTMLDocument as IPersistFile;
PersistFile.Save(StringToOleStr('c:\MiPaginaWeb.html'), System.True);
end;
DESACTIVA LOS MENUS POPUP
Poner un componente tApplicationEvents en el form y en el evento onMessage poner lo siguiente
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
begin
if (Msg.Message = WM_RBUTTONDOWN) or (Msg.Message = WM_RBUTTONDBLCLK) then
begin
if IsChild(Webbrowser1.Handle, Msg.hwnd) then
begin
// Muestra tu propio popup o lo que tú quieras
Handled := True;
end;
end;
end;
OTRO MÉTODO PARA DESACTIVAR LAS VENTANAS EMERGENTES
En el evento OnNewWindow2 poner lo siguiente:
procedure TForm1.WebBrowserNewWindow2(Sender: TObject;var ppDisp: IDispatch; var Cancel: WordBool);
begin
Cancel := True;
end;
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
============
EJEMPLO DE USO
===============
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
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
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”
¿ 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:
Suscribirse a:
Entradas (Atom)
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...
-
Los códigos QR son una forma eficiente de almacenar y acceder a información. Las ventajas de usarlos son: Facilidad de uso : Los códigos Q... -
Seguidamente os dejo una lista bastante amplia de funciones escritas en Delphi que se utilizan cuando estamos programando una aplicación q...
-
Espectacular simulación realizada con OpenGL del movimiento de los electrones cuando atraviesan un campo eléctrico. Como muestra la image...