hexdump.pas

RxRich很有用的文字图像显示控件,这是它的Demo

{*******************************************************}
{                                                       }
{     Delphi Visual Component Library                   }
{                                                       }
{     Copyright (c) 1996,97 Borland International       }
{     Portions copyright (c) 1997 Master-Bank           }
{                                                       }
{*******************************************************}

unit HexDump;

interface

uses
  SysUtils, {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Menus;

const
  MAXDIGITS = 16;

{ THexDump }

type
  THexStr = array[0..2] of Char;
  THexStrArray = array[0..MAXDIGITS-1] of THexStr;

  THexDump = class(TCustomControl)
  private
    FActive: Boolean;
    FAddress: Pointer;
    FDataSize: Longint;
    FTopLine: Longint;
    FCurrentLine: Longint;
    FVisibleLines: Integer;
    FLineCount: Longint;
    FBytesPerLine: Integer;
    FItemHeight: Integer;
    FItemWidth: Integer;
    FFileColors: array[0..2] of TColor;
    FShowLineMarker: Boolean;
    FShowCharacters: Boolean;
    FShowAddress: Boolean;
    FRelativeAddress: Boolean;
    FBorder: TBorderStyle;
    FHexData: THexStrArray;
    FLineChars: array[0..MAXDIGITS] of Char;
    FLineAddr: array[0..15] of Char;
    procedure CalcPaintParams;
    procedure SetTopLine(Value: Longint);
    procedure SetCurrentLine(Value: Longint);
    procedure SetFileColor(Index: Integer; Value: TColor);
    function GetFileColor(Index: Integer): TColor;
    procedure SetShowCharacters(Value: Boolean);
    procedure SetShowAddress(Value: Boolean);
    procedure SetShowLineMarker(Value: Boolean);
    procedure SetRelativeAddress(Value: Boolean);
    procedure SetBorder(Value: TBorderStyle);
    procedure SetAddress(Value: Pointer);
    procedure SetDataSize(Value: Longint);
    procedure AdjustScrollBars;
    procedure InvalidateLineMarker;
    procedure SetScroll(Value: Longint);
    function LineAddr(Index: Longint): PChar;
    function LineData(Index: Longint): PChar;
    function LineChars(Index: Longint; MaxLen: Integer): PChar;
    function ScrollIntoView: Boolean;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMEnter(var Message: TCMGotFocus); message CM_ENTER;
    procedure CMExit(var Message: TCMLostFocus); message CM_EXIT;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Paint; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property CurrentLine: Longint read FCurrentLine write SetCurrentLine;
    property LineCount: Longint read FLineCount;
    property Address: Pointer read FAddress write SetAddress;
    property DataSize: Longint read FDataSize write SetDataSize;
  published
    property Align;
    property Border: TBorderStyle read FBorder write SetBorder default bsSingle;
    property Color default clWindow;
    property Ctl3D default True;
    property Font;
    property ParentColor default False;
    property ParentCtl3D;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property ShowAddress: Boolean read FShowAddress write SetShowAddress default True;
    property ShowCharacters: Boolean read FShowCharacters write SetShowCharacters default True;
    property ShowLineMarker: Boolean read FShowLineMarker write SetShowLineMarker default True;
    property RelativeAddress: Boolean read FRelativeAddress write SetRelativeAddress default False;
    property AddressColor: TColor index 0 read GetFileColor write SetFileColor default clWindowText;
    property HexDataColor: TColor index 1 read GetFileColor write SetFileColor default clWindowText;
    property AnsiCharColor: TColor index 2 read GetFileColor write SetFileColor default clHighlight;
    property OnClick;
    property OnDblClick;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

function CreateHexDump(AOwner: TWinControl): THexDump;

implementation

uses VCLUtils;

{ Create THexDump control }

function CreateHexDump(AOwner: TWinControl): THexDump;
begin
  Result := THexDump.Create(AOwner);
  with Result do begin
    Parent := AOwner;
    Font.Name := 'Courier';
    Align := alClient;
  end;
end;

{$IFNDEF WIN32}
function LongMulDiv(Mult1, Mult2, Div1: Longint): Longint; assembler;
{ copied from GRIDS.PAS }
type
  Quadword = record
    w0, w1, w2, w3: Word;
  end;
var
  Temp: Quadword;
asm
{ Mul }
        MOV     DX,Mult1.Word[2]
        MOV     AX,Mult1.Word[0]
        MOV     CX,Mult2.Word[2]
        MOV     BX,Mult2.Word[0]
        MOV     DI,DX
        MOV     SI,AX
        MUL     BX
        MOV     Temp.w0,AX
        MOV     Temp.w1,DX
        MOV     AX,DI
        MUL     CX
        MOV     Temp.w2,AX
        MOV     Temp.w3,DX
        MOV     AX,DI
        MUL     BX
        ADD     Temp.w1,AX
        ADC     Temp.w2,DX
        ADC     Temp.w3,0
        MOV     AX,SI
        MUL     CX
        ADD     Temp.w1,AX
        ADC     Temp.w2,DX
        ADC     Temp.w3,0
        MOV     DX,Temp.w3
        MOV     SI,Temp.w2
        MOV     BX,Temp.w1
        MOV     AX,Temp.w0
{ rounding }
        MOV     CX,Div1.Word[2]
        MOV     DI,Div1.Word[0]
        SHR     CX,1
        RCR     DI,1
        ADD     AX,DI
        ADC     BX,CX
        ADC     SI,0
        ADC     DX,0
{ Div }
        MOV     CX,32
        CLC
@1:     RCL     AX,1
        RCL     BX,1
        RCL     SI,1
        RCL     DX,1
        JNC     @3
@2:     SUB     SI,Div1.Word[0]
        SBB     DX,Div1.Word[2]
        STC
        LOOP    @1
        JMP     @5
@3:     CMP     DX,Div1.Word[2]
        JC      @4
        JNE     @2
        CMP     SI,Div1.Word[0]
        JNC     @2
@4:     CLC
        LOOP    @1
@5:     RCL     AX,1
        RCL     BX,1
        MOV     CX,SI
        MOV     DX,BX
end;
{$ENDIF}

{ THexDump }

constructor THexDump.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csFramed, csOpaque, csCaptureMouse, csClickEvents,
    csDoubleClicks];
  Ctl3D := True;
  FBorder := bsSingle;
  FShowLineMarker := True;
  ParentColor := False;
  Color := clWindow;
  FFileColors[0] := clWindowText;
  FFileColors[1] := clWindowText;
  FFileColors[2] := clHighlight;
  FShowAddress := True;
  FShowCharacters := True;
  Width := 300;
  Height := 200;
  FillChar(FHexData, SizeOf(FHexData), #9);
  TabStop := True;
end;

destructor THexDump.Destroy;
begin
  inherited Destroy;
end;

procedure THexDump.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do begin
    if (FBorder = bsSingle) then
{$IFDEF WIN32}
      if NewStyleControls and Ctl3D then
        ExStyle := ExStyle or WS_EX_CLIENTEDGE
      else Style := Style or WS_BORDER;
{$ELSE}
      Style := Style or WS_BORDER;
{$ENDIF}
    Style := Style or WS_VSCROLL;
  end;
end;

{ VCL Command Messages }

procedure THexDump.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Canvas.Font := Self.Font;
  FItemHeight := Canvas.TextHeight('A') + 2;
  FItemWidth := Canvas.TextWidth('D') + 1;
  CalcPaintParams;
  AdjustScrollBars;
end;

procedure THexDump.CMCtl3DChanged(var Message: TMessage);
begin
{$IFDEF WIN32}
  if NewStyleControls and (FBorder = bsSingle) then RecreateWnd;
  inherited;
{$ELSE}
  inherited;
  Invalidate;
{$ENDIF}
end;

procedure THexDump.CMEnter;
begin
  inherited;
  InvalidateLineMarker;
end;

procedure THexDump.CMExit;
begin
  inherited;
  InvalidateLineMarker;
end;

{ Windows Messages }

procedure THexDump.WMSize(var Message: TWMSize);
begin
  inherited;
  CalcPaintParams;
  AdjustScrollBars;
end;

procedure THexDump.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  Message.Result := DLGC_WANTARROWS;
end;

procedure THexDump.WMVScroll(var Message: TWMVScroll);
var
  NewTopLine: Longint;
  LinesMoved: Longint;
  R: TRect;
begin
  inherited;
  if (DataSize = 0) or (Address = nil) then Exit;
  NewTopLine := FTopLine;
  case Message.ScrollCode of
    SB_LINEDOWN: Inc(NewTopLine);
    SB_LINEUP: Dec(NewTopLine);
    SB_PAGEDOWN: Inc(NewTopLine, FVisibleLines - 1);
    SB_PAGEUP: Dec(NewTopLine, FVisibleLines - 1);
    SB_TOP: NewTopLine := 0;
    SB_BOTTOM: NewTopLine := FLineCount - 1;
    SB_THUMBPOSITION, SB_THUMBTRACK:
{$IFDEF WIN32}
      NewTopLine := Message.Pos;
{$ELSE}
      NewTopLine := LongMulDiv(Message.Pos, FLineCount - 1, MaxInt);
{$ENDIF}
  end;
  if NewTopLine >= FLineCount then NewTopLine := FLineCount - 1;
  if NewTopLine < 0 then NewTopLine := 0;
  if NewTopLine <> FTopLine then begin
    LinesMoved := FTopLine - NewTopLine;
    FTopLine := NewTopLine;
    SetScroll(FTopLine);
    if Abs(LinesMoved) = 1 then begin
      R := Bounds(0, 0, ClientWidth, ClientHeight - FItemHeight);
      if LinesMoved = 1 then OffsetRect(R, 0, FItemHeight);
      ScrollWindow(Handle, 0, FItemHeight * LinesMoved, @R, nil);
      if LinesMoved = -1 then
      begin
        R.Top := ClientHeight - FItemHeight;
        R.Bottom := ClientHeight;
      end
      else
      begin
        R.Top := 0;
        R.Bottom := FItemHeight;
      end;