Los tipos enteros en Delphi

Byte:

- Tipo entero que soporta valores entre 0 y 255.
- Gasta un byte de memoria (8 bits).

Cardinal:

- Tipo entero básico sin signo.
- Soporta valores entre 0 y 4294967295.
- Gasta 4 bytes de memoria (32 bits).

Integer:

- Tipo entero con signo.
- Soporta valores entre -2147483648 y 2147483647.
- Gasta 4 bytes de memoria (32 bits)

Int64:

- Tipo entero con signo.
- Alcanza valores desde -9223372036854775808 hasta 9223372036854775807.
- Gasta 8 bytes de memoria (64 bits).

LongInt:

- Tipo entero con signo.
- Valores comprendidos entre -2147483648 y 2147483647.
- Gasta 4 bytes de memoria (32 bits).
- Es un tipo fijo que no cambiará en futuras versiones de Delphi.

LongWord:

- Tipo entero sin signo.
- Valores comprendidos entre 0 y 4294967295.
- Gasta 4 bytes de memoria (32 bits).

DWord:

- Igual que LongWord;

ShortInt:

- Tipo entero con signo.
- Valores comprendidos entre -128 y 127.
- Gasta 1 byte de memoria (8 bits).

SmallInt:

- Tipo entero con signo.
- Valores comprendidos entre -32768 y 32767.
- Gasta 2 bytes de memoria (16 bits).

Word:

- Tipo entero sin signo.
- Valores comprendidos entre 0 y 65535.
- Gasta 2 bytes de memoria (16 bits).

Pruebas realizadas en Delphi 7.

Trabajando con arrays dinámicos

Una de las ventajas de los arrays dinámicos respecto a los estáticos es que pueden modificar su tamaño en tiempo de ejecución y no es necesaria la gestión de memoria para los mismos, ya que se liberan automáticamente al terminar el procedimiento, función o clase donde están alojados. También son ideales para enviar un número indeterminado de parámetros a funciones o procedimientos.

Para crear una array dinámico lo que hacemos es declarar el array pero sin especificar su tamaño:

  public
    Clientes: array of string;

Antes de meter un elemento al array hay que especificar su tamaño con la función SetLength. En este ejemplo creamos tres elementos:

  SetLength( Clientes, 3 );

Y ahora introducimos los datos en el mismo:

  Clientes[0] := 'JUAN';
  Clientes[1] := 'CARLOS';
  Clientes[2] := 'MARIA';

A diferencia de los arrays estáticos el primer elemento es el cero y no
el uno. Como he dicho antes no es necesario liberarlos de memoria, pero
si aún así deseamos hacerlo sólo es necesario hacer lo siguiente:

  Clientes := nil;

con lo cual el array queda inicializado para que pueda volver a ser utilizado.

Pruebas realizadas en Delphi 7.

Clonar las propiedades de un control

Cuantas veces hemos deseado en tiempo de ejecución copiar las características de un control a otro según las acciones del usuario. Por ejemplo si tenemos nuestro propio editor de informes se podrían copiar las carácterísticas de las etiquetas seleccionas por el usuario al resto del formulario (font, color, width, etc.)

Para ello tenemos que añadir la unidad TypInfo:

uses
  Windows, Dialogs, ..., TypInfo;

A esta función que voy a mostrar hay que pasarle el control origen y el destino (la copia) así como que propiedades deseamos copiar:

function ClonarPropiedades( Origen, Destino: TObject;
                            Propiedades: array of string ): Boolean;
var
  i: Integer;
begin
  Result := True;
  try
    for i := Low( Propiedades ) to High( Propiedades ) do
    begin
      // ¿Existe la propiedad en el control origen?
      if not IsPublishedProp( Origen, Propiedades[I] ) then
        Continue;

      // ¿Existe la propiedad en el control destino?
      if not IsPublishedProp( Destino, Propiedades[I] ) then
        Continue;

      // ¿Son del mismo tipo las dos propiedades? 
      if PropType( Origen, Propiedades[I]) <>
        PropType( Destino, Propiedades[I] ) then
        Continue;

      // Copiamos la propiedad según si es variable o método
      case PropType(Origen, Propiedades[i]) of
        tkClass:
          SetObjectProp( Destino, Propiedades[i],
            GetObjectProp( Origen, Propiedades[i] ) );

        tkMethod:
          SetMethodProp( Destino, Propiedades[I],
                         GetMethodProp( Origen, Propiedades[I] ) );
        else
          SetPropValue( Destino, Propiedades[i],
                        GetPropValue( Origen, Propiedades[i] ) );
      end;
    end;
  except
    Result := False;
  end;
end;

Para copiar las características principales de una etiqueta habría que llamar a la función de la siguiente manera:

 ClonarPropiedades( Label1, Label2, ['Font', 'Color', 'Alignment',
                    'Width', 'Height', 'Layout'] );

También se pueden copiar eventos tales como OnClick, OnMouseDown, etc. permitiendo así abarcar muchos controles con un solo evento.

Pruebas realizadas en Delphi 7.

Aplicar antialiasing a una imagen

El algoritmo antialiasing se suele aplicar a una imagen para evitar los bordes dentados y los degradados bruscos de color. Lo que hace es suavizar toda la imagen.

En este caso el siguiente procedimiento toma un objeto TImage como primer parámetro y como segundo el porcentaje de antialiasing deseado, siendo normal no aplicar más del 10 o 20%:

procedure Antialiasing( Imagen: TImage; iPorcentaje: Integer );
type
  TRGBTripleArray = array[0..32767] of TRGBTriple;
  PRGBTripleArray = ^TRGBTripleArray;
var
  SL, SL2: PRGBTripleArray;
  l, m, p: Integer;
  R, G, B: TColor;
  R1, R2, G1, G2, B1, B2: Byte;
