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.

Listar los programas instalados en Windows

Windows almacena la lista de programas instalados (Agregar/Quitar programas) en la clave de registro:

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\

En esa clave hay tantas subclaves como programas instalados. Pero lo que nos interesa a nosotros no es el nombre de la clave del programa instalado sino el nombre del programa que muestra Windows en Agregar/Quitar programas. Para ello entramos en cada clave y leemos el valor DisplayName.

Lo primero añadimos la unidad:

uses
  Windows, Messages, ..., Registry;

Y aquí tenemos un procedimiento al cual le pasamos un ListBox y nos lo rellena con la lista de programas instalados en Windows:

procedure ListarAplicaciones( Lista: TListBox );
const
  INSTALADOS = '\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall';
var
  Registro: TRegistry;
  Lista1 : TStringList;
  Lista2 : TStringList;
  j, n : integer;
begin
  Registro := TRegistry.Create;
  Lista1 := TStringList.Create;
  Lista2 := TStringList.Create;

  // Guardamos todas las claves en la lista 1
  with Registro do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey( INSTALADOS, False );
    GetKeyNames( Lista1 );
  end;

  // Recorremos la lista 1 y leemos el nombre del programa instalado
  for j := 0 to Lista1.Count-1 do
  begin
    Registro.OpenKey( INSTALADOS + '\' + Lista1.Strings[j], False );
    Registro.GetValueNames( Lista2 );

    // Mostramos el programa instalado sólo si tiene DisplayName
    n := Lista2.IndexOf( 'DisplayName' );
    if ( n <> -1 ) and ( Lista2.IndexOf('UninstallString') <> -1 ) then
      Lista.Items.Add( ( Registro.ReadString( Lista2.Strings[n] ) ) );
  end;

  Lista.Sorted := True; // Ordenamos la lista alfabéticamente
  Lista1.Free;
  Lista2.Free;
  Registro.CloseKey;
  Registro.Destroy;
end;

Con esto se podría hacer un programa que eliminara de Agregar/Quitar programas aquellas claves de programas mal desinstalados.

Pruebas realizadas en Delphi 7.

Ejecutar un programa y esperar a que termine

Uno de los problemas habituales con los que se enfrenta un programador es que su cliente le pida algo que o bien no sabe como programarlo o no dispone del componente o librería necesaria para llevar tu tarea a cabo.

Un ejemplo puede ser realizar una copia de seguridad en formatos ZIP, RAR, 7Z, etc., convertir de un formato de video o sonido a otro e incluso llamar a comandos del sistema para realizar procesos criticos en un servidor. Entonces sólo se nos ocurre llamar a un programa externo que realice la tarea por nosostros (y que soporte parámetros).

Sé lo que estáis pensando (la función WinExec), pero en este caso no me vale ya que el programa tiene que esperar a que termine de ejecutarse antes de pasar al siguiente proceso.

Aquí os muestro un procedimiento que ejecuta un programa y se queda esperando a que termine:

function EjecutarYEsperar( sPrograma: String; Visibilidad: Integer ): Integer;
var
  sAplicacion: array[0..512] of char;
  DirectorioActual: array[0..255] of char;
  DirectorioTrabajo: String;
  InformacionInicial: TStartupInfo;
  InformacionProceso: TProcessInformation;
  iResultado, iCodigoSalida: DWord;
begin
  StrPCopy( sAplicacion, sPrograma );
  GetDir( 0, DirectorioTrabajo );
  StrPCopy( DirectorioActual, DirectorioTrabajo );
  FillChar( InformacionInicial, Sizeof( InformacionInicial ), #0 );
  InformacionInicial.cb := Sizeof( InformacionInicial );

  InformacionInicial.dwFlags := STARTF_USESHOWWINDOW;
  InformacionInicial.wShowWindow := Visibilidad;
  CreateProcess( nil, sAplicacion, nil, nil, False,
                 CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS,
                 nil, nil, InformacionInicial, InformacionProceso );

  // Espera hasta que termina la ejecución
  repeat
    iCodigoSalida := WaitForSingleObject( InformacionProceso.hProcess, 1000 );
    Application.ProcessMessages;
  until ( iCodigoSalida <> WAIT_TIMEOUT );

  GetExitCodeProcess( InformacionProceso.hProcess, iResultado );
  MessageBeep( 0 );
  CloseHandle( InformacionProceso.hProcess );
  Result := iResultado;
end;

El parámetro iVisibilidad puede ser:

SW_SHOWNORMAL     -> Lo normal
SW_SHOWMINIMIZED  -> Minimizado (ventanas MS-DOS o ventanas no modales)
SW_HIDE           -> Oculto     (ventanas MS-DOS o ventanas no modales)

La función devuelve un cero si la ejecución terminó correctamente.

Por ejemplo para ejecutar la calculadora de Windows y esperar a que termine:

procedure EjecutarCalculadora;
begin
  if EjecutarYEsperar( 'C:\Windows\System32\Calc.exe', SW_SHOWNORMAL ) = 0 then
    ShowMessage( 'Ejecución terminada con éxito.' )
  else
    ShowMessage( 'Ejecución no terminada correctamente.' );
end;

Pruebas realizadas en Delphi 7.

Obtener modos de video

A la hora de realizar un programa hay que tener muy presente la resolución de la pantalla y el área de trabajo donde se pueden colocar las ventanas.

Para ello tenemos el objeto TScreen que nos devuelve no sólo la resolución actual de video sino que además nos da el tamaño del escritorio y el área de trabajo del mismo (si esta fija la barra de tareas hay que respetar su espacio y procurar que nuestra ventana no se superponga a la misma).

Si utilizamos las propiedades Position o WindowsState del formulario no hay que preocuparse por esto, pero si hemos creado nuestra propia piel y pasamos de las ventanas normales de Windows hay que andarse con ojo y no dejar que el usuario se crea que ha desaparecido la barra de tareas.

El siguiente procedimiento vuelca la información de la pantalla actual en un objeto Memo llamado PANTALLA:

procedure TFInformacion.InfoPantalla;
begin
  PANTALLA.Lines.Clear;
  PANTALLA.Lines.Add( Format( 'Resolución: %dx%d ', [Screen.Width, Screen.Height] ) );
  PANTALLA.Lines.Add( Format( 'Escritorio: x: %d y: %d Ancho: %d Alto: %d',
                      [Screen.DesktopLeft, Screen.DesktopTop, Screen.DesktopWidth, Screen.DesktopHeight] ) );
  PANTALLA.Lines.Add( Format( 'Area de trabajo: x: %d y: %d Ancho: %d Alto: %d',
                      [Screen.WorkAreaLeft, Screen.WorkAreaTop, Screen.WorkAreaWidth, Screen.WorkAreaHeight] ) );
end;

Otra información interesante sería saber que resoluciones posibles tiene nuestra tarjeta de video. Vamos a mostrar todos los modos de video posible en un ListBox llamado MODOS:

procedure TFInformacion.InfoModosVideo;
var i: Integer;
    ModoVideo: TDevMode;
begin
  i := 0;
  MODOS.Clear;
  while EnumDisplaySettings( nil, i, ModoVideo ) do
  begin
    with ModoVideo do
      MODOS.Items.Add(Format( '%dx%d %d Colores', [dmPelsWidth, dmPelsHeight, Int64(1) shl dmBitsperPel] ) );

    Inc( i );
  end;
end;

Esta es la típica información que suelen mostrar los programas tipo TuneUp.

Pruebas realizadas en Delphi 7.

Formularios transparentes

Si estais hartos de que vuestros formularios tengan el mismo aspecto soso de siempre podeis crear nuevos temas y skins tales como los reproductores BSPlayer, WinDVD, PowerDVD, etc.

Para ello tenemos aquí un procedimiento que toma como parámetro un formulario y que hará que todo su fondo sea transparente. Si queremos que algo no sea transparente lo ponemos dentro de un bitmap, shape o panel.

procedure TransparentarFormulario( Form: TForm );
var
  Region, RegionTemp: HRGN;
  i: Integer;
  Rect: TRect;
begin
  Region := 0;

  for i := 0 to Form.ControlCount - 1 do
  begin
    Rect := Form.Controls[i].BoundsRect;
    OffsetRect( Rect, Form.ClientOrigin.x - Form.Left, Form.ClientOrigin.y - Form.Top );
    RegionTemp := CreateRectRgnIndirect( Rect );

    if Region = 0 then
      Region := RegionTemp
    else
    begin
      CombineRgn( Region, Region, RegionTemp, RGN_OR );
      DeleteObject( RegionTemp );
    end;
  end;

  RegionTemp := CreateRectRgn( 0, 0, Form.Width,
                               GetSystemMetrics( SM_CYCAPTION )+
                               GetSystemMetrics( SM_CYSIZEFRAME )+
                               GetSystemMetrics( SM_CYMENU ) * Ord( Form.Menu <> nil ) );

  CombineRgn( Region, Region, RegionTemp, RGN_OR );
  DeleteObject( RegionTemp );
  SetWindowRgn( Form.Handle, Region, True );
end;

Quitando los margenes de la ventana con BorderStyle = bsNone ya tenemos un formulario completamente transparente donde sólo hay que insertarle los objetos que van a ser visibles.

Pruebas realizadas en Delphi 7.

Utilizar una fuente TTF sin instalarla

Uno de los primeros inconvenientes al distribuir nuestras aplicaciones es ver que en otros Windows aparecen nuestras etiquetas y campos desplazados debido a que la fuente que utilizan no es la que tenemos nosotros en nuestro equipo.

O bien utilizamos fuentes estandar tales como Tahoma, Arial, etc. o podemos utilizar el siguiente truco que consiste en añadir la fuente utilizada al lado de nuestro ejecutable y cargarla al arrancar nuestra aplicación.

El procedimiento para cargar una fuente es:

procedure CargarFuente( sFuente: String );
begin
  AddFontResource( PChar( ExtractFilePath( Application.ExeName ) + sFuente ) );
  SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );
end;

Y en el procedimiento OnCreate de nuestro formulario cargamos la fuente:

procedure TFPrincipal.FormCreate( Sender: TObject );
begin
  CargarFuente( 'Diner.ttf' );
  Etiqueta.Font.Name := 'Diner';
end;

Donde se supone que el archivo Diner.ttf está al lado de nuestro ejecutable.

Antes de cerrar nuestra aplicación debemos liberar de memoria la fuente utilizada con el procedimiento:

procedure EliminarFuente( sFuente: String );
begin
  RemoveFontResource( PChar( ExtractFilePath( Application.ExeName ) + sFuente ) );
  SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );
end;

Este prodecimiento sería llamado en el evento OnDestroy del formulario:

procedure TFPrincipal.FormDestroy( Sender: TObject );
begin
  EliminarFuente( 'Diner.ttf' );
end;

Es recomendable hacer esto una sola vez en el formulario principal de la aplicación y no en cada formulario del programa, a menos que tengamos un formulario que utiliza exclusivamente una fuente en concreto.

Pruebas realizadas en Delphi 7.