uhexview.pas

来自「在delphi中实现windows核心编程.原书光盘代码核心编程.原书光盘代码」· PAS 代码 · 共 435 行

unit UHexView;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, Grids;

type
  TfrmHexView = class(TForm)
    HexScrollBar: TScrollBar;
    HexGrid: TStringGrid;
    GroupBox1: TGroupBox;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    procedure HexGridMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure HexGridMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure HexScrollBarScroll(Sender: TObject; ScrollCode: TScrollCode;
      var ScrollPos: Integer);
    procedure FormResize(Sender: TObject);
    procedure HexGridDrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure HexGridSelectCell(Sender: TObject; ACol, ARow: Integer;
      var CanSelect: Boolean);
    procedure HexGridKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure BitBtn2Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);

  private
    { Private declarations }
    FDownCoord: TGridCoord;
    FMouseDown: Boolean;
    FHexPosition: Int64;
    FFileSize: Int64;
    FCurrPosition: Int64;
    FBufferStart: Int64;
    FPositionVisible: Boolean;
    FBuffer: array of Char;
    FFileName: string;
    procedure SetHexPosition(const Value: Int64);
    procedure SetFileName(const Value: string);
    procedure SetCurrPosition(const Value: Int64);

    property HexPosition: Int64 read FHexPosition write SetHexPosition;
    property FileName: string read FFileName write SetFileName;
    property CurrPosition: Int64 read FCurrPosition write SetCurrPosition;

    procedure RepositionSelection(Coord: TGridCoord);
    procedure FillBuffer(Position: Int64);
    procedure LoadFileIntoHexViewer;
    procedure ClearGrid;
    procedure DrawHexText(ACol, ARow: Integer; Rect: TRect);
  public
    { Public declarations }
    procedure MouseWheelHandler(var Message: TMessage); override;
  end;

var
  frmHexView: TfrmHexView;

implementation

uses UMain;

{$R *.DFM}

procedure TfrmHexView.DrawHexText(ACol, ARow: Integer; Rect: TRect);
begin
  {在最后一列画Ascii字符}
  with HexGrid.Canvas do begin
    Font.Color := clBlack;
    {在规定的四边形中显示字符用红色}
    TextRect(Rect, Rect.Left + 5, Rect.Top + 2, HexGrid.Cells[ACol, Arow]);
   {以相反的颜色画选中的字符}
    if (HexGrid.Selection.Left > 0) and (HexGrid.Selection.Left <=
      Length(HexGrid.Cells[ACol, ARow])) and (HexGrid.Selection.Top = ARow) and FPositionVisible then
    begin
      Brush.Color := clRed;
      Font.Color := clWhite;
      Rect.Left := Rect.Left + 5 + (HexGrid.Selection.Left - 1) * TextWidth('A');
      Rect.Right := Rect.Left + TextWidth('A');
      Rect.Top := Rect.Top + 2;
      TextRect(Rect, Rect.Left, Rect.Top, HexGrid.Cells[ACol, ARow][HexGrid.Selection.Left]);
    end;
  end;
end;

procedure TfrmHexView.SetFileName(const Value: string);
begin
  if AnsiCompareText(FFileName, Value) <> 0 then
    FFileName := Value;
  if (FFileName <> '') then
    LoadFileIntoHexViewer; {把文件以16进制读入StringGrid中}
end;

procedure TfrmHexView.SetCurrPosition(const Value: Int64);
var
  ARect: TGridRect;
  ACoord: TGridCoord;
begin
  {设置当前16进制的位置}
  FCurrPosition := Value;
  {位置是否可见？}
  FPositionVisible := (FCurrPosition >= FHexPosition) and
    (FCurrPosition < FHexPosition + HexGrid.RowCount * 16);
  {如果位置可见则在Cell选中}
  if FPositionVisible then begin
    ACoord.X := (FCurrPosition - FHexPosition) mod 16 + 1;
    ACoord.Y := (FCurrPosition - FHexPosition) div 16;
    ARect.TopLeft := ACoord;
    ARect.BottomRight := ACoord;
    HexGrid.Selection := ARect;
  end;
end;

procedure TfrmHexView.ClearGrid;
var
  i, j: Integer;
begin
  {清Cell中值}
  with HexGrid do
    for i := 0 to RowCount - 1 do
      for j := 0 to 17 do
        Cells[j, i] := '' {16列，其中第一列}
end;

procedure TfrmHexView.RepositionSelection(Coord: TGridCoord);
begin
  {重新配置选中位置}
  CurrPosition := HexPosition + Coord.Y * 16 + Coord.X - 1;
  HexGrid.Repaint;
  {设置滚动条的位置}
  HexScrollBar.Position := HexPosition div 16;
end;