begin
  with Imagen.Canvas do
  begin
    Brush.Style  := bsClear;
    Pixels[1, 1] := Pixels[1, 1];

    for l := 0 to Imagen.Height - 1 do
    begin
      SL := Imagen.Picture.Bitmap.ScanLine[l];

      for p := 1 to Imagen.Width - 1 do
      begin
        R1 := SL[p].rgbtRed;
        G1 := SL[p].rgbtGreen;
        B1 := SL[p].rgbtBlue;

        if (p < 1) then
          m := Imagen.Width
        else
          m := p - 1;

        R2 := SL[m].rgbtRed;
        G2 := SL[m].rgbtGreen;
        B2 := SL[m].rgbtBlue;
       
        if ( R1 <> R2 ) or ( G1 <> G2 ) or ( B1 <> B2 ) then
        begin
          R := Round( R1 + ( R2 - R1 ) * 50 / ( iPorcentaje + 50 ) );
          G := Round( G1 + ( G2 - G1 ) * 50 / ( iPorcentaje + 50 ) );
          B := Round( B1 + ( B2 - B1 ) * 50 / ( iPorcentaje + 50 ) );
          SL[m].rgbtRed := R;
          SL[m].rgbtGreen := G;
          SL[m].rgbtBlue := B;
        end;

        if ( p > Imagen.Width - 2 ) then
          m := 0
        else
          m := p + 1;

        R2 := SL[m].rgbtRed;
        G2 := SL[m].rgbtGreen;
        B2 := SL[m].rgbtBlue;

        if ( R1 <> R2 ) or ( G1 <> G2 ) or ( B1 <> B2 ) then
        begin
          R := Round( R1 + ( R2 - R1 ) * 50 / ( iPorcentaje + 50 ) );
          G := Round( G1 + ( G2 - G1 ) * 50 / ( iPorcentaje + 50 ) );
          B := Round( B1 + ( B2 - B1 ) * 50 / ( iPorcentaje + 50 ) );
          SL[m].rgbtRed := R;
          SL[m].rgbtGreen := G;
          SL[m].rgbtBlue := B;
        end;

        if ( l < 1 ) then
          m := Imagen.Height - 1
        else
          m := l - 1;

        SL2 := Imagen.Picture.Bitmap.ScanLine[m];
        R2  := SL2[p].rgbtRed;
        G2  := SL2[p].rgbtGreen;
        B2  := SL2[p].rgbtBlue;

        if ( R1 <> R2 ) or ( G1 <> G2 ) or ( B1 <> B2 ) then
        begin
          R := Round( R1 + ( R2 - R1 ) * 50 / ( iPorcentaje + 50 ) );
          G := Round( G1 + ( G2 - G1 ) * 50 / ( iPorcentaje + 50 ) );
          B := Round( B1 + ( B2 - B1 ) * 50 / ( iPorcentaje + 50 ) );
          SL2[p].rgbtRed := R;
          SL2[p].rgbtGreen := G;
          SL2[p].rgbtBlue := B;
        end;

        if ( l > Imagen.Height - 2 ) then
          m := 0
        else
          m := l + 1;

        SL2 := Imagen.Picture.Bitmap.ScanLine[m];
        R2  := SL2[p].rgbtRed;
        G2  := SL2[p].rgbtGreen;
        B2  := SL2[p].rgbtBlue;

        if ( R1 <> R2 ) or ( G1 <> G2 ) or ( B1 <> B2 ) then
        begin
          R := Round( R1 + ( R2 - R1 ) * 50 / ( iPorcentaje + 50 ) );
          G := Round( G1 + ( G2 - G1 ) * 50 / ( iPorcentaje + 50 ) );
          B := Round( B1 + ( B2 - B1 ) * 50 / ( iPorcentaje + 50 ) );
          SL2[p].rgbtRed := R;
          SL2[p].rgbtGreen := G;
          SL2[p].rgbtBlue := B;
        end;
      end;
    end;
  end;
end;

Suponiendo que tengamos en un formulario un objeto TImage llamado Image1 llamaríamos a este procedimiento de la siguiente manera:

  Antialiasing( Image1, 10 );

Pruebas realizadas en Delphi 7.

Dibujar varias columnas en un ComboBox

Vamos a ver un ejemplo de dibujar tres columnas al desplegar un ComboBox. El truco está en guardar el valor de las tres columnas en el mismo item pero separado por un punto y coma.

Después implementamos nuestra propia función de dibujado de columnas para que muestre las tres columnas. Para ello metemos en el evento OnDrawItem del ComboBox:

procedure TFormulario.ComboBoxDrawItem( Control: TWinControl; Index: Integer;
                                        Rect: TRect; State: TOwnerDrawState );
var
  sValor, sTodo: string;
  i, iPos: Integer;
  rc: TRect;
  AnchoColumna: array[0..3] of Integer;
begin
  ComboBox.Canvas.Brush.Style := bsSolid;
  ComboBox.Canvas.FillRect( Rect );

  // Las columnas deben ir separadas por un ;
  sTodo := ComboBox.Items[Index];

  // Establecemos el ancho de las columnas
  AnchoColumna[0] := 0;
  AnchoColumna[1] := 100;  // Ancho de la columna 1
  AnchoColumna[2] := 200;  // Ancho de la columna 2
  AnchoColumna[3] := 300;  // Ancho de la columna 3

  // Leemos el texto de la primera columna
  iPos := Pos( ';', sTodo );
  sValor := Copy( sTodo, 1, iPos - 1 );

  for i := 0 to 3 do
  begin
    // Dibujamos la primera columna
    rc.Left   := Rect.Left + AnchoColumna[i] + 2;
    rc.Right  := Rect.Left + AnchoColumna[i+1] - 2;
    rc.Top    := Rect.Top;
    rc.Bottom := Rect.Bottom;

    // Escribimos el texto
    Combobox.Canvas.TextRect( rc, rc.Left, rc.Top, sValor );

    // Dibujamos las líneas que separan las columnas
    if i < 3 then
    begin
      Combobox.Canvas.MoveTo( rc.Right, rc.Top );
      Combobox.Canvas.LineTo( rc.Right, rc.Bottom );
    end;

    // Leemos el texto de la segunda columna
    sTodo := Copy( sTodo, iPos + 1, Length( sTodo ) - iPos );
    iPos := Pos( ';', sTodo );
    sValor := Copy( sTodo, 1, iPos - 1 );
  end;
end;

Modificando el bucle y el array de enteros AnchoColumna podemos crear el número de columnas que queramos. Ahora sólo hay que meter los items en el ComboBox separados por punto y coma:

 with Combobox.Items do
 begin
   Add( 'JOSE;SANCHEZ;GARCIA;' );
   Add( 'MARIA;PEREZ;GOMEZ;' );
   Add( 'ANDRES;MARTINEZ;RUIZ;' );
 end;

Por último hay que decirle al ComboBox que la rutina de pintar los items corre por nuestra cuenta:

procedure TFormulario.FormCreate(Sender: TObject);
begin
  // Le decimos al ComboBox que lo vamos a pintar nosotros
  Combobox.Style := csOwnerDrawFixed;
end;

Pruebas realizadas en Delphi 7.

Generar claves aleatorias

El siguiente procedimiento que voy a mostrar genera una clave aleatoria según el número de sílabas y números que le indiquemos. Por ejemplo:

GenerarClave( 3, 2 )

puede devolver:

catamo56
dilema12
catoye97
...

Aquí tenemos el generador de claves:

function GenerarClave( iSilabas, iNumeros: Byte ): string;
const
  Consonante: array [0..19] of Char = ( 'b', 'c', 'd', 'f', 'g', 'h', 'j',
                                        'k', 'l', 'm', 'n', 'p', 'r', 's',
                                        't', 'v', 'w', 'x', 'y', 'z' );

  Vocal: array [0..4] of Char = ( 'a', 'e', 'i', 'o', 'u' );

  function Repetir( sCaracter: String; iVeces: Integer ): string;
  var
    i: Integer;
  begin
    Result := '';
    for i := 1 to iVeces do
      Result := Result + sCaracter;
  end;

var
  i: Integer;
  si, sf: Longint;
  n: string;
