【delphi开源代码栏目提醒】:网学会员,鉴于大家对delphi开源代码十分关注,论文会员在此为大家搜集整理了“HexDump.pas”一文,供大家参考学习!
unit HexDump;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
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: Integer;
FTopLine: Integer;
FCurrentLine: Integer;
FVisibleLines: Integer;
FLineCount: Integer;
FBytesPerLine: Integer;
FItemHeight: Integer;
FItemWidth: Integer;
FFileColors: array[0..2] of TColor;
FShowCharacters: Boolean;
FShowAddress: Boolean;
FBorder: TBorderStyle;
FHexData: THexStrArray;
FLineAddr: array[0..15] of char;
procedure CalcPaintParams;
procedure SetTopLine(Value: Integer);
procedure SetCurrentLine(Value: Integer);
procedure SetFileColor(Index: Integer; Value: TColor);
function GetFileColor(Index: Integer): TColor;
procedure SetShowCharacters(Value: Boolean);
procedure SetShowAddress(Value: Boolean);
procedure SetBorder(Value: TBorderStyle);
procedure SetAddress(Value: Pointer);
procedure SetDataSize(Value: Integer);
procedure AdjustScrollBars;
function LineAddr(Index: Integer): PChar;
function LineData(Index: Integer): PChar;
function LineChars(Index: Integer): PChar;
function ScrollIntoView: Boolean;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
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: Integer read FCurrentLine write SetCurrentLine;
property Address: Pointer read FAddress write SetAddress;
property DataSize: Integer read FDataSize write SetDataSize;
published
property Align;
property Border: TBorderStyle read FBorder write SetBorder;
property Color default clWhite;
property Ctl3D;
property Font;
property TabOrder;
property TabStop;
property ShowAddress: Boolean read FShowAddress write SetShowAddress default True;
property ShowCharacters: Boolean read FShowCharacters write SetShowCharacters default True;
property AddressColor: TColor index 0 read GetFileColor write SetFileColor default clBlack;
property HexDataColor: TColor index 1 read GetFileColor write SetFileColor default clBlack;
property AnsiCharColor: TColor index 2 read GetFileColor write SetFileColor default clBlack;
end;
function CreateHexDump(AOwner: TWinControl): THexDump;
implementation
{ Form Methods }
function CreateHexDump(AOwner: TWinControl): THexDump;
begin
Result := THexDump.Create(AOwner);
with Result do
begin
Parent := AOwner;
Font.Name := 'FixedSys';
ShowCharacters := True;
Align := alClient;
end;
end;
{ THexDump }
constructor THexDump.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csFramed];
FBorder := bsSingle;
Color := clWhite;
FShowAddress := True;
FShowCharacters := True;
Width := 300;
Height := 200;
FillChar(FHexData, SizeOf(FHexData), #9);
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
Style := Style or WS_BORDER;
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.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: Integer;
LinesMoved: Integer;
R: TRect;
begin
inherited;
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_THUMBPOSITION, SB_THUMBTRACK: NewTopLine := Message.Pos;
end;
if NewTopLine < 0 then NewTopLine := 0;
if NewTopLine >= FLineCount then
NewTopLine := FLineCount - 1;
if NewTopLine <> FTopLine then
begin
LinesMoved := FTopLine - NewTopLine;
FTopLine := NewTopLine;
SetScrollPos(Handle, SB_VERT, FTopLine, True);
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;
Windows.InvalidateRect(Handle, @R, False);
end
else Invalidate;
end;
end;
{ Painting Related }
procedure THexDump.CalcPaintParams;
const
Divisor: array[boolean] of Integer = (3,4);
var
CharsPerLine: Integer;
begin
if FItemHeight < 1 then Exit;
FVisibleLines := (ClientHeight div FItemHeight) + 1;
CharsPerLine := ClientWidth div FItemWidth;
if FShowAddress then Dec(CharsPerLine, 10);
FBytesPerLine := CharsPerLine div Divisor[FShowCharacters];
if FBytesPerLine < 1 then
FBytesPerLine := 1
else if FBytesPerLine > MAXDIGITS then
FBytesPerLine := MAXDIGITS;
FLineCount := (DataSize div FBytesPerLine);
if Boolean(DataSize mod FBytesPerLine) then Inc(FLineCount);
end;
procedure THexDump.AdjustScrollBars;
begin
SetScrollRange(Handle, SB_VERT, 0, FLineCount - 1, True);
end;
function THexDump.ScrollIntoView: Boolean;
begin
Result := False;
if FCurrentLine < FTopLine then
begin
Result := True;
SetTopLine(FCurrentLine);
end
else if FCurrentLine >= (FTopLine + FVisibleLines) - 1 then
begin
SetTopLine(FCurrentLine - (FVisibleLines - 2));
Result := True;
end;
end;
procedure THexDump.SetTopLine(Value: Integer);
var
LinesMoved: Integer;
R: TRect;
begin
if Value <> FTopLine then
begin
i
上一篇:
FrmRoomMan.frm
下一篇:
儿童四肢皮肤挫伤采用美宝疮疡贴治疗的疗效