procedure TfrmHexView.LoadFileIntoHexViewer;
begin
  {调整大小大小}
  FormResize(Self);
  {重设数据}
  FFileSize := 0;
  HexScrollBar.Position := 0;
  HexScrollBar.Enabled := False;
  ClearGrid;
  if (FileName = '') or DirectoryExists(FileName) then
    exit;
  try
   {头64k载入缓冲区}
    FillBuffer(0);
    if FFileSize div 16 > HexGrid.RowCount then
    begin
      {设置滚动条}
      HexScrollBar.Max := FFileSize div 16 - HexGrid.RowCount;
      if FFileSize mod 16 <> 0 then
        HexScrollBar.Max := HexScrollBar.Max + 1;
      HexScrollBar.Enabled := True;
    end;
    HexPosition := 0;
    {设置选中的位置为开始点}
    CurrPosition := 0;
    HexScrollBar.Position := 0;
  except
    on EFOpenError do
      ;
  end;
end;

procedure TfrmHexView.MouseWheelHandler(var Message: TMessage);
var
  ControlOver: TControl;
  MousePos: TPoint;
  WScrollCode: Word;
  ScrollPos: Integer;
begin
  {鼠标经过哪里？}
  MousePos.X := Message.LParamLo;
  MousePos.Y := Message.LParamHi;
  ControlOver := FindVCLWindow(MousePos);
  if Assigned(ControlOver) then begin
    with TWMMouseWheel(Message) do begin
      ScrollPos := Trunc(Abs(WheelDelta / 120));
      if WheelDelta < 0 then
        WScrollCode := SB_LINEDOWN
      else
        WScrollCode := SB_LINEUP;
      {转换wheel messages 为滚动消息}
      if (ControlOver <> HexGrid) then
        ControlOver.Perform(WM_VSCROLL, MakeLong(WScrollCode, ScrollPos), 0)
      else
        if WheelDelta < 0 then
          HexScrollBarScroll(Self, scLineDown, ScrollPos)
        else
          HexScrollBarScroll(Self, scLineUp, ScrollPos);
      Result := 1;
    end;
  end
  else
    inherited MouseWheelHandler(Message);
end;


procedure TfrmHexView.FillBuffer(Position: Int64);
var
  FileStream: TFileStream;
begin
  {读64k到Grid缓冲区中}
  FileStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
  try
    if FFileSize = 0 then
      FFileSize := FileStream.Size;
    SetLength(FBuffer, 64000);
    FillChar(FBuffer[0], 64000, #0);
    if Position < 0 then
      Position := 0;
    FileStream.Position := Position;
    FileStream.Read(FBuffer[0], 64000);
    FBufferStart := Position;
  finally
    FileStream.Free;
  end;
end;

procedure TfrmHexView.SetHexPosition(const Value: Int64);
var
  ByteNum: Integer;
  i, j: Integer;
  CellText: string;
begin
  FHexPosition := Value;
  if FFileSize = 0 then
    exit;
  with HexGrid do begin
    if (FHexPosition < FBufferStart) or (FHexPosition + RowCount * 16 > FBufferStart + 64000) then
      FillBuffer(FHexPosition - 32000);
    ByteNum := FHexPosition - FBufferStart;
    {以当前的数据填充Grid}
    for i := 0 to RowCount - 1 do begin
      Cells[0, i] := IntToHex(FHexPosition + i * 16, 8);
      CellText := '';
      for j := 1 to 16 do begin
        if FBufferStart + ByteNum < FFileSize then begin
          Cells[j, i] := IntToHex(Ord(FBuffer[ByteNum]), 2);
          CellText := CellText + FBuffer[ByteNum];
        end
        else
          Cells[j, i] := '';
        Inc(ByteNum);
      end;
      Cells[17, i] := CellText;
    end;
  end;
end;

procedure TfrmHexView.HexGridMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  CurrRect: TRect;
begin
  {处理鼠标按下消息，避免改变选中的位置}
  if Sender = HexGrid then
    with TStringGrid(Sender) do begin
      FMouseDown := True;
      FDownCoord := MouseCoord(X, Y);
      if FDownCoord.X = 17 then begin
        CurrRect := CellRect(FDownCoord.X, FDownCoord.Y);
        FDownCoord.X := (X - CurrRect.Left - 5) div Canvas.TextWidth('0') + 1;
      end;
      if FDownCoord.X > 0 then
        RepositionSelection(FDownCoord);
    end;
end;

procedure TfrmHexView.HexGridMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  UpCoord: TGridCoord;
  CurrRect: TRect;
begin
  FMouseDown := False;
  if Sender = HexGrid then
    with TStringGrid(Sender) do begin
      UpCoord := MouseCoord(X, Y);
      if UpCoord.X = 17 then begin
        CurrRect := CellRect(UpCoord.X, UpCoord.Y);
        UpCoord.X := (X - CurrRect.Left - 5) div Canvas.TextWidth('0') + 1;
      end;
      if (UpCoord.X > 0) and ((UpCoord.X <> FDownCoord.X) or (UPCoord.Y <> FDownCoord.Y)) then
        RepositionSelection(UpCoord);
    end;


end;

procedure TfrmHexView.HexScrollBarScroll(Sender: TObject;
  ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
  {处理滚动消息}
  case ScrollCode of
    scLineUp: if HexPosition >= 16 then
        HexPosition := HexPosition - 16;
    scLineDown: if (HexPosition + HexGrid.VisibleRowCount * 16 < FFileSize) then
        HexPosition := HexPosition + 16;
    scPageUp: if HexPosition > HexGrid.VisibleRowCount * 16 then
        HexPosition := HexPosition - HexGrid.VisibleRowCount * 16
      else
        HexPosition := 0;
    scPageDown: if (HexPosition + (HexGrid.VisibleRowCount + 1) * 32 < FFileSize) then
        HexPosition := HexPosition + HexGrid.VisibleRowCount * 16;
    scTrack,
      scPosition: if ((ScrollPos + HexGrid.VisibleRowCount) * 16 < FFileSize) then
        HexPosition := ScrollPos * 16
      else
        HexPosition := ((FFileSize - HexGrid.VisibleRowCount * 16) div 16 + 1) * 16;
  end;
  CurrPosition := FCurrPosition;
  ScrollPos := HexPosition div 16;
  HexGrid.SetFocus;
end;

procedure TfrmHexView.FormResize(Sender: TObject);
var
  RowCount: Integer;
  MaxScroll: Integer;
begin
  {获取新一行}
  RowCount := HexGrid.Parent.ClientHeight div HexGrid.RowHeights[0];
  if RowCount = 0 then
    RowCount := 1;
  HexGrid.RowCount := RowCount;
  {设置滚动条的最大值}
  if FFileSize > 0 then begin
    MaxScroll := FFileSize div 16 - HexGrid.RowCount;
    if FFileSize mod 16 > 0 then
      Inc(MaxScroll);
    if MaxScroll <= 0 then
      HexScrollBar.Enabled := False
    else
      HexScrollBar.Max := MaxScroll;
  end;
  SetHexPosition(FHexPosition);
end;

procedure TfrmHexView.HexGridDrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
begin
  {当Cell重画时调用此函数}
  if ACol = 17 then
    DrawHexText(ACol, ARow, Rect)
  else if (gdSelected in State) then begin
    {如果位置为可见区，则画选中的的字符}
    if FPositionVisible then begin
      HexGrid.Canvas.Brush.Color := clHighlight;
      HexGrid.Canvas.Font.Color := clWhite;
    end;
    HexGrid.Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top + 2, HexGrid.Cells[ACol, Arow]);
  end;
end;

procedure TfrmHexView.HexGridSelectCell(Sender: TObject; ACol,
  ARow: Integer; var CanSelect: Boolean);
begin
  CanSelect := (ACol <> 17) and (not FMouseDown) and (FFileSize > 0) and FPositionVisible;
  if CanSelect then
    CanSelect := (HexPosition + ARow * 16 + ACol <= FFileSize);
end;

procedure TfrmHexView.HexGridKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);

