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.
