Lenguaje de programación Borland Delphi
Este ejemplo muestra cómo obtener la información de un fichero ejecutable o de una librería (versión, extensión, nombre, compañía, descripción, tamaño, fecha de creación, fecha de última modificación, fecha de último acceso, ...). Para ello hemos utilizado varias funcines del Api de Windows: "GetFileVersionInfo", "GetFileTime", ... a continuación mostramos el código fuente/Source code completo en Delphi 6:
unit UnidadMenuPrincipal;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, shellapi;
type
TformMenuPrincipal = class(TForm)
txtFichero: TEdit;
Label1: TLabel;
bSeleccionar: TButton;
dlAbrir: TOpenDialog;
bInformacionFichero: TButton;
lInfo: TMemo;
Label2: TLabel;
bGuardar: TButton;
Button1: TButton;
dlGuardar: TSaveDialog;
LWEB: TLabel;
procedure bSeleccionarClick(Sender: TObject);
procedure bInformacionFicheroClick(Sender: TObject);
//para arrastrar y soltar
procedure SoltarFichero (var Msg: TWMDropFiles); message WM_DROPFILES;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure bGuardarClick(Sender: TObject);
procedure LWEBClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
formMenuPrincipal: TformMenuPrincipal;
implementation
{$R *.dfm}
//si se utilizar drag and drop (arrastrar y soltar)
procedure TformMenuPrincipal.SoltarFichero (var Msg : TWMDropFiles);
var
CFileName: array[0..MAX_PATH] of Char;
begin
try
if DragQueryFile(Msg.Drop, 0, CFileName, MAX_PATH) > 0 then
begin
txtFichero.Text := CFileName;
bInformacionFicheroClick(nil);
Msg.Result := 0;
end;
finally
DragFinish(Msg.Drop); //finaliza arrastrar y soltar
end;
end;
function versionFichero (const FileName: TFileName; var Major, Minor, Release, Build : word): boolean;
var
size, len: longword;
handle: THandle;
buffer: pchar;
pinfo: ^VS_FIXEDFILEINFO;
begin
Result := False;
size := GetFileVersionInfoSize(Pointer(FileName), handle);
if size > 0 then begin
GetMem(buffer, size);
if GetFileVersionInfo(Pointer(FileName), 0, size, buffer)
then
if VerQueryValue(buffer, '\', pointer(pinfo), len) then begin
Major := HiWord(pinfo.dwFileVersionMS);
Minor := LoWord(pinfo.dwFileVersionMS);
Release := HiWord(pinfo.dwFileVersionLS);
Build := LoWord(pinfo.dwFileVersionLS);
Result := True;
end;
FreeMem(buffer);
end;
end;
procedure TformMenuPrincipal.bSeleccionarClick(Sender: TObject);
begin
dlAbrir.Title := 'Seleccione el fichero...';
dlAbrir.Filter := 'Aplicación (*.exe)|*.exe|Librería (*.dll)|*.dll|Com (*.com)|*.com|Todos los archivos (*.*)|*.*';
if dlAbrir.Execute then
begin
txtFichero.Text := dlAbrir.FileName;
bInformacionFicheroClick(nil);
end;
end;
function obtenerInfoFichero (info : string; fichero : string) : string;
type
PaLeerBuffer = array [0..MAX_PATH] of char;
var
Size, Size2 : DWord;
Pt, Pt2 : Pointer;
Idioma : string;
begin
Result := '';
Size := GetFileVersionInfoSize(PChar (fichero), Size2);
if Size > 0 then
begin
GetMem (Pt, Size);
if GetFileVersionInfo (PChar (fichero), 0, Size, Pt) then
begin
VerQueryValue( Pt, '\VarFileInfo\Translation',Pt2, Size2);
Idioma:=IntToHex( DWord(Pt2^) ,8 );
Idioma:=Copy(Idioma,5,4)+Copy(Idioma,1,4);
VerQueryValue( Pt,Pchar('\StringFileInfo\'+Idioma+'\'+info),Pt2, Size2);
if Size2 > 0 then
begin
Result:=Copy(PaLeerBuffer(Pt2^),1,Size2);
end
else
result := '';
FreeMem (Pt);
end;
end
else
result := '';
end;
function tamanoFichero (sFileToExamine: string) : Integer;
var
SearchRec: TSearchRec;
sgPath: string;
inRetval, I1: Integer;
begin
sgPath := ExpandFileName(sFileToExamine);
try
inRetval := FindFirst(ExpandFileName(sFileToExamine), faAnyFile, SearchRec);
if inRetval = 0 then
I1 := SearchRec.Size
else
I1 := -1;
finally
SysUtils.FindClose(SearchRec);
end;
Result := I1;
end;
function quitarExtension (nombreFichero : string) : string;
begin
result := copy(ExtractFileName(nombreFichero), 1,
pos(ExtractFileExt(nombreFichero), ExtractFileName(nombreFichero)) - 1);
end;
function obtenerFechasFichero (const FileName: string; var Created: TDateTime;
var Accessed: TDateTime; var Modified: TDateTime): Boolean;
var
h: THandle;
Info1, Info2, Info3: TFileTime;
SysTimeStruct: SYSTEMTIME;
TimeZoneInfo: TTimeZoneInformation;
Bias: Double;
begin
Result := False;
Bias := 0;
h := FileOpen(FileName, fmOpenRead or fmShareDenyNone);
if h > 0 then
begin
try
if GetTimeZoneInformation(TimeZoneInfo) <> $FFFFFFFF then
Bias := TimeZoneInfo.Bias / 1440; // 60x24
GetFileTime(h, @Info1, @Info2, @Info3);
if FileTimeToSystemTime(Info1, SysTimeStruct) then
Created := SystemTimeToDateTime(SysTimeStruct) - Bias;
if FileTimeToSystemTime(Info2, SysTimeStruct) then
Accessed := SystemTimeToDateTime(SysTimeStruct) - Bias;
if FileTimeToSystemTime(Info3, SysTimeStruct) then
Modified := SystemTimeToDateTime(SysTimeStruct) - Bias;
Result := True;
finally
FileClose(h);
end;
end;
end;
procedure TformMenuPrincipal.bInformacionFicheroClick(Sender: TObject);
var
major, minor, release, build : word;
version : string;
sizeFichero : Longint;
fechaCreacion, ultimoAcceso, ultimaModificacion : TDateTime;
begin
if versionFichero(txtFichero.Text,major,minor,release, build) then
version := Format('Versión: %d.%d.%d.%d', [Major, Minor, Release, Build])
else
version := 'Versión no disponible';
lInfo.Clear;
lInfo.Lines.Add('Nombre: ' + ExtractFileName(txtFichero.Text));
lInfo.Lines.Add('Extensión: ' + ExtractFileExt(txtFichero.Text));
lInfo.Lines.Add('Ubicación: ' + ExtractFilePath(txtFichero.Text));
lInfo.Lines.Add('Nombre sin extensión: ' + quitarExtension (extractfilename(txtFichero.text)));
lInfo.Lines.Add(version);
lInfo.Lines.Add('Compañía: ' + obtenerInfoFichero ('CompanyName', txtFichero.Text));
lInfo.Lines.Add('Descripción: ' + obtenerInfoFichero ('FileDescription', txtFichero.Text));
lInfo.Lines.Add('Nombre interno: ' + obtenerInfoFichero ('InternalName', txtFichero.Text));
lInfo.Lines.Add('Derechos de copia: ' + obtenerInfoFichero ('LegalCopyright', txtFichero.Text));
lInfo.Lines.Add('Nombre original: ' + obtenerInfoFichero ('OriginalFilename', txtFichero.Text));
lInfo.Lines.Add('Nombre producto: ' + obtenerInfoFichero ('ProductName', txtFichero.Text));
lInfo.Lines.Add('Versión producto: ' + obtenerInfoFichero ('ProductVersion', txtFichero.Text));
lInfo.Lines.Add('Versión fichero: ' + obtenerInfoFichero ('FileVersion', txtFichero.Text));
lInfo.Lines.Add('Comentarios: ' + obtenerInfoFichero ('Comments', txtFichero.Text));
sizeFichero := tamanoFichero(txtFichero.Text);
if sizeFichero = 0 then
lInfo.Lines.Add('Tamaño (Bytes): Para obtener el tamaño el fichero debe estar cerrado.')
else
lInfo.Lines.Add('Tamaño (Bytes): ' + IntToStr(tamanoFichero(txtFichero.Text)));
//fechas
if obtenerFechasFichero (txtFichero.Text, fechaCreacion, ultimoAcceso, ultimaModificacion) then
begin
lInfo.Lines.Add('Fecha creación: ' + DateToStr (fechaCreacion));
lInfo.Lines.Add('Fecha último acceso: ' + DateToStr(ultimoAcceso));
lInfo.Lines.Add('Fecha modificación: ' + DateToStr(ultimaModificacion));
end;
end;
function GetFileTimes(const FileName: string; var Created: TDateTime;
var Accessed: TDateTime; var Modified: TDateTime): Boolean;
var
h: THandle;
Info1, Info2, Info3: TFileTime;
SysTimeStruct: SYSTEMTIME;
TimeZoneInfo: TTimeZoneInformation;
Bias: Double;
begin
Result := False;
Bias := 0;
h := FileOpen(FileName, fmOpenRead or fmShareDenyNone);
if h > 0 then
begin
try
if GetTimeZoneInformation(TimeZoneInfo) <> $FFFFFFFF then
Bias := TimeZoneInfo.Bias / 1440; // 60x24
GetFileTime(h, @Info1, @Info2, @Info3);
if FileTimeToSystemTime(Info1, SysTimeStruct) then
Created := SystemTimeToDateTime(SysTimeStruct) - Bias;
if FileTimeToSystemTime(Info2, SysTimeStruct) then
Accessed := SystemTimeToDateTime(SysTimeStruct) - Bias;
if FileTimeToSystemTime(Info3, SysTimeStruct) then
Modified := SystemTimeToDateTime(SysTimeStruct) - Bias;
Result := True;
finally
FileClose(h);
end;
end;
end;
procedure TformMenuPrincipal.FormCreate(Sender: TObject);
begin
//permitimos arrastrar y soltar
DragAcceptFiles(Handle, True);
if ParamCount > 0 then
begin
if ParamStr(1) <> '' then
begin
if FileExists(ParamStr(1)) then
begin
txtFichero.Text := ParamStr(1);
bInformacionFicheroClick(nil);
end;
end;
end
else
txtFichero.Text := Application.ExeName;
end;
procedure TformMenuPrincipal.Button1Click(Sender: TObject);
begin
close;
end;
procedure TformMenuPrincipal.bGuardarClick(Sender: TObject);
begin
dlGuardar.Title := 'Guardar información de fichero...';
dlGuardar.FileName := ChangeFileExt(ExtractFileName(txtFichero.Text), '.txt');
if dlGuardar.Execute then
lInfo.Lines.SaveToFile (dlGuardar.FileName);
end;
procedure TformMenuPrincipal.LWEBClick(Sender: TObject);
begin
ShellExecute(Handle, Nil, PChar(LWEB.CAPTION),
Nil, Nil, SW_SHOWNORMAL);
end;
end.
Si es usuario registrado puede descargar/download el código fuente del truco pulsando aquí.
Publicado el: 2005-03-25