begin
  Result := '';
  Randomize;

  if iSilabas <> 0 then
    for i := 1 to iSilabas do
    begin
      Result := Result + Consonante[Random(19)];
      Result := Result + Vocal[Random(4)];
    end;

  if iNumeros = 1 then
    Result := Result + IntToStr(Random(9))
  else
    if iNumeros >= 2 then
    begin
      if iNumeros > 9 then
        iNumeros := 9;

      si     := StrToInt('1' + Repetir( '0', iNumeros - 1 ) );
      sf     := StrToInt( Repetir( '9', iNumeros ) );
      n      := FloatToStr( si + Random( sf ) );
      Result := Result + Copy( n, 0, iNumeros );
    end;
end;

Suele utilizarse en la creación de cuentas de usuario y departamentos en programas de gestión, dejando que posteriormente el usuario pueda cambiarse la clave.

Pruebas realizadas en Delphi 7.

Meter recursos dentro de un ejecutable

Una de las cosas que mas hacen engordar el tamaño de un ejecutable es meter los mismos botones con imagenes en distintos formularios. Si diseñamos nuestros propios botones Aceptar y Cancelar y los vamos replicando en cada formulario el tamaño de nuestro programa puede crecer considerablemente.

Para evitar esto lo que vamos a hacer es meter la imagen dentro de un recurso compilado y posteriormente accederemos a la misma dentro del programa. La ventaja de utilizar este método es que la imagen sólo esta una vez en el programa independientemente del número de formularios donde vaya a aparecer.

Supongamos que vamos a meter la imagen MiBoton.jpg dentro de nuestro programa. Creamos al lado de la misma el archivo imagenes.rc el cual contiene:

1 RCDATA MiBoton.jpg

Se pueden meter en un archivo de recursos tantas imagenes como se desee, así como otros tipos de archivo (sonidos, animaciones flash, etc.). Las siguientes líneas serían:

2 RCDATA imagen2.jpg
3 RCDATA imagen3.jpg
...

Ahora abrimos una ventana de símbolo del sistema dentro del mismo directorio donde este la imagen y compilamos el recurso:

c:\imagenes\brc32 -r -v imagenes.rc

Lo cual nos creará el archivo imagenes.res.

Ahora para utilizar el recurso dentro de nuestro programa hay que añadir debajo de implementation (del formulario principal de la aplicación) la directiva {$R imagenes.res}:

implementation

{$R *.dfm}
{$R imagenes.res}

Esto lo que hace es unir todos los recursos de imagenes.res con nuestro ejecutable. Para cargar la imagen dentro de un objeto TImage hacemos lo siguiente:

procedure TFPrincipal.FormCreate( Sender: TObject );
var
  Recursos: TResourceStream;
  Imagen: TJPegImage;
begin
  Imagen := TJPegImage.Create;
  Recursos := TResourceStream.Create( hInstance, '#1', RT_RCDATA );
  Recursos.Seek( 0, soFromBeginning );
  Imagen.LoadFromStream( Recursos );
  Imagen1.Canvas.Draw( 0, 0, Imagen );
  Recursos.Free;
  Imagen.Free;
end;

Donde Imagen1 es un objeto TImage. Aunque pueda parecer algo molesto tiene las siguientes ventajas:

- Evita que un usuario cualquiera utilice nuestras imagenes (a menos claro que sepa utilizar un editor de recursos).

- Facilita la distribución de nuestro programa (va todo en el exe).

- Se puede añadir cualquier tipo de archivo o dato dentro del ejecutable.

- Ahorramos mucha memoria al cargar una sola vez el recurso.

Pruebas realizadas en Delphi 7.

Dibujar un gradiente en un formulario

Con un sencillo procedimiento podemos hacer que el fondo de nuestros formularios quede con un aspecto profesional con un degradado de color. Para ello escribimos en el evento OnPaint del formulario:

procedure TFormulario.FormPaint( Sender: TObject );
var
  wFila, wVertical: Word;
  iRojo: Integer;
begin
  iRojo := 200;
  wVertical := ( ClientHeight + 512 ) div 256;

  for wFila := 0 to 512 do
  begin
    with Canvas do
    begin
      Brush.Color := RGB( iRojo, 0, wFila );
      FillRect( Rect( 0, wFila * wVertical, ClientWidth, ( wFila + 1 ) * wVertical ) );
      Dec( iRojo );
    end;
  end;
end;

Lo que hace es crear un barrido vertical según el ancho y alto de nuestro formulario y va restando de la paleta RGB el componente rojo. Si queremos cambiar el color sólo hay que jugar con los componentes RGB hasta conseguir el efecto deseado.

Al maximizar o cambiar el ancho y alto de la ventana se quedará el degradado cortado. Para evitar esto le decimos en el evento OnResize que vuelva a pintar la ventana:

procedure TFormulario.FormResize( Sender: TObject );
begin
  Repaint;
end;

Este efecto suele utilizarse mucho instalaciones o en CD-ROM interactivos, catálogos, etc.

Pruebas realizadas en Delphi 7.

Trocear y unir archivos

Una de las utilidades más famosas que se han asociado a la descarga de archivos es el programa Hacha, el cual trocea archivos a un cierto tamaño para luego poder unirlos de nuevo.

El siguiente procedimiento parte un archivo a la longitud en bytes que le pasemos:

procedure TrocearArchivo( sArchivo: TFileName; iLongitudTrozo: Integer );
var
  i: Word;
  FS, Stream: TFileStream;
  sArchivoPartido: String;
begin
  FS := TFileStream.Create( sArchivo, fmOpenRead or fmShareDenyWrite );

  try
    for i := 1 to Trunc( FS.Size / iLongitudTrozo ) + 1 do
    begin
      sArchivoPartido := ChangeFileExt( sArchivo, '.' + FormatFloat( '000', i ) );
      Stream := TFileStream.Create( sArchivoPartido, fmCreate or fmShareExclusive );

      try
        if fs.Size - fs.Position < iLongitudTrozo then
          iLongitudTrozo := FS.Size - FS.Position;

        Stream.CopyFrom( FS, iLongitudTrozo );
      finally
        Stream.Free;
      end;
    end;
  finally
    FS.Free;
  end;
end;

Si por ejemplo le pasamos el archivo Documentos.zip creará los archivos:

Documentos.001
Documentos.002
....

Para volver a unirlo tenemos otro procedimiento donde le pasamos el primer trozo y el nombre del archivo original:

procedure UnirArchivo( sTrozo, sArchivoOriginal: TFileName );
var
  i: integer;
  FS, Stream: TFileStream;
begin
  i := 1;
  FS := TFileStream.Create( sArchivoOriginal, fmCreate or fmShareExclusive );

  try
    while FileExists( sTrozo ) do
    begin
      Stream := TFileStream.Create( sTrozo, fmOpenRead or fmShareDenyWrite );

      try
        FS.CopyFrom( Stream, 0 );
      finally
        Stream.Free;
      end;

      Inc(i);
      sTrozo := ChangeFileExt( sTrozo, '.' + FormatFloat( '000', i ) );
    end;
  finally
    FS.Free;
  end;
end;

