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.

Hay dos maneras de hacer esto, con AssingFile o con TFileStream. Prefiero AssingFile, pues se pueden hacer cosas que no se pueden con stream, por ejemplo mover el puntero hacia un registro (aunque solo en modo lectura) mediante el procedimiento Seek y también podemos usar la función FilePos para averiguar sobre qué registro está el puntero. Agregar datos a un archivo binario no se puede ni con AssigFile ni con FileStream, siempre debemos cargar los datos en memoria y re-escribir todo el archivo, lo cual hoy no es la gran cosa debido a la cantidad de sobra de memoria RAM que tiene cualquier ordenar y la velocidad de procesamiento.

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.

Mucho se dice que no hay que guardar datos cifrados porque de una u otra forma pueden llegar a descifrarlos, máxime si dejamos el valor de la key o llave en nuestro programa. Y es cierto, pero no menos cierto es que es mucho mejor que dejar los datos sin encriptar en un archivo de texto o ini (que también es texto plano) o si se quiere en una tabla en SQLite, o también en un binario sin cifrar. Resumiendo es mejor cifrar. Y si además no guardamos la llave en el programa, sino que la requerimos al usuario (tampoco guardamos su hash), la única manera de obtener los datos es mediante el método de fuerza bruta, que tardará bastante con una llave de 30 caracteres con mayúsculas, minúsculas, números, espacios y símbolos, actualmente tardaría años.

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.

Además de ver como se guarda una imagen de cualquier formato (JGP, PNG, etc.) en una base de datos SQL (SQLite en este caso), también veremos como leerla y mostrarla en un TImage en un formulario.
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

Cuando damos al usuario la posibilidad del autocompletado en un ComboBox y no validamos, existe la posibilidad de que salte un error y es correcto, porque siempre hay que validar. Por ejemplo puede pasar esto:


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

Si bien TDBGrid tiene la propiedad Anchors (Anclajes), cuando la definimos y agrandamos y achicamos el formulario, la grilla también lo hace, mas no sus columnas, la cuales carecen de la propiedad Anchors, entonces el ancho de las columnas permanece estático, no cambia.

¿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

Hacer el "benchmark" de una función, proceso o programa es algo relativamente simple en Lazarus/FreePascal utilizando la unidad dateutils.

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.

TListBox es un componente que muestra una lista de cadenas (strings) y resalta la seleccionada por el usuario. Se encuentra en la pestaña Standard de la paleta de componentes. Permite la multiselección pero en este ejemplo se usará la selección única.

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

Antes esto era una tarea un poco complicada según pude observar después de varias búsquedas que me mostraban hilos de foros de hace unos cuantos años. Por suerte esto ya no es así e incluir una imagen de cualquier formato (dentro de los más populares) almacenada en un campo o columna del tipo BLOB es tan sencillo que no requiere ni una línea de código.

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.