viernes, 13 de abril de 2018
Publicar proyecto
¿Para qué sirve esto? Para varias cosas, por ejemplo, para duplicar un proyecto o precisamente para publicar un proyecto. Lo de duplicar un proyecto se entiende, en cuanto a publicar, un ejemplo simple es para subirlo a un foro o ponerlo como descarga (primero publicar, luego comprimir).
Nota: el proceso de publicar proyecto no afecta en lo más mínimo al proyecto original.
Si usted participa de un foro de programación y le piden que adjunte el proyecto, pues bien, esto es lo que debe hacer:
Primero prepare un directorio vacío donde Lazarus publicará el proyecto.
Luego acceda a la opción desde el menú Proyecto.
En directorio de destino debemos establecer el que creamos para tal fin. Presionando sobre el botón con los tres puntos es la forma más práctica.
Si el proyecto tiene por ejemplo archivo de LazReport y queremos que se publiquen, los agregamos en los filtros a incluir "|lfr" y listo, aceptar.
Una ventana de diálogo nos advierte que si el directorio no está vacío se vaciará. Luego no habrá ningún mensaje de proyecto publicado ni nada, pero en el directorio especificado estarán todos los archivos. Se comprimen a formato 7z o zip y se publica. Es importante utilizar siempre 7z o zip en los foros de programación, especialmente el zip.
También sirve esto como copia de seguridad
domingo, 11 de marzo de 2018
Guardar y leer registros en archivos binarios.
En este ejemplo guardaremos registros con nombres de empresas, número ID y nombre de la base de datos, algo simple. Como buffer usaremos un array (vector o matriz unidimensional) de registros.
Código:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics,
Dialogs, StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
BGuardar: TButton;
BLeer: TButton;
BAgregar: TButton;
edID: TEdit;
EdEmpresa: TEdit;
EdBD: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Memo1: TMemo;
procedure BAgregarClick(Sender: TObject);
procedure BGuardarClick(Sender: TObject);
procedure BLeerClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
type
TReg=record
ID:Integer;
Empresa:string[100];
BD:string[100];
end;
var
Form1: TForm1;
archivo:String;
aReg:array[0..99] of TReg;
cantReg:Integer;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
archivo:=GetCurrentDir+PathDelim+'datareg.bin';
cantReg:=0;
if FileExists(archivo) then BLeerClick(Sender);
//Si el archivo existe lo carga al array
end;
procedure TForm1.BGuardarClick(Sender: TObject);
var
FReg:File of TReg; //Archivo que contendrá registros tipo TReg
i:Integer;
begin
AssignFile(FReg,archivo); //Vinculamos el archivo
Rewrite(FReg); //Lo vamos a sobreescribir
for i:=0 to cantReg-1 do //Recorremos el array y lo escribimos
//con Write
begin
Write(FReg,aReg[i]);
end;
CloseFile(FReg); //Cerramos el archivo
end;
procedure TForm1.BLeerClick(Sender: TObject);
var
FReg:File of TReg; //Archivo que contendrá registros tipo TReg
i:Integer;
begin
AssignFile(FReg,archivo); //Vinculamos el archivo
Reset(FReg); //Lo abrimos en modo solo lectura
i:=0;
while not (EOF(FReg)) do //Lo cargamos al array
begin
Read(FReg,aReg[i]);
Memo1.Lines.Add(IntToStr(aReg[i].ID)+' '+aReg[i].Empresa+' '+
aReg[i].BD);
Inc(i);
Inc(cantReg);
end;
CloseFile(FReg); //Cerramos el archivo
end;
procedure TForm1.BAgregarClick(Sender: TObject);
begin
aReg[cantReg].ID:=StrToInt(edID.Text);//Agregamos solo al array,
//no al archivo.
aReg[cantReg].Empresa:=EdEmpresa.Text;
aReg[cantReg].BD:=EdBD.Text;
Inc(cantReg);
Memo1.Lines.Add('aReg['+IntToStr(cantReg-1)+']: '+EdEmpresa.Text);
end;
end.
En el registro debemos definir la longitud de los strings.
El primer registro de un archivo binario está en la posición 0 (cero).
No hay forma de agregar un registro a un archivo binario, como sí podemos hacerlo con archivos de texto plano, siempre ha que sobreescribir todo el archivo, de ahí ReWrite.
Al utilizar AssignFile podemos acceder mediante Seek a un determinado registro conociendo su posición y leerlo.
Código fuente: archivosbinarios.7z (incluye e archivo binario con 5 registros).
o en GitLab
viernes, 9 de marzo de 2018
Cifrar y guardar en archivo binario.
En este ejemplo, para que se entienda bien, porque de eso tratan los ejemplos, cargaremos la llave en una variable. También cabe destacar que los nombres de variables y funciones que se ven en este ejemplo, son para aprender, en la práctica hay que esconder los datos, no usar para cifrar una función llamada cifrar, etc. También hay que validar datos y utilizar try al leer y escribir archivos.
Veamos el código:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics,
Dialogs, StdCtrls, BlowFish;
type
{ TForm1 }
TForm1 = class(TForm)
BGuardar: TButton;
BLeer: TButton;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Edit4: TEdit;
Edit5: TEdit;
Edit6: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
procedure BGuardarClick(Sender: TObject);
procedure BLeerClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
function Cifrar (const texto:String):RawByteString;
function DesCifrar (const texto:String):RawByteString;
{ private declarations }
public
{ public declarations }
end;
type
TRegistro=Record
Servidor:String[100];
Usuario:String[100];
Clave:String[100];
end;
var
Form1: TForm1;
archivo:String;
llave:String;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
archivo:=GetCurrentDir+PathDelim+'prueba.dat';
llave:='La llave';
end;
function TForm1.Cifrar(const texto: String): RawByteString;
var
str_Cifrar:TBlowFishEncryptStream;
streamTexto:TStringStream;
begin
streamTexto:=TStringStream.Create('');
str_Cifrar:=TBlowFishEncryptStream.Create(llave,streamTexto);
str_Cifrar.WriteAnsiString(texto);
str_Cifrar.Free;
Result:=streamTexto.DataString;
streamTexto.Free;
end;
function TForm1.DesCifrar(const texto: String): RawByteString;
var
str_DesCifrar:TBlowFishDeCryptStream;
unstream:TStringStream;
temp:RawByteString;
begin
unstream:=TStringStream.Create(texto);
unstream.Position:=0;
str_DesCifrar:=TBlowFishDeCryptStream.Create(llave,unstream);
temp:=str_DesCifrar.ReadAnsiString;
str_DesCifrar.Free;
unstream.Free;
Result:=temp;
end;
procedure TForm1.BGuardarClick(Sender: TObject);
var
Registro:TRegistro;
FReg:File of TRegistro;
begin
Registro.Servidor:=Cifrar(Edit1.text);
Registro.Usuario:=Cifrar(Edit2.text);
Registro.Clave:=Cifrar(Edit3.text);
AssignFile(FReg,archivo);
Rewrite(FReg);
Write(FReg,Registro);
CloseFile(FReg);
end;
procedure TForm1.BLeerClick(Sender: TObject);
var
Registro:TRegistro;
FReg:File of TRegistro;
begin
AssignFile(FReg,archivo);
Reset(FReg);
Read(FReg,Registro);
CloseFile(FReg);
edit4.Text:=DesCifrar(Registro.Servidor);
edit5.Text:=DesCifrar(Registro.Usuario);
Edit6.Text:=DesCifrar(Registro.Clave);
end;
end.
Lo primero que debemos hacer es incluir la unidad BlowFish en uses.
Si trabajamos con archivos binarios, definimos un registro para guardar y leer los datos.
En el método Create simplemente definimos el archivo y la llave, que como ven, puede contener espacios.
Luego 2 funciones para encriptar y desencriptar y 2 procedimientos para guardar y leer, para un ejemplo, alcanza y sobra.
Veamos la función Cifrar:
function TForm1.Cifrar(const texto: String): RawByteString;
var
str_Cifrar:TBlowFishEncryptStream;
streamTexto:TStringStream;
begin
streamTexto:=TStringStream.Create('');
str_Cifrar:=TBlowFishEncryptStream.Create(llave,streamTexto);
str_Cifrar.WriteAnsiString(texto);
str_Cifrar.Free;
Result:=streamTexto.DataString;
streamTexto.Free;
end;
Nótese que no devuelve un string, sino un RawByteString que es una cadena de caracteres (string) sin ningún CodePage asociado, ideal e indispensable para que esto funcione.
Necesitamos dos variables, una para el stream de cifrado de Blow Fish y otro un stream común, donde volcaremos el texto cifrado.
Creamos el stream común (streamTexto) vacío.
Creamos el stream de cifrado de BF y le pasamos como parámetros la llave (establecida en FormCreate) y el stream de texto vacío. Es importante hacer todo en este orden.
Ahora ciframos con WriteAnsiString, como parámetro le pasamos la constante de la función llamada texto.
Liberamos el stream de cifrado, el texto cifrado está en el stream de texto (streamtexto).
Finalmente asignamos al resultado de la función el DataString del stream de texto y liberamos el mismo.
Ahora la función DesCifrar:
function TForm1.DesCifrar(const texto: String): RawByteString; var str_DesCifrar:TBlowFishDeCryptStream; unstream:TStringStream; temp:RawByteString; begin unstream:=TStringStream.Create(texto); unstream.Position:=0; str_DesCifrar:=TBlowFishDeCryptStream.Create(llave,unstream); temp:=str_DesCifrar.ReadAnsiString; str_DesCifrar.Free; unstream.Free; Result:=temp; end;
También usamos dos variables para los streams y una tercera del tipo RawByteString que contendrá el valor que retornará la función. Podría obviarse esta variable supuestamente, pero por algo está ahí, la verdad no me acuerdo, algún error me habrá hecho intentar con una variable temporal, funcionó y ahí está.
Aquí cuando creamos el stream de texto, no lo hacemos vacío sino con el valor de la constante texto y a su vez, volvemos a cero su posición para que BF la lea desde el comienzo.
Creamos el stream de descifrado de BF y le pasamos también la llave y el stream de texto.
Ahora sí desciframos usando el método ReadAnsiString perteciente a TBlowFishDeCryptStream y lo asignamos a la variable temp; liberamos los streams y como resultado enviamos el valor de temp.
El resto del código no lo voy a explicar porque simplemente es usar estas dos funciones, escribir y leer el archivo binario de la manera habitual.
Descargar el código fuente: BlowFish.7z
o en GitLab
viernes, 9 de febrero de 2018
Guardar y leer imágenes en bases de datos.
Logotipo: TImage;Al TImage del Form1 lo llamamos Logotipo.
Para leer la imagen y mostrarla en un TImage en un Form:
procedure TFom1.CargoDatos;
var
unstream:TMemoryStream;
begin
//Se cargan la campos "normales"...
if ZQuery1.FieldByName('logo').IsNull then
begin
Logotipo.Picture.Clear;
Exit;
end;
unstream:=TMemoryStream.Create;
unstream.Position:=0;
TBlobField(ZQuery1.FieldByName('logo')).SaveToStream(unstream);
unstream.Position:=0;
Logotipo.Picture.LoadFromStream(unstream);
unstream.Free;
end;
Declaramos una variable del tipo TMemoryStream donde almacenaremos el contenido de la imagen que se encuentra en el campo "logo" de una tabla.Para no tener problemas, averiguamos si existe tal imagen, lo hacemos con FieldByName('logo').IsNull. Si esto devuelve True entonces borramos la imagen de LogoTipo, si no hacemos esto quedará la imagen cargada anteriormente si la hubiere. Si IsNull devuelve False quiere decir que hay una imagen (o debería haberla), entonces creamos el stream, lo posicionamos en 0 (cero) y lo cargamos con TBlobField(el campo).SaveToStream y cabe aclarar que no es necesario definir ninguna variable del tipo TBlobField, este procedimiento se encarga de todo. Ahora ya tenemos la imagen del campo logo de una tabla de una base de datos cargada en un stream de memoria, el paso final es mostrarla en el formulario, para eso posicionamos nuevamente a 0 (cero) el stream, y lo mandamos al TImage nombrado Logotipo y no olvidarse de liberar el stream utilizando el método Free.
Ahora lo inverso, leer la imagen y guardarla en la base de datos. Se omite la carga desde archivo en este ejemplo.
procedure TForm1.GuardarDatos(Sender: TObject); var ms:TMemoryStream; begin //Se pone el dataset en modo edit o insert y se graban los
//campos "normales"...
if (logotipo.Picture.Width>0) then
begin
ms:=TMemoryStream.Create;
Logotipo.Picture.SaveToStream(ms);
ms.Position:=0;
TBlobField(ZQuery1.FieldByName('logo')).LoadFromStream(ms);
ms.Free;
end
else
begin
ZQuery1.FieldByName('logo').AsString:='';
end;
ZQuery1.Post;
end;
Como en el código anterior, necesitamos una variable para el stream en memoria. Y nuevamente para no tener problemas, mediante Logotipo.Picture.Width>0 determinamos si hay alguna imagen que guardar, caso contrario se guarda NULL, AsString:='' hace eso.Si hay imagen, creamos el stream y le asignamos la imagen que está contenida en la propiedad Picture de Logotipo (TImage). Posicionamos en 0 (cero) el stream que ya contiene la imagen y nuevamente nos valemos de TBlobField que asignará el stream al campo "logo" y liberamos con Free el stream.
Desde ya es un código orientativo, pero testeado que este método funciona, al menos para SQlite utilizando ZeosLib.
Hay muchas formas de hacer esto, pero esta forma es la que menos problemas me trajo y es bastante simple y "limpia". He probado antes con DBImage, pero a veces ejecutando el código desde la IDE me tiraba un error EReadError que podía ignorar y todo seguía bien, de hecho ejecutando el programa (fuera de la IDE) esos errores no se mostraban, hasta que detecté que si la imagen que leía DBImage no era JPG entonces largaba ese error, eso me motivo a deshacerme de TDBImage y hacerlo como lo muestro, básicamente con un stream, el procedimiento TBlobField y un TImage.
sábado, 3 de febrero de 2018
TDBLookUpComboBox validar OnExit
O esto otro:
que de paso, no puede pasar en el combo de bancos, porque es del tipo lista y de manera predeterminada ya seleccionamos el primer elemento, ahí no hay que validar nada, el usuario no puede hacer de las suyas. Pues bien, en cualquiera de los dos casos, si presiona imprimir y no se valida, el programa mostrará un mensaje de error. En cambio con una simple validación, obligamos al usuario a seleccionar un ítem del combo, mediante el evento OnExit:
procedure TFRepCuentas.cmbCtaExit(Sender: TObject);
begin
if cmbCta.ItemIndex=-1 then
begin
ShowMessage('Debe seleccionar una cuenta.');
cmbCta.SetFocus;
end;
end;
Entonces si el usuario lo deja en blanco o escribe xx (no coincidiendo xx con ningún elemento del combo) le aparecerá el siguiente mensaje y le enviará el cursor nuevamente al combo y de ahí no sale hasta que seleccione un ítem.
Y tendrá que seleccionar una cuenta sí o sí o cerrar la ventana (lo cual también podríamos evitar si quisiéramos).
sábado, 27 de enero de 2018
DBGrid: Anchors de las columnas
¿Cómo hacer que las columnas cambien el ancho cuando se agranda el formulario que contiene la DBGrid?
Creando el evento FormResize y asignarlo a los eventos del Form OnResize y OnChangeBounds. Desde ya el grid debe estar anclado al formulario y tener definido al menos las constraints de valores mínimos. Luego, un poco de matemáticas y eso es todo.
Así tengo definido el anclaje del DBGrid, mucho no entiendo de este tema, mucho prueba y error hasta dar con el resultado que busco.
Las Constraints del DBGrid, aunque esto es relativo si están definidas las del Form.
En los eventos del DBGrid, desde el inspector de objetos, creamos el evento para OnResize y también lo asignamos a OnChangeBounds.
procedure TfrmBancos.FormResize(Sender: TObject);
var
ndiv, nmod, ndist:Integer;
begin
ndist:=(Width-Constraints.MinWidth);
if ndist < 4 then exit;
ndiv:=ndist div 4;
nmod:=ndist mod 4;
DBGrid1.Columns.Items[1].Width:=160+ndiv;
DBGrid1.Columns.Items[2].Width:=120+ndiv;
DBGrid1.Columns.Items[3].Width:=150+ndiv;
DBGrid1.Columns.Items[4].Width:=160+ndiv;
if nmod>0 then
DBGrid1.Columns.Items[4].Width:=DBGrid1.Columns.Items[4].Width+nmod;
end; En este caso, la columna 0 (cero) no la muestro, solo las 1,2,3 y 4 con un ancho definido en la propiedad width de cada columna de 160, 120, 150 y 160 respectivamente.
Lo que hago es calcular en cuántos píxeles se agranda el formulario y en base a ello, lo distribuyo en las columnas, como son 4, hago la división entera sobre 4 y el resto (mod) lógicamente también sobre 4. Luego elijo a que columna se asigno el sobrante si es que lo hay (mod 4).
jueves, 25 de enero de 2018
Enviar archivos a un servidor vía FTP
En este ejemplo vamos a enviar un archivo "listado.txt" que debe estar en la misma carpeta que el programa a un servidor remoto, es decir, necesitamos sí o sí un servidor al cual conectarnos vía FTP, y un usuario con privilegio de lectura y escritura. La conexión la hacemos por el puerto 21. Desde ya el archivo y el puerto se pueden cambiar desde el código fuente.
Necesitamos también el paquete synapse.
Descargar Synapse desde la web del autor: http://www.ararat.cz/synapse/doku.php/download
En la wiki de Free Pascal hay mucha información y ejemplos de Synapse (en inglés): http://wiki.freepascal.org/Synapse
Podemos utilizar este paquete sin necesidad de instalarlo ni reconstruir la IDE Lazarus.
Desde un proyecto nuevo o habiendo ya descargado es de este ejemplo (al final de esta entrada) vamos a Paquete y Abrir archivo de paquete .lpk.
El paquete se encuentra en la carpeta lib dentro de source donde se haya descomprimido synapse.
No tiene que aparecer esto.
Ahora tal cual se ve en la imagen, botón Usar y Agregar al proyecto, nada más, no se compila ni se instala.
Lo primero es incluir las unidades ftpsend y blcksock en la sección uses.
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls, ftpsend, blcksock;Al Form1 le vamos a definir dos variables privadas para que puedan ser accedidas desde los procedimientos (eventos/métodos).
private
TotalBytes : longint;
CurrentBytes : longint;En la clase TForm vamos a incluir estos procedimientos:
procedure btnEnviarClick (Sender: TObject);
procedure btnSalirClick (Sender: TObject);
procedure FormCreate (Sender: TObject);
procedure SockCallBack (Sender: TObject; Reason: THookSocketReason; const Value: string);FormCreate solamente hace los TEdit tipo password por lo tanto no es necesario para "practicar", o puede dejarse como password solo el correspondiente al TEdit de la contraseña.
edContrasena.EchoMode:=emPassword;
edServidor.EchoMode:=emPassword;
edUsuario.EchoMode:=emPassword;El método SockCallBack solo es necesario para mostrar una barra de progreso.
case Reason of
HR_WriteCount:El enumerado HR_WriteCount se utiliza porque se envían archivos, si en cambio se recibieran archivos, el enumerado es otro, lo veremos en otra entrada donde explicare como recibir archivos vía FTP que desde ya, es parecido a esto.
Variables del evento btnEnviarClick:
procedure TForm1.btnEnviarClick(Sender: TObject);
var
ftp: TFTPSend;
remotefile: string;
localfile: String;
i: Integer;Lo primero es definir una variable (en este caso llamada ftp) del tipo TFTPSend que se encuentra en la unidad ftpsend.pas. Si bien el nombre de esta unidad puede llevar a pensar que exista otra llamada ftpreciebe.pas, pues no, en ftpsend está todo, ya sea para enviar como para recibir archivos.
Luego de instanciar la variable "ftp"
ftp := TFTPSend.Create; debemos "envolver" todo el código de conexión y envío del archivo en un try ... finally, no es obligatorio pero si recomendable.ftp.DSock.OnStatus := @SockCallBack;Es para incrementar la progressbar.
ftp.Timeout:=4000;Esto es muy importante y lamentablemente no se menciona en la mayoría de ejemplos de FTPSend que hay en Internet. Si no definimos un tiempo de espera, el programa puede colgarse o largar un error, de esta forma establecemos en 4 segundo el tiempo de espera de respuesta del servidor.
if ftp.StoreFile(remotefile,False)La función StoreFile es la que manda el archivo al servidor, el primer parámetros es un string que contiene la carpeta del servidor y el nombre del archivo /prueba/listado.txt y el segundo parámetro, booleano, solo debe ser True si el servidor soporta reanudar subidas, si es así solo se sube la parte que resta y si el tamaño del archivo es el mismo que el del archivo que está en el servidor, entonces no se envía nada. Como tercera opción, en caso de que el archivo del servidor sea más grande que el archivo local, entonces se envía todo el archivo desde el comienzo.
Todo el código:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls, ftpsend, blcksock;
type
{ TForm1 }
TForm1 = class(TForm)
btnEnviar: TButton;
btnSalir: TButton;
edCarpetaServidor: TEdit;
edServidor: TEdit;
edContrasena: TEdit;
edUsuario: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
MemoLog: TMemo;
ProgressBar1: TProgressBar;
procedure btnEnviarClick(Sender: TObject);
procedure btnSalirClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure SockCallBack(Sender: TObject; Reason: THookSocketReason; const Value: string);
private
TotalBytes : longint;
CurrentBytes : longint;
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.btnEnviarClick(Sender: TObject);
var
ftp : TFTPSend;
remotefile:string;
localfile:String;
i:Integer;
begin
btnEnviar.Enabled:=False;
btnSalir.Enabled:=False;
ftp := TFTPSend.Create;
localfile:='listado.txt';
MemoLog.Lines.Add('Conectando con el servidor. Por favor espere.');
Application.ProcessMessages;
try
ftp.DSock.OnStatus := @SockCallBack;
ftp.Username:=edUsuario.Text;
ftp.Password:=edContrasena.Text;
ftp.TargetHost:=edServidor.Text;
ftp.TargetPort:='21';
ftp.Timeout:=4000;
if ftp.Login then
MemoLog.Lines.Add('Login: ********* correcto')
else
begin
MemoLog.Lines.Add('Login: ********* incorrecto');
exit;
end;
Application.ProcessMessages;
Sleep(1000);
remotefile:=edCarpetaServidor.Text+'listado.txt';
Progressbar1.Position:=0;
ftp.DirectFileName:=localfile;
ftp.DirectFile:=true;
TotalBytes:=FileSize(localfile);
MemoLog.Lines.Add('Enviando archivo: ' + localfile);
MemoLog.Lines.Add('Total Bytes: ' + IntToStr(TotalBytes));
if ftp.StoreFile(remotefile,False) then
MemoLog.Lines.Add('Transferencia completa')
else
MemoLog.lines.add('Transferencia fallida');
Application.ProcessMessages;
Sleep(1000);
finally
ftp.Logout;
ftp.free;
end;
MemoLog.Lines.Add(#13#10+'Envío de archivos finalizado'+#13#10+'Puede cerrar (salir) esta ventana');
btnEnviar.Enabled:=True;
btnSalir.Enabled:=True;
end;
procedure TForm1.btnSalirClick(Sender: TObject);
begin
Close;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
edContrasena.EchoMode:=emPassword;
edServidor.EchoMode:=emPassword;
edUsuario.EchoMode:=emPassword;
end;
procedure TForm1.SockCallBack(Sender: TObject; Reason: THookSocketReason;
const Value: string);
begin
Application.ProcessMessages;
case Reason of
HR_WriteCount:
begin
inc(CurrentBytes, StrToIntDef(Value, 0));
ProgressBar1.Position := Round(100 * (CurrentBytes / TotalBytes));
end;
HR_Connect: CurrentBytes := 0;
end;
end;
end.Descargar proyecto (incluye el archivo listado.txt): EnviaraFTP.7z
miércoles, 24 de enero de 2018
Medir el tiempo de ejecución de un proceso
En este ejemplo vamos a calcular cuanto se tarda en imprimir 10.000 líneas en un TMemo. También obtendremos la velocidad promedio de líneas por segundo.
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, DateTimePicker, Forms, Controls, Graphics,
Dialogs, StdCtrls, dateutils;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
CheckBox1: TCheckBox;
dtpEmpieza: TDateTimePicker;
dtpFinaliza: TDateTimePicker;
dtpTranscurrido: TDateTimePicker;
edImpps: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
procedure Empezar;
procedure Finalizar;
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var
i:Integer;
begin
Empezar;
if CheckBox1.Checked then
begin
for i:=1 to 10000 do
begin
Application.ProcessMessages;
Memo1.Lines.Add(IntToStr(i));
end;
end
else
begin
for i:=1 to 10000 do
Memo1.Lines.Add(IntToStr(i));
end;
Finalizar;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Memo1.Clear;
end;
procedure TForm1.Empezar;
begin
dtpEmpieza.Time:=Now;
end;
procedure TForm1.Finalizar;
begin
dtpFinaliza.Time:=Now;
dtpTranscurrido.Time:=dtpFinaliza.Time-dtpEmpieza.Time;
edImpps.Text:=FloatToStr((10000/((SecondOf(dtpTranscurrido.Time)+((MilliSecondOf(dtpTranscurrido.Time)/1000))))));
end;
end.
Desde ya se pueden quitar los dos TDateTimePicker y reemplazarlos por dos variables del tipo TTime, o ocultar dichos componentes. También reemplazar el valor 10000 por una constante o variable. Se puede jugar un buen rato.
Código fuente: MedirProcesos.7z o en GitLab
martes, 23 de enero de 2018
TListBox: conceptos básicos.
Esta lista se compone de Items que son del tipo TString que es una clase abstracta.
Es como la implementación gráfica de un vector de cadenas, con propiedades y métodos que permiten su manipulación.
En el ejemplo se crea un programa que carga al comienzo la lista con algunos elementos y permite agregar, eliminar, borrar la lista, ordenarla, copiarla a un TMemo y recorrerla mostrando el recorrido en el Memo. También se muestra en un TEdit el elemento seleccionado.
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
Buttons;
type
{ TForm1 }
TForm1 = class(TForm)
btnRecorrer: TBitBtn;
btnListAMemo: TBitBtn;
btnAgregar: TBitBtn;
btnEliminar: TBitBtn;
btnOrdenar: TBitBtn;
btnBorrarTodo: TBitBtn;
cbDuplicados: TCheckBox;
edAgregar: TEdit;
edSeleccionado: TEdit;
lblSeleccionado: TLabel;
ListBox1: TListBox;
Memo1: TMemo;
procedure btnRecorrerClick(Sender: TObject);
procedure btnAgregarClick(Sender: TObject);
procedure btnBorrarTodoClick(Sender: TObject);
procedure btnEliminarClick(Sender: TObject);
procedure btnListAMemoClick(Sender: TObject);
procedure btnOrdenarClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
private
function YaExiste (elemento: String): Boolean;
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.btnAgregarClick(Sender: TObject);
begin
if Length(Trim(edAgregar.Text))<1 then exit;
//Trim elimina espacios en blanco, Length el tamaño.
//Si ingresa un dato en blanco no hace nada.
if not (cbDuplicados.Checked) then if YaExiste(edAgregar.Text) then exit;
//Si no se marcó Permitir duplicados entonces se llama a la función YaExiste, si devuelve True no se agrega.
ListBox1.AddItem(edAgregar.Text,ListBox1);
//Además del string a agregar hay que especificar el objeto.
edAgregar.Clear;
//Limpia el TEdit. edAgregar.Text:='' también es válido.
end;
procedure TForm1.btnRecorrerClick(Sender: TObject);
var
i:Integer;
begin
Memo1.Clear;
Memo1.Lines.Add('');
Memo1.Lines.Add('for i:=0 to ListBox1.Count-1 do'+#13#10+' Memo1.Lines.Add(ListBox1.Items.Strings[i]);'+#13#10);
for i:=0 to ListBox1.Count-1 do
//TListBox es base 0 (cero) por eso desde 0 hasta cantidad-1
Memo1.Lines.Add('ListBox1.Items.Strings['+IntToStr(i)+']: '+ListBox1.Items.Strings[i]);
//ListBox1.Items.String[i] así se accede al texto de cada ítem.
end;
procedure TForm1.btnBorrarTodoClick(Sender: TObject);
begin
ListBox1.Clear;
//Limpia la ListBox
end;
procedure TForm1.btnEliminarClick(Sender: TObject);
begin
if ListBox1.ItemIndex>=0 then ListBox1.Items.Delete(ListBox1.ItemIndex);
//Si hay algún ítem seleccionado, entonces ItemIndex tendrá un valor mayor o igual a cero, caso contrario será -1.
end;
procedure TForm1.btnListAMemoClick(Sender: TObject);
begin
Memo1.Lines.Add('Memo1.Lines:=ListBox1.Items;');
Memo1.Lines:=ListBox1.Items;
//Ya la propiedades Lines e Items son del mismo tipo TStrings basta con asignar una a la otra.
end;
procedure TForm1.btnOrdenarClick(Sender: TObject);
begin
ListBox1.Sorted:=True;
ListBox1.Sorted:=False;
//El False se agrega para que si se agrega un nuevo elemento lo agregue al final y se pueda volver a ordenar.
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ListBox1.AddItem('Devuan',ListBox1);
ListBox1.AddItem('Linux mint',ListBox1);
ListBox1.AddItem('Gentoo',ListBox1);
ListBox1.AddItem('Arch Linux',ListBox1);
ListBox1.AddItem('Ubuntu',ListBox1);
ListBox1.AddItem('Debian',ListBox1);
ListBox1.AddItem('Mangaro',ListBox1);
end;
procedure TForm1.ListBox1Click(Sender: TObject);
begin
edSeleccionado.Text:=ListBox1.Items.Strings[ListBox1.ItemIndex];
//Se accede al texto Items.Strings y el índice lo tomamos de la propia lista ItemIndex que es el ítem seleccionado.
end;
function TForm1.YaExiste(elemento: String): Boolean;
//elemento es el texto de edAgregar
var
i:Integer;
ret:Boolean;
begin
ret:=False;
for i:=0 to listbox1.Count-1 do
if elemento=listbox1.Items.Strings[i] then ret:=True;
//Recorremos toda la lista buscando si ya existe.
YaExiste:=ret;
end;
end.
Como vemos, cuando ordenamos la lista, los elementos cambian el índice, no es solo un ordenamiento visual.
Para que la lista esté siempre ordenada basta con establecer la propiedad Sorted en True, de esta forma cuando se agregue un elemento, lo hará en la posición que le corresponda y no al final. Haciendo esto, el botón ordenar ya no tiene sentido y debe quitarse.
Código fuente: TListBox3.7z
Más entradas de ListBox.
domingo, 14 de enero de 2018
LazReport: incluir imagen de campo BLOB
Desde el diseñador LazReport debemos incluir un objeto del tipo imagen y nos aparecerá el siguiente diálogo:
La opción Cargar es para cargar una imagen contenida en un archivo, no es el caso. Debemos hacer click en Texto.
Y aquí tanto solo indicamos el campo que contiene la imagen. Si el dataset está conectado, podemos agregarlo desde el botón Campo de DB.
Eso es todo.




















