elmago00,
Cita:
Empezado por elmago00
...solo detallen las propiedades que tiene este código pero en FireMonkey...
|
Revisa este código:
Código Delphi
[-]
unit Unit1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Rtti, System.Classes,
System.Variants, System.UIConsts, FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs,
FMX.StdCtrls, FMX.ListBox, FMX.Layouts, FMX.Grid;
type
TColumnAccess = class(TColumn)
end;
TForm1 = class(TForm)
StringGrid1: TStringGrid;
ComboBox1: TComboBox;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
procedure DumpFile(aFileName:TFileName; SG: TStringGrid; const BPF: Word);
var
c, i, r: Integer;
Ascii: String;
Aux: Byte;
Col, Row: Integer;
CellCtrl: TStyledControl;
begin
with TMemoryStream.Create do
try
LoadFromFile(aFileName);
SG.ShowHeader := False;
SG.ShowHorzLines := False;
SG.ShowVertLines := False;
for i := 1 to BPF + 2 do
SG.AddObject(TStringColumn.Create(nil));
SG.RowCount:= Size div BPF;
for Row := 0 to SG.RowCount - 1 do
begin
for Col := 0 to SG.ColumnCount - 1 do
begin
Application.ProcessMessages;
CellCtrl := TColumnAccess(SG.Columns[Col]).CellControlByRow(Row);
if ( CellCtrl <> nil ) and (CellCtrl is TTextCell) then
begin
TTextCell(CellCtrl).StyledSettings := [];
TTextCell(CellCtrl).Font.Family := 'Courrier New';
TTextCell(CellCtrl).Font.Size := 10;
TTextCell(CellCtrl).FontColor := claBlack;
TTextCell(CellCtrl).Font.Style := [];
TTextCell(CellCtrl).TextAlign := TTextAlign.taCenter;
if (Col = 0) then
SG.Columns[Col].Width := 80;
if (Col <> SG.ColumnCount - 1) and (Col <> 0) then
SG.Columns[Col].Width := 30;
if (Col = SG.ColumnCount - 1) then
SG.Columns[Col].Width := SG.Canvas.TextWidth('X') * BPF;
end;
end;
end;
SG.Cells[0,0]:= 'Offset(h)';
SG.Cells[SG.ColumnCount-1,0]:= 'ASCII';
for i:= 0 to BPF-1 do
begin
SG.Cells[i+1,0]:= IntToHex(i,2);
end;
Seek(0, soBeginning);
c:= 0;
r:= 1;
while c < Size do
begin
SG.Cells[0, r]:= Format('%s',[IntToHex(c, 8)]);
Ascii:= EmptyStr;
i:= 0;
while (i < BPF)and(i+c < Size) do
begin
Read(Aux, SizeOf(Byte));
SG.Cells[i+1,r]:= IntToHex(Aux,2);
if Aux = 0 then Aux := 46;
Ascii:= Ascii + Chr(Aux);
Inc(i);
end;
SG.Cells[SG.ColumnCount-1,r]:= Format('%s',[Ascii]);
Inc(c, BPF);
Inc(r);
end;
finally
Free;
end;
end;
procedure SaveDump(aFileName:TFileName; SG: TStringGrid);
var
c,r: Integer;
s: String;
begin
with TStringList.Create do
try
for r:= 0 to SG.RowCount-1 do
begin
s:= '';
for c:= 0 to SG.ColumnCount-1 do s:= s + SG.Cells[c,r] + ' ';
SetLength(s,Length(s)-1);
Add(s);
end;
SaveToFile(aFileName);
finally
Free;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ComboBox1.Items.CommaText:= '8,10,16,24,32,48,64,128,255';
ComboBox1.ItemIndex:= 2;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
with OpenDialog1 do
begin
Filter:= '*.*';
if Execute then
begin
Caption:= FileName;
DumpFile(FileName, StringGrid1,
StrToInt(ComboBox1.Items[ComboBox1.ItemIndex]) );
end;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
with SaveDialog1 do
begin
Filter:= '*.txt';
DefaultExt:= '*.txt';
if Execute then
SaveDump(FileName, StringGrid1);
end;
end;
end.
El código anterior en Delphi XE4 bajo Windows 7 Professional x32,
es la implementación del código del Msg #1 en FireMonkey HD, como se muestra en la siguiente imagen:
Espero sea útil
Nelson.