Una ampliación interesante a estos procedimientos sería meter el nombre del archivo original en el primer o último trozo, así como un hash (MD4, MD5, SHA, etc.) para saber si algún trozo está defectuoso.

Pruebas realizadas en Delphi 7.

Mover componentes en tiempo de ejecución

Para darle un toque profesional a un programa no esta mal añadir un editor que permita al usuario personalizar sus formularios, informes o listados. Por ejemplo en un programa de facturación sería interesante que el usuario pudiera personalizar el formato de su factura.

Antes de nada hay que crear en la sección private del formulario tres variables encargadas de guardar las coordenadas del componente que se esta moviendo así como una variable booleana que nos dice si en este momento se esta moviendo un componente:

  private
    { Private declarations }
    iComponenteX, iComponenteY: Integer;
    bMoviendo: Boolean;

Creamos dentro de type la definición de un control movible:

type 
  TMovible = class( TControl );

Los siguientes procedimientos hay que asignarlos a un componente para que puedan ser movidos por todo el formulario al ejecutar el programa:

procedure TFPrincipal.ControlMouseDown( Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer );
begin
  iComponenteX := X;
  iComponenteY := Y;
  bMoviendo := True;
  TMovible( Sender ).MouseCapture := True;
end;

procedure TFPrincipal.ControlMouseMove( Sender: TObject; Shift: TShiftState; X, Y: Integer );
begin
  if bMoviendo then
    with Sender as TControl do
    begin
      Left := X - iComponenteX + Left;
      Top  := Y - iComponenteY + Top;
    end;
end;

procedure TFPrincipal.ControlMouseUp( Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer );
begin
  if bMoviendo then
  begin
    bMoviendo := False;
    TMovible( Sender ).MouseCapture := False;
  end;
end;

Por ejemplo, si queremos mover una etiqueta por el formulario habría que asignar los eventos:

Label1.OnMouseDown := ControlMouseDown;
Label1.OnMouseUp := ControlMouseUp;
Label1.OnMouseMove := ControlMouseMove;

Con esto ya podemos crear nuestro propio editor de formularios sin tener que utilizar las propiedades DragKing y DragMode de los formularios que resultan algo engorrosas.

Pruebas realizadas en Delphi 7.

Averiguar los datos del usuario de Windows

Una de las mejores cosas que se pueden hacer en un programa cuando da un error es que nos envíe automáticamente los datos por correo electrónico. Pero es importante saber que usuario ha enviado el error dentro de la red local.

A continuación vamos a ver cuatro procedimientos que nos van a dar el nombre del usuario de Windows, el nombre de su PC en la red, su IP local y su IP pública.

Lo primero como siempre es añadir las unidades:

uses
  Windows, Messages, ..., WinSock, IdHttp, WinInet;

Esta función nos devuelve el nombre del usuario:

function LeerUsuarioWindows: string;
var
  sNombreUsuario: String;
  dwLongitudNombre: DWord;
begin
  dwLongitudNombre := 255;
  SetLength( sNombreUsuario, dwLongitudNombre );

  if GetUserName( PChar( sNombreUsuario ), dwLongitudNombre ) Then
    Result := Copy( sNombreUsuario, 1, dwLongitudNombre - 1 )
  else
    Result := 'Desconocido';
end;

Y esta otra nos da el nombre del PC en la red:

function LeerNombrePC: string;
var
  Buffer: array[0..255] of char;
  dwLongitud: DWord;
begin
  dwLongitud := 256;

  if GetComputerName( Buffer, dwLongitud ) then
    Result := Buffer
  else
    Result := ''
end;

La siguiente nos da la IP Local en la red:

function IPLocal: String;
var
  p: PHostEnt;
  s: array[0..128] of char;
  p2: pchar;
  wVersionRequested: WORD;
  wsaData: TWSAData;
begin
  // Arranca la librería WinSock
  wVersionRequested := MAKEWORD( 1, 1 );
  WSAStartup( wVersionRequested, wsaData );

  // Obtiene el nombre del PC
  GetHostName( @s, 128 );
  p := GetHostByName( @s );

  // Obtiene la dirección IP y libera la librería WinSock
  p2 := iNet_ntoa( PInAddr( p^.h_addr_list^ )^ );
  Result := Result + p2;
  WSACleanup;
end;

Y esta última lo que hace es decirnos nuestra IP pública conectando con el servidor dyndns.org y utiliza el componente Indy HTTP el cual leer el contenido del HTML:

function IP_Publica: string;

  function EsNumerico( S: string ): Boolean;
  begin
    Result := false;
    if ( Length( S ) > 0 ) then
      case S[1] of
        '0'..'9': Result := True;
      end;
  end;
var
  HTMLBody: string;
  i: Integer;
  IdHTTP: TIdHTTP;
begin
  Result := '';

  // ¿Estamos conectados a Internet?
  if WinInet.InternetGetConnectedState( nil, 0 ) then
  begin
    IdHTTP := TIdHTTP.Create( Application );

    try
      HTMLBody := IdHTTP.Get( 'http://checkip.dyndns.org/' );

      for i := 0 to Length( HTMLBody ) - 1 do
      begin
        if EsNumerico( HTMLBody[i] ) or ( HTMLBody[i] = '.' ) then
          Result := Result + HTMLBody[i];
      end;

     finally
       IdHTTP.Free;
     end;
  end;
end;

Pruebas realizadas en Delphi 7.

Leer la cabecera PE de un programa

¿Queréis verle las tripas a un archivo EXE? El siguiente procedimiento que voy a mostrar lee la cabecera PE de los archivos ejecutables y nos informa del punto de entrada del programa, el estado de los registros, la pila, etc.

Un archivo ejecutable se compone de distintas cabeceras dentro del mismo, ya sea si se va a ejecutar dentro del antiguo sistema operativo MS-DOS o en cualquier versión de Windows.

El siguiente procedimiento toma como parámetro un archivo ejecutable y lo guarda en un supuesto campo memo llamado INFORMACION que se encuentra en el formulario FPrincipal:

procedure TFPrincipal.ExaminarEXE( sArchivo: String );
var
  FS: TFilestream;
  Firma: DWORD;
  Cabecera_dos: IMAGE_DOS_HEADER;
  Cabecera_pe: IMAGE_FILE_HEADER;
  Cabecera_opc: IMAGE_OPTIONAL_HEADER;
begin
  INFORMACION.Clear;

  FS := TFilestream.Create( sArchivo, fmOpenread or fmShareDenyNone );

  try
    FS.Read( Cabecera_dos, SizeOf( Cabecera_dos ) );

    if Cabecera_dos.e_magic <> IMAGE_DOS_SIGNATURE then
    begin
      INFORMACION.Lines.Add( 'Cabecera DOS inválida' );
      Exit;
    end;
   
    LeerCabeceraDOS( Cabecera_dos, INFORMACION.Lines );

    FS.Seek( Cabecera_dos._lfanew, soFromBeginning );
    FS.Read( Firma, SizeOf( Firma ) );

    if Firma <> IMAGE_NT_SIGNATURE then
    begin
      INFORMACION.Lines.Add( 'Cabecera PE inválida' );
      Exit;
    end;

    FS.Read( Cabecera_pe, SizeOf( Cabecera_pe ) );
    LeerCabeceraPE( Cabecera_pe, INFORMACION.Lines );

    if Cabecera_pe.SizeOfOptionalHeader > 0 then
    begin
      FS.Read( Cabecera_opc, SizeOf( Cabecera_opc ) );
      LeerCabeceraOpcional( Cabecera_opc, INFORMACION.Lines );
    end;
  finally
    FS.Free;
  end;
