4 respuestas en este tema

[monchito_elroro]

Buen día hermanos , en este ocación quisiera compartirles un aporte mío, bueno más que todo es un proyecto que me baje de la web, exactamente de:
http://www.ajpdsoft....article&sid=121
 
Es un software para poder obtener casi todos las propiedades de un archivo (especialmente los EXE), el proyecto original venía para delphi, así que me puse a tratar de pasarlo para lazarus, tuve mucho inconvenientes en la operación (especialmente en los carácteres especiales ñ y tildes) también tuve que cambiar algunas cosas, pero al final después de tanto batallar logré obtener un buen resultado, logré pasar el programa para usarlo en lazarus y les quiero compartir el código fuente para que me ayuden a perfeccionarlo y que nos pueda servir a todos nosotros, también quisiera que me ayuden a  arreglar unos pequeñisimos detalles, pero como les comente el programa ya esta listo para usar y soporta arrastrar archivos encima también.
 
sin más preambulos aquí esta todo el código fuente para lazarus:

delphi

unit Unit1;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Windows, Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, LazUTF8, LCLIntf;
 
type
 
  { TForm1 }
 
  TForm1 = class(TForm)
    Button2: TButton;
    Button5: TButton;
    Button6: TButton;
    Edit1: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Memo1: TMemo;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure FormDropFiles(Sender: TObject; const FileNames: array of String);
    procedure Label3Click(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.lfm}
 
{ TForm1 }
 
function quitarExtension (nombreFichero : string) : string;
begin
  result := copy(ExtractFileName(nombreFichero), 1,
      pos(ExtractFileExt(nombreFichero), ExtractFileName(nombreFichero)) - 1);
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 FileVersion(const FileName: TFileName): String;
var
  VerInfoSize: Cardinal;
  VerValueSize: Cardinal;
  Dummy: Cardinal;
  PVerInfo: Pointer;
  PVerValue: PVSFixedFileInfo;
  iLastError: DWord;