var
  OldPosition: Int64;
begin
  {处理按键}
  OldPosition := CurrPosition;
  case Key of
    VK_Up: if CurrPosition >= 16 then
        CurrPosition := CurrPosition - 16;
    VK_Prior: if CurrPosition > HexGrid.VisibleRowCount * 16 then
        CurrPosition := CurrPosition - HexGrid.VisibleRowCount * 16
      else
        CurrPosition := 0;
    VK_Down: if (CurrPosition + 16 < FFileSize) then
        CurrPosition := CurrPosition + 16;
    VK_Next: if (CurrPosition + HexGrid.VisibleRowCount * 16 < FFileSize) then
        CurrPosition := CurrPosition + HexGrid.VisibleRowCount * 16;
    VK_Home: if Shift = [ssCtrl] then
        CurrPosition := 0
      else
        CurrPosition := CurrPosition div 16 * 16;
    VK_End: if Shift = [ssCtrl] then
        CurrPosition := FFileSize - 1
      else
        CurrPosition := ((CurrPosition div 16) + 1) * 16 - 1;
    VK_Left: if CurrPosition > 0 then
        CurrPosition := CurrPosition - 1;
    VK_Right: if CurrPosition < FFileSize - 1 then
        CurrPosition := CurrPosition + 1;
  end;
  Key := 0;
  if OldPosition <> CurrPosition then begin
    {如果非可见的，则设当前的位置为视图区}
    if not FPositionVisible then
      if OldPosition > CurrPosition then
        HexPosition := CurrPosition div 16 * 16
      else
        HexPosition := ((CurrPosition div 16) + 1) * 16 - HexGrid.RowCount * 16;
    CurrPosition := FCurrPosition;
    HexGrid.Repaint;
  end;
  {设置新的Grid初始位置}
  HexScrollBar.Position := HexPosition div 16;
end;

procedure TfrmHexView.BitBtn2Click(Sender: TObject);
begin
  Close;
end;

procedure TfrmHexView.BitBtn1Click(Sender: TObject);
begin
  Close;
end;

procedure TfrmHexView.FormShow(Sender: TObject);
begin
  SetFileName(frmMain.filename);
end;

end.