end;

Éste a su vez llama a cada uno de los procedimientos que leen las cabeceras DOS, PE y opcional dentro del mismo EXE:

procedure LeerCabeceraDOS( const h: IMAGE_DOS_HEADER; Memo: TStrings );
begin
  Memo.Add( 'Cabecera DOS del archivo' );
  Memo.Add( Format( 'Número mágico: %d', [h.e_magic] ) );
  Memo.Add( Format( 'Byes de la última página del archivo: %d', [h.e_cblp] ) );
  Memo.Add( Format( 'Páginas en archivo: %d', [h.e_cp] ) );
  Memo.Add( Format( 'Relocalizaciones: %d', [h.e_crlc] ) );
  Memo.Add( Format( 'Tamaño de la cabecera en párrafos: %d', [h.e_cparhdr] ) );
  Memo.Add( Format( 'Mínimo número de párrafos que necesita: %d', [h.e_minalloc] ) );
  Memo.Add( Format( 'Máximo número de párrafos que necesita: %d', [h.e_maxalloc] ) );
  Memo.Add( Format( 'Valor inicial (relativo) SS: %d', [h.e_ss] ) );
  Memo.Add( Format( 'Valor inicial SP: %d', [h.e_sp] ) );
  Memo.Add( Format( 'Checksum: %d', [h.e_csum]));
  Memo.Add( Format( 'Valor inicial IP: %d', [h.e_ip] ) );
  Memo.Add( Format( 'Valor inicial (relativo) CS: %d', [h.e_cs] ) );
  Memo.Add( Format( 'Dirección del archivo de la tabla de relocalización: %d', [h.e_lfarlc] ) );
  Memo.Add( Format( 'Número overlay: %d', [h.e_ovno]));
  Memo.Add( Format( 'Identificador OEM (para e_oeminfo): %d', [h.e_oemid] ) );
  Memo.Add( Format( 'Información OEM; específico e_oemid: %d', [h.e_oeminfo] ) );
  Memo.Add( Format( 'Dirección de la nueva cabecera exe: %d', [h._lfanew] ) );
  Memo.Add( '' );
end;

procedure LeerCabeceraPE( const h: IMAGE_FILE_HEADER; Memo: TStrings );
var
  Fecha: TDateTime;
begin
  Memo.Add( 'Cabecera PE del archivo' );
  Memo.Add( Format( 'Máquina: %4x', [h.Machine]));

  case h.Machine of
    IMAGE_FILE_MACHINE_UNKNOWN : Memo.Add(' Máquina desconocida ' );
    IMAGE_FILE_MACHINE_I386: Memo.Add( ' Intel 386. ' );
    IMAGE_FILE_MACHINE_R3000: Memo.Add( ' MIPS little-endian, 0x160 big-endian ' );
    IMAGE_FILE_MACHINE_R4000: Memo.Add( ' MIPS little-endian ' );
    IMAGE_FILE_MACHINE_R10000: Memo.Add( ' MIPS little-endian ' );
    IMAGE_FILE_MACHINE_ALPHA: Memo.Add( ' Alpha_AXP ' );
    IMAGE_FILE_MACHINE_POWERPC: Memo.Add( ' IBM PowerPC Little-Endian ' );
    $14D: Memo.Add( ' Intel i860' );
    $268: Memo.Add( ' Motorola 68000' );
    $290: Memo.Add( ' PA RISC' );
    else
      Memo.Add( ' tipo de máquina desconocida' );
  end;

  Memo.Add( Format( 'Número de secciones: %d', [h.NumberOfSections] ) );
  Memo.Add( Format( 'Fecha y hora: %d', [h.TimeDateStamp] ) );
  Fecha := EncodeDate( 1970, 1, 1 ) + h.Timedatestamp / SecsPerDay;
  Memo.Add( FormatDateTime( ' c', Fecha ) );

  Memo.Add( Format( 'Puntero a la tabla de símbolos: %d', [h.PointerToSymbolTable] ) );
  Memo.Add( Format( 'Número de símbolos: %d', [h.NumberOfSymbols] ) );
  Memo.Add( Format( 'Tamaño de la cabecera opcional: %d', [h.SizeOfOptionalHeader] ) );
  Memo.Add( Format( 'Características: %d', [h.Characteristics] ) );

  if ( IMAGE_FILE_DLL and h.Characteristics ) <> 0 then
    Memo.Add(' el archivo es una' )
  else
    if (IMAGE_FILE_EXECUTABLE_IMAGE and h.Characteristics) <> 0 then
      Memo.Add(' el archivo es un programa' );

  Memo.Add('');
end;