begin
 
  Result := '';
  VerInfoSize := GetFileVersionInfoSize(PChar(FileName), Dummy);
 
  if VerInfoSize > 0 then
  begin
 
    GetMem(PVerInfo, VerInfoSize);
    try
      if GetFileVersionInfo(PChar(FileName), 0, VerInfoSize, PVerInfo) then
      begin
        if VerQueryValue(PVerInfo, '\', Pointer(PVerValue), VerValueSize) then
          with PVerValue^ do
            //Result := Format('v%d.%d.%d build %d', [    // original, devuelve ejem:     v8.7.0.0 build 0
            Result := Format('%d.%d.%d', [    // modificado para mi uso, Ericksystem, devuelve ejm:      8.7
              HiWord(dwFileVersionMS), //Major
              LoWord(dwFileVersionMS), //Minor
              HiWord(dwFileVersionLS), //Release
              LoWord(dwFileVersionLS)]); //Build
      end
      else
      begin
        iLastError := GetLastError;
        Result := Format('GetFileVersionInfo failed: (%d) %s',
                      [iLastError, SysErrorMessage(iLastError)]);
      end;
    finally
      FreeMem(PVerInfo, VerInfoSize);
    end;
  end
  else
  begin
 
    iLastError := GetLastError;
    Result := Format('GetFileVersionInfo failed: (%d) %s',
                     [iLastError, SysErrorMessage(iLastError)]);
  end;
End;
 
function obtenerAtributos (fichero : string) : DWORD;
begin
  result := GetFileAttributes(pchar(fichero));
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 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 TForm1.Button1Click(Sender: TObject);
begin
 
end;
 
procedure TForm1.Button2Click(Sender: TObject);
begin
  SaveDialog1.Title := 'Guardar información de fichero...';
  SaveDialog1.FileName := ChangeFileExt(ExtractFileName('e:\virtualprinter.exe'), '.txt');
  if SaveDialog1.Execute then
    memo1.Lines.SaveToFile (SaveDialog1.FileName);
end;
 
procedure TForm1.Button3Click(Sender: TObject);
begin
 
end;
 
procedure TForm1.Button4Click(Sender: TObject);
begin
 
end;
 
procedure TForm1.Button5Click(Sender: TObject);
begin
  OpenDialog1.Title := 'Seleccione el fichero...';
  OpenDialog1.Filter := 'Aplicación (*.exe)|*.exe|Librería (*.dll)|*.dll|Com (*.com)|*.com|Todos los archivos (*.*)|*.*';
  if OpenDialog1.Execute then
  begin
    edit1.Text := OpenDialog1.FileName;
    Button6Click(nil);
  end;
end;
 
procedure TForm1.Button6Click(Sender: TObject);
var
  sizeFichero : Longint;
  fechaCreacion, ultimoAcceso, ultimaModificacion : TDateTime;
  atributos : word;
begin
  if FileExists(edit1.Text) then
  begin
    //tabInfo.Show;
    {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';}
    Memo1.Clear;
    Memo1.Lines.Add('Nombre: ' + ExtractFileName(edit1.Text));
    Memo1.Lines.Add('Extensión: ' + ExtractFileExt(edit1.Text));
    Memo1.Lines.Add('Ubicación (carpeta): ' + ExtractFilePath(edit1.Text));
    Memo1.Lines.Add('Nombre sin extensión: ' + quitarExtension (extractfilename(edit1.text)));
    Memo1.Lines.Add('Unidad: ' + ExtractFileDrive(edit1.text));
    //Memo1.Lines.Add(version);
    Memo1.Lines.Add('Version: '+FileVersion(UTF8ToWinCP(edit1.text)));
    Memo1.Lines.Add('Compañía: ' + obtenerInfoFichero ('CompanyName', UTF8ToWinCP(edit1.Text)));
    Memo1.Lines.Add('Descripción: ' + obtenerInfoFichero ('FileDescription', UTF8ToWinCP(edit1.Text)));
    Memo1.Lines.Add('Nombre interno: ' + obtenerInfoFichero ('InternalName', UTF8ToWinCP(edit1.Text)));
    Memo1.Lines.Add('Derechos de copia: ' + obtenerInfoFichero ('LegalCopyright', UTF8ToWinCP(edit1.Text)));
    Memo1.Lines.Add('Nombre original: ' + obtenerInfoFichero ('OriginalFilename', UTF8ToWinCP(edit1.Text)));
    Memo1.Lines.Add('Nombre producto: ' + obtenerInfoFichero ('ProductName', UTF8ToWinCP(edit1.Text)));
    Memo1.Lines.Add('Versión producto: ' + obtenerInfoFichero ('ProductVersion', UTF8ToWinCP(edit1.Text)));
    Memo1.Lines.Add('Versión fichero: ' + obtenerInfoFichero ('FileVersion', UTF8ToWinCP(edit1.Text)));
    Memo1.Lines.Add('Comentarios: ' + obtenerInfoFichero ('Comments', UTF8ToWinCP(edit1.Text)));
    sizeFichero := tamanoFichero(edit1.Text);
    if sizeFichero = 0 then
      Memo1.Lines.Add('Tamaño (Bytes): Para obtener el tamaño el fichero debe estar cerrado.')
    else
      Memo1.Lines.Add('Tamaño (Bytes): ' + IntToStr(tamanoFichero(edit1.Text)));
 
    //fechas
    if obtenerFechasFichero (edit1.Text, fechaCreacion, ultimoAcceso, ultimaModificacion) then
    begin
      Memo1.Lines.Add('Fecha creación: ' + DateToStr (fechaCreacion));
      Memo1.Lines.Add('Fecha último acceso: ' + DateToStr(ultimoAcceso));
      Memo1.Lines.Add('Fecha modificación: ' + DateToStr(ultimaModificacion));
    end;
 
    //atributos
    atributos := obtenerAtributos (PChar(edit1.Text));
    if (atributos and FILE_ATTRIBUTE_ARCHIVE) > 0 then
      Memo1.lines.Add('Atributo listo para archivar: Sí')
    else
      Memo1.lines.Add('Atributo listo para archivar: No');
 
    if (atributos and FILE_ATTRIBUTE_DIRECTORY > 0) then
      Memo1.lines.Add('Atributo directorio: Sí')
    else
      Memo1.lines.Add('Atributo directorio: No');
 
    if (atributos and FILE_ATTRIBUTE_HIDDEN > 0) then
      Memo1.lines.Add('Atributo oculto: Sí')
    else
      Memo1.lines.Add('Atributo oculto: No');
 
    if (atributos and FILE_ATTRIBUTE_OFFLINE > 0)  then
      Memo1.lines.Add('Atributo fuera de línea: Sí')
    else
      Memo1.lines.Add('Atributo fuera de línea: No');
 
    if (atributos and FILE_ATTRIBUTE_TEMPORARY > 0)  then
      Memo1.lines.Add('Atributo temporal: Sí')
    else
      Memo1.lines.Add('Atributo temporal: No');
 
    if (atributos and FILE_ATTRIBUTE_READONLY > 0)  then
      Memo1.lines.Add('Atributo sólo lectura: Sí')
    else
      Memo1.lines.Add('Atributo sólo lectura: No');
 
    if (atributos and FILE_ATTRIBUTE_SYSTEM > 0)  then
      Memo1.lines.Add('Atributo sistema: Sí')
    else
      Memo1.lines.Add('Atributo sistema: No');
 
    if (atributos and FILE_ATTRIBUTE_NORMAL > 0)  then
      Memo1.lines.Add('Atributo normal: Sí')
    else
      Memo1.lines.Add('Atributo normal: No');
 
    if (atributos and FILE_ATTRIBUTE_COMPRESSED) > 0 then
      Memo1.lines.Add('Atributo comprimido: Sí')
    else
      Memo1.lines.Add('Atributo comprimido: No');
 
    if (atributos and $00004000) > 0 then
      Memo1.lines.Add('Atributo encriptado: Sí')
    else
      Memo1.lines.Add('Atributo encriptado: No');
 
    if (atributos and $00002000) > 0 then
      Memo1.lines.Add('Atributo permitir indexar: No')
    else
      Memo1.lines.Add('Atributo permitir indexar: Sí');
 
    Button2.SetFocus;
  end
  else
    MessageDlg('El fichero seleccionado no existe.', mtWarning, [mbok], 0);
end;
 
procedure TForm1.FormDropFiles(Sender: TObject; const FileNames: array of String
  );
var
  i: Integer;
begin
    for i := Low(FileNames) to High(FileNames) do
    Edit1.Text := FileNames[i];
    Button6Click(nil);
end;
 
procedure TForm1.Label3Click(Sender: TObject);
begin
  OpenURL('http://www.ajpdsoft.com/modules.php?name=News&file=article&sid=121');
end;
 
end.

También les comparto el proyecto traducido a lazarus y una imagen del software.
http://www.mediafire...rchivo 2.zip   (proyecto)
http://subefotos.com...834bed31beo.png
(Disculpen por subirlo a mediafire es que por este medio no me dejaba)
 
Sin más me despido queridos amigos esperando sus sugerencias y me puedan ayudar a perfeccionarlo, buen día.

[egostar]

(Disculpen por subirlo a mediafire es que por este medio no me dejaba)

 

 

Voy a revisar porque no te dejó,

 

Saludos

[monchito_elroro]

Gracias amigo egostar

[egostar]

Gracias amigo egostar

 

Que tal amigo, lo más probable es que se exceda el tamaño del limite de "upload" que es de 500 kB por subida,. no puedo ver los archivos ya que no tengo acceso aquí en mi trabajo.

 

Saludos

[monchito_elroro]

Buscando más opciones encontre uno bueno que puede funcionar multicross, es decir para Win, Linux y Mac aunque aún no lo confirmo de momento me funciona perfecto en windows.

 

También recalcar que al parecer solo funciona para los archivos:

.exe/.dll/.ocx

 

aquí esta el code:

Obtener información de un achivo.

php

Uses
  fileinfo,
  winpeimagereader,
  elfreader,
  Machoreader;   
 
procedure TForm1.Button2Click(Sender: TObject);
var info:TFileVersionInfo;
begin
  memo1.clear;
  info := TFileVersionInfo.Create(nil);
  info.fileName:='E:\ñoñito acción\iTunes64Setup.exe';
  info.ReadFileInfo;
  //showmessage(info.VersionStrings.Text);  // muestra toda la info
  memo1.lines.add('CompanyName: '+info.VersionStrings.Values['CompanyName']);
  memo1.lines.add('FileDescription: '+info.VersionStrings.Values['FileDescription']);
  memo1.lines.add('FileVersion: '+info.VersionStrings.Values['FileVersion']);
  memo1.lines.add('InternalName: '+info.VersionStrings.Values['InternalName']);
  memo1.lines.add('LegalCopyright: '+info.VersionStrings.Values['LegalCopyright']);
  memo1.lines.add('OriginalFilename: '+info.VersionStrings.Values['OriginalFilename']);
  memo1.lines.add('ProductName: '+info.VersionStrings.Values['ProductName']);
  memo1.lines.add('ProductVersion: '+info.VersionStrings.Values['ProductVersion']);
  info.Free;
End;

La fuente de donde me guíe es este:

http://wiki.freepasc...on,_and_Company

 

Lo Genial de este código es que me reconoce automáticamente las "ñ" las tildes y los caracteres assci, como en el ejemplo el logo © que lleva el itunes en "LegalCopyright" espero les pueda ser útil hermanos, saludos con todos