procedure LeerCabeceraOpcional( const h: IMAGE_OPTIONAL_HEADER; Memo: TStrings );
begin
  Memo.Add( 'Información sobre la cabecera PE de un archivo ejecutable EXE' );
  Memo.Add( Format( 'Magic: %d', [h.Magic] ) );

  case h.Magic of
    $107: Memo.Add( ' Imagen de ROM' );
    $10b: Memo.Add( ' Imagen de ejecutable' );
    else
      Memo.Add( ' Tipo de imagen desconocido' );
  end;

  Memo.Add( Format( 'Versión mayor del enlazador: %d', [h.MajorLinkerVersion] ) );
  Memo.Add( Format( 'Versión menor del enlazador: %d', [h.MinorLinkerVersion]));
  Memo.Add( Format( 'Tamaño del código: %d', [h.SizeOfCode]));
  Memo.Add( Format( 'Tamaño de los datos inicializados: %d', [h.SizeOfInitializedData]));
  Memo.Add( Format( 'Tamaño de los datos sin inicializar: %d', [h.SizeOfUninitializedData]));
  Memo.Add( Format( 'Dirección del punto de entrada: %d', [h.AddressOfEntryPoint]));
  Memo.Add( Format( 'Base de código: %d', [h.BaseOfCode]));
  Memo.Add( Format( 'Base de datos: %d', [h.BaseOfData]));
  Memo.Add( Format( 'Imagen base: %d', [h.ImageBase]));
  Memo.Add( Format( 'Alineamiento de la sección: %d', [h.SectionAlignment]));
  Memo.Add( Format( 'Alineamiento del archivo: %d', [h.FileAlignment]));
  Memo.Add( Format( 'Versión mayor del sistema operativo: %d', [h.MajorOperatingSystemVersion]));
  Memo.Add( Format( 'Versión mayor del sistema operativo: %d', [h.MinorOperatingSystemVersion]));
  Memo.Add( Format( 'Versión mayor de la imagen: %d', [h.MajorImageVersion]));
  Memo.Add( Format( 'Versión menor de la imagen: %d', [h.MinorImageVersion]));
  Memo.Add( Format( 'Versión mayor del subsistema: %d', [h.MajorSubsystemVersion]));
  Memo.Add( Format( 'Versión menor del subsistema: %d', [h.MinorSubsystemVersion]));
  Memo.Add( Format( 'Valor de la versión Win32: %d', [h.Win32VersionValue]));
  Memo.Add( Format( 'Tamaño de la imagen: %d', [h.SizeOfImage]));
  Memo.Add( Format( 'Tamaño de las cabeceras: %d', [h.SizeOfHeaders]));
  Memo.Add( Format( 'CheckSum: %d', [h.CheckSum]));
  Memo.Add( Format( 'Subsistema: %d', [h.Subsystem]));

  case h.Subsystem of
    IMAGE_SUBSYSTEM_NATIVE:
      Memo.Add( ' La imagen no requiere un subsistema. ' );

    IMAGE_SUBSYSTEM_WINDOWS_GUI:
      Memo.Add( ' La imagen se corre en un subsistema GUI de Windows. ' );

    IMAGE_SUBSYSTEM_WINDOWS_CUI:
      Memo.Add( ' La imagen corre en un subsistema terminal de Windows. ' );

    IMAGE_SUBSYSTEM_OS2_CUI:
      Memo.Add( ' La imagen corre sobre un subsistema terminal de OS/2. ' );

    IMAGE_SUBSYSTEM_POSIX_CUI:
      Memo.Add( ' La imagen corre sobre un subsistema terminal Posix. ' );
    else
      Memo.Add( ' Subsistema desconocido.' )
  end;

  Memo.Add( Format( 'Características DLL: %d', [h.DllCharacteristics]) );
  Memo.Add( Format( 'Tamaño de reserva de la pila: %d', [h.SizeOfStackReserve]) );
  Memo.Add( Format( 'Tamaño de trabajo de la pila: %d', [h.SizeOfStackCommit]) );
  Memo.Add( Format( 'Tamaño del Heap de reserva: %d', [h.SizeOfHeapReserve]) );
  Memo.Add( Format( 'Tamaño de trabajo del Heap: %d', [h.SizeOfHeapCommit]) );
  Memo.Add( Format( 'Banderas de carga: %d', [h.LoaderFlags] ) );
  Memo.Add( Format( 'Numeros RVA y tamaño: %d', [h.NumberOfRvaAndSizes] ) );
end;

Espero que os sea de utilidad si os gusta programar herramientas de administración de sistemas operativos Windows.

Pruebas realizadas en Delphi 7.

Leer las dimensiones de imágenes JPG, PNG y GIF

Si estáis pensando en crear un visor de fotografías aquí os traigo tres procedimientos que leen al ancho y alto de imagenes con extensión JPG, PNG y GIF leyendo los bytes de su cabecera. No hay para BMP ya que se puede hacer con un componente TImage.

Antes de nada hay que incluir una función que lee los enteros almacenados en formato del procesador motorola, que guarda los formatos enteros en memoria al contrario de los procesadores Intel/AMD:

function LeerPalabraMotorola( F: TFileStream ): Word;
type
  TPalabraMotorola = record
    case Byte of
      0: ( Value: Word );
      1: ( Byte1, Byte2: Byte );
  end;
var
  MW: TPalabraMotorola;
begin
  F.Read( MW.Byte2, SizeOf( Byte ) );
  F.Read( MW.Byte1, SizeOf( Byte ) );
  Result := MW.Value;
end;

El siguiente procedimiento toma como parámetros la ruta y nombre de una imagen JPG, y dos variales enteras donde se almacenará el ancho y alto de la imagen:

procedure DimensionJPG( sArchivo: string; var wAncho, wAlto: Word );
const
  ValidSig: array[0..1] of Byte = ($FF, $D8);
  Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
var
  Sig: array[0..1] of byte;
  F: TFileStream;
  x: integer;
  Seg: byte;
  Dummy: array[0..15] of byte;
  Len: word;
  iLongitudLinea: LongInt;
begin
  FillChar( Sig, SizeOf( Sig ), #0 );

  F := TFileStream.Create( sArchivo, fmOpenRead );
  try
    iLongitudLinea := F.Read( Sig[0], SizeOf( Sig ) );

    for x := Low( Sig ) to High( Sig ) do
      if Sig[x] <> ValidSig[x] then
        iLongitudLinea := 0;

    if iLongitudLinea > 0 then
    begin
      iLongitudLinea := F.Read( Seg, 1 );

      while ( Seg = $FF ) and ( iLongitudLinea > 0 ) do
      begin
        iLongitudLinea := F.Read( Seg, 1 );

        if Seg <> $FF then
        begin
          if ( Seg = $C0 ) or ( Seg = $C1 ) then
          begin
            iLongitudLinea := F.Read( Dummy[0], 3 ); // Nos saltamos estos bytes
            wAlto := LeerPalabraMotorola( F );
            wAncho  := LeerPalabraMotorola( F );
          end
          else
          begin
            if not ( Seg in Parameterless ) then
            begin
              Len := LeerPalabraMotorola( F );
              F.Seek( Len - 2, 1 );
              F.read( Seg, 1 );
            end
            else
              Seg := $FF; { Fake it to keep looping. }
          end;
        end;
      end;
    end;
  finally
    F.Free;
  end;
end;

Lo mismo para una imagen PNG:

procedure DimensionPNG( sArchivo: string; var wAncho, wAlto: Word );
type
  TPNGSig = array[0..7] of Byte;
const
  ValidSig: TPNGSig = (137,80,78,71,13,10,26,10);
var
  Sig: TPNGSig;
  F: TFileStream;
  x: Integer;
begin
  FillChar( Sig, SizeOf( Sig ), #0 );
  F := TFileStream.Create( sArchivo, fmOpenRead );
  try
    F.read( Sig[0], SizeOf( Sig ) );

    for x := Low( Sig ) to High( Sig ) do
      if Sig[x] <> ValidSig[x] then
        Exit;

    F.Seek( 18, 0 );
    wAncho := LeerPalabraMotorola( F );
    F.Seek( 22, 0 );
    wAlto := LeerPalabraMotorola( F );
  finally
    F.Free;
  end;
end;

Y para una imagen GIF:

procedure DimensionGIF( sArchivo: string; var wAncho, wAlto: Word );
type
  TCabeceraGIF = record
    Sig: array[0..5] of char;
    ScreenWidth, ScreenHeight: Word;
    Flags, Background, Aspect: Byte;
  end;

  TBloqueImagenGIF = record
    Left, Top, Width, Height: Word;
    Flags: Byte;
  end;
var
  F: file;
  Cabecera: TCabeceraGIF;
  BloqueImagen: TBloqueImagenGIF;
  iResultado: Integer;
  x: Integer;
  c: char;
  bEncontradasDimensiones: Boolean;
begin
  wAncho  := 0;
  wAlto := 0;

  if sArchivo = '' then
    Exit;

  {$I-}
  FileMode := 0;   // Sólo lectura
  AssignFile( F, sArchivo );
  Reset( F, 1);
  if IOResult <> 0 then
    Exit;

  // Lee la cabecera y se asegura de que sea un archivo válido
  BlockRead( F, Cabecera, SizeOf( TCabeceraGIF ), iResultado );

  if ( iResultado <> SizeOf( TCabeceraGIF ) ) or ( IOResult <> 0 ) or
     ( StrLComp( 'GIF', Cabecera.Sig, 3 ) <> 0 ) then
  begin
    Close( F );
    Exit;
  end;

  { Skip color map, if there is one }
  if ( Cabecera.Flags and $80 ) > 0 then
  begin
    x := 3 * ( 1 shl ( ( Cabecera.Flags and 7 ) + 1 ) );
    Seek( F, x );
    if IOResult <> 0 then
    begin
      Close( F );
      Exit;
    end;
  end;

  bEncontradasDimensiones := False;
  FillChar( BloqueImagen, SizeOf( TBloqueImagenGIF ), #0 );

  BlockRead( F, c, 1, iResultado );
  while ( not EOF( F ) ) and ( not bEncontradasDimensiones ) do
  begin
    case c of
      ',': // Encontrada imagen
        begin
          BlockRead( F, BloqueImagen, SizeOf( TBloqueImagenGIF ), iResultado );
          if iResultado <> SizeOf( TBloqueImagenGIF ) then
          begin
            Close( F );
            Exit;
          end;

          wAncho := BloqueImagen.Width;
          wAlto := BloqueImagen.Height;
          bEncontradasDimensiones := True;
        end;
       
      'ÿ': // esquivar esto
        begin
          // Nada
        end;

      // No hacer nada, ignorar
    end;

    BlockRead( F, c, 1, iResultado );
  end;

  Close( F );
  {$I+}
end;

Así no será necesario cargar toda la imagen para averiguar sus dimensiones.

Pruebas realizadas en Delphi 7.

Descargar un archivo de Internet sin utilizar componentes

Añadiendo a nuestro formulario la librería WinINet se pueden descargar archivos por HTTP con la siguiente función:

function DescargarArchivo( sURL, sArchivoLocal: String ): boolean;
const BufferSize = 1024;
var
  hSession, hURL: HInternet;
  Buffer: array[1..BufferSize] of Byte;
  LongitudBuffer: DWORD;
  F: File;
  sMiPrograma: String;
begin
  sMiPrograma := ExtractFileName( Application.ExeName );
  hSession := InternetOpen( PChar( sMiPrograma ), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0 );

  try
    hURL := InternetOpenURL( hSession, PChar( sURL ), nil, 0, 0, 0 );

    try
      AssignFile( F, sArchivoLocal );
      Rewrite( F, 1 );

      repeat
        InternetReadFile( hURL, @Buffer, SizeOf( Buffer ), LongitudBuffer );
        BlockWrite( F, Buffer, LongitudBuffer );
      until LongitudBuffer = 0;

      CloseFile( F );
      Result := True;
    finally
      InternetCloseHandle( hURL );
    end
  finally
    InternetCloseHandle( hSession );
  end
end;

El primer parámetro es la URL completa del archivo a descargar y el segundo la ruta y nombre del archivo donde se va a guardar en nuestro disco duro. Un ejemplo de llamada a la función sería:

DescargarArchivo( 'http:\\miweb.com\imagen.jpg', 'C:\Mis documentos\imagen.jpg' );

Pruebas realizadas en Delphi 7.

Averiguar el nombre del procesador y su velocidad

El registro de Windows suele almacenar gran cantidad de información no sólo de la configuración de los programas instalados, sino también el estado real del hardware de nuestro PC.

En esta ocasión vamos a leer el nombre del procesador y su velocidad desde nuestro programa. Antes de nada añadimos a uses:

uses
  Windows, Messages, ..., Registry;

La siguiente función nos devuelve el nombre del procesador:

function NombreProcesador: string;
var
  Registro: TRegistry;
begin
  Result := '';
  Registro := TRegistry.Create;

  try
    Registro.RootKey := HKEY_LOCAL_MACHINE;

    if Registro.OpenKey( '\Hardware\Description\System\CentralProcessor\0', False ) then
      Result := Registro.ReadString( 'Identifier' );
  finally
    Registro.Free;
  end;
end;

Y esta otra nos da su velocidad (según la BIOS y el fabricante):

function VelocidadProcesador: string;
var
  Registro: TRegistry;
begin
  Registro := TRegistry.Create;
  try
    Registro.RootKey := HKEY_LOCAL_MACHINE;

    if Registro.OpenKey( 'Hardware\Description\System\CentralProcessor\0', False ) then
    begin
      Result := IntToStr( Registro.ReadInteger( '~MHz' ) ) + ' MHz';
      Registro.CloseKey;
    end;
  finally
    Registro.Free;
  end;
end;

Hay veces que dependiendo del procesador y del multiplicador de la BIOS casi nunca coincide la velocidad real que nos da Windows con la de verdad (sobre todo en procesadores AMD). Aquí tenemos otra función que calcula en un segundo la velocidad real del procesador con una pequeña rutina en ensamblador:

function CalcularVelocidadProcesador: Double;
const
  Retardo = 500;
var
  TimerHi, TimerLo: DWORD;
  ClasePrioridad, Prioridad: Integer;
begin
  ClasePrioridad := GetPriorityClass( GetCurrentProcess );
  Prioridad := GetThreadPriority( GetCurrentThread );

  SetPriorityClass( GetCurrentProcess, REALTIME_PRIORITY_CLASS );
  SetThreadPriority( GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL );

  Sleep( 10 );
 
  asm
    dw 310Fh
    mov TimerLo, eax
    mov TimerHi, edx
  end;

  Sleep( Retardo );

  asm
    dw 310Fh
    sub eax, TimerLo
    sbb edx, TimerHi
    mov TimerLo, eax
    mov TimerHi, edx
  end;

  SetThreadPriority( GetCurrentThread, Prioridad );
  SetPriorityClass( GetCurrentProcess, ClasePrioridad );

  Result := TimerLo / ( 1000 * Retardo );
end;

Nos devuelve el resultado en una variable double, donde que podríamos sacar la información en pantalla de la siguiente manera:

ShowMessage( Format( 'Velocidad calculada: %f MHz', [CalcularVelocidadProcesador] ) );

Pruebas realizadas en Delphi 7.

Convertir un icono en imagen BMP

Aunque hay cientos de librerías de iconos por la red que suele utilizar todo el mundo para sus programas, lo ideal sería diseñar nuestros propios iconos utilizando como plantilla los que hay por Internet.

Se que hay decenas de programas de diseño que convierten entre distintos formatos, pero lo ideal sería tener nuestro propio conversor. Para ello tenemos el siguiente procedimiento que convierte un archivo ICO en una imagen BMP para que luego podamos utilizarla en nuestras aplicaciones:

procedure ConvertirImagen( sIcono, sBMP: String );
var
  Bitmap: TBitmap;
  Imagen: TImage;
begin
  Imagen := TImage.Create( nil );
  Imagen.Picture.LoadFromFile( sIcono );
  Bitmap := TBitMap.Create;

  with Bitmap do
  begin
    PixelFormat := pf24bit;
    Height := Application.Icon.Height;
    Width := Application.Icon.Width;
    Canvas.Draw( 0, 0, Imagen.Picture.Graphic );
  end;

  Bitmap.SavetoFile( sBMP );

  Imagen.Free;
end;

El primer parámetro es el icono y el segundo la imagen BMP resultante. Lo que hace el procedimiento es cargar el icono en un objeto TImage, para después copiar su contenido en un bitmap antes de guardarlo en un archivo.

Pruebas realizadas en Delphi 7.

Borrar archivos temporales de Internet

Uno de los componentes más útiles de Delphi hoy en día es WebBrowser el cual nos permite crear dentro de nuestros programas un navedador web utilizando el motor de Internet Explorer.

El único inconveniente es que al finalizar nuestro programa tenemos que ir a Internet Explorer y vaciar la caché, evitando que se llene el disco duro de basura.

Pues vamos a ver un procedimiento que elimina los archivos temporales de Internet Explorer, no sin antes añadir la unidad WinINet:

uses
  Windows, Messages, ..., WinInet;

procedure BorrarCacheIE;
var
  lpEntryInfo: PInternetCacheEntryInfo;
  hCacheDir: LongWord;
  dwEntrySize: LongWord;
begin
  dwEntrySize := 0;
  FindFirstUrlCacheEntry( nil, TInternetCacheEntryInfo( nil^ ), dwEntrySize );
  GetMem( lpEntryInfo, dwEntrySize );

  if dwEntrySize > 0 then
    lpEntryInfo^.dwStructSize := dwEntrySize;

  hCacheDir := FindFirstUrlCacheEntry( nil, lpEntryInfo^, dwEntrySize );

  if hCacheDir <> 0 then
  begin
    repeat
      DeleteUrlCacheEntry( lpEntryInfo^.lpszSourceUrlName );
      FreeMem( lpEntryInfo, dwEntrySize );
      dwEntrySize := 0;
      FindNextUrlCacheEntry( hCacheDir, TInternetCacheEntryInfo( nil^ ), dwEntrySize );
      GetMem( lpEntryInfo, dwEntrySize );

      if dwEntrySize > 0 then
        lpEntryInfo^.dwStructSize := dwEntrySize;

    until not FindNextUrlCacheEntry( hCacheDir, lpEntryInfo^, dwEntrySize );
  end;

  FreeMem( lpEntryInfo, dwEntrySize );
  FindCloseUrlCache( hCacheDir );
end;

Este procedimiento habría que ejecutarlo al cerrar nuestro programa dejando el sistema limpio.

Pruebas realizadas en Delphi 7.

Deshabilitar el cortafuegos de Windows XP

Una de las tareas más frecuentes a las que se enfrenta un programador es la de crear aplicaciones que automaticen procesos de nuestra aplicación tales como subir datos por FTP, conectar con otro motor de bases de datos para enviar, etc.

Y si hay algún programa que pueda interrumpir el proceso de cara a las comunicaciones TCP/IP es el cortafuegos de Windows. Primero añadimos a uses:

uses
  Windows, Messages, ..., WinSvc, ShellApi;

Este sería un el procedimiento que detiene el servicio:

procedure DeshabilitarCortafuegosXP;
var
  SCM, hService: LongWord;
  sStatus: TServiceStatus;
begin
  SCM := OpenSCManager( nil, nil, SC_MANAGER_ALL_ACCESS );
  hService := OpenService( SCM, PChar( 'SharedAccess' ), SERVICE_ALL_ACCESS );
  ControlService( hService, SERVICE_CONTROL_STOP, sStatus );
  CloseServiceHandle( hService );
end;

Para volver a activarlo sólo hay que ir al panel de control y ponerlo en marcha de nuevo. Esto no vale para otros cortafuegos (Panda, Norton, etc.)

Pruebas realizadas en Delphi 7.

Leer el número de serie de una unidad

Cuando se vende un programa generalmente se suele poner el precio según el número de equipos donde se va a instalar (licencia). Proteger nuestra aplicación contra copias implica leer algo característico en el PC que lo haga único.

Pues bien, cuando se formatea una unidad de disco Windows le asigna un número de serie que no cambiará hasta que vuelva a ser formateada. Lo que vamos a hacer es una función que toma como parámetro la unidad de disco que le pasemos (C:, D:, ...) y nos devolverá su número de serie:

function LeerSerieDisco( cUnidad: Char ): String;
var
  dwLongitudMaxima, VolFlags, dwSerie: DWord;
begin
  if GetVolumeInformation( PChar( cUnidad + ':\' ), nil, 0,
                           @dwSerie, dwLongitudMaxima, VolFlags, nil, 0) then
  begin
    // devolvemos el número de serie en hexadecimal
    Result := IntToHex( dwSerie, 8 );
    Insert( '-', Result, 5 );
  end
  else
    Result := '';
end;

Nos devolverá algo como esto:

D4BD-0EC7

Con ese número ya podemos crear nuestro propio keygen alterando las letras, el orden o utilizando el algoritmo de encriptación que nos apetezca.

El único inconveniente es que si el usuario vuelve a formatear esa unidad entonces nos tiene que volver a pedir el número de serie. Hay otros programadores que prefieren leer el número de la BIOS o de la tarjeta de video, ya depende del nivel de protección que se desee.

Pruebas realizadas en Delphi 7.

Leer los archivos del portapapeles

El siguiente procedimiento lee el nombre de archivos o directorios del portapapales capturados por el usuario con CTRL + C ó CTRL + X y los muestra en un ListBox que le pasamos como parámetro:

procedure LeerArchivosPortapapeles( Lista: TListBox );
var
  HPortapapeles: THandle;  // Handle del portapapeles
  iNumArc, i: Integer;     // Nº de archivos
  Archivo: array [0..MAX_PATH - 1] of char;
begin
  if ClipBoard.HasFormat( CF_HDROP ) then
  begin
    HPortapapeles := ClipBoard.GetAsHandle( CF_HDROP );
    iNumArc := DragQueryFile( HPortapapeles, $FFFFFFFF, nil, 0);

    for i := 0 to iNumArc - 1 do
    begin
      DragQueryFile( HPortapapeles, i, @Archivo, MAX_PATH );
      Lista.Items.Add( Archivo );
    end;
  end;
end;

Para poder compilarlo hay que añadir las unidades externas:

uses
  Windows, Messages, ..., ClipBrd, ShellAPI;

Sólo mostrará archivos o directorios y no imágenes o cualquier otro archivo capturado dentro de un programa. Puede sernos de utilidad para realizar programas de copia de seguridad, conversiones de archivo, etc.

Pruebas realizadas en Delphi 7.