hexdump.pas

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

      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);
  if (FLineCount - 1) < FCurrentLine then CurrentLine := FLineCount - 1;
  if (FLineCount - 1) < FTopLine then SetTopLine(FLineCount - 1);
end;

procedure THexDump.SetScroll(Value: Longint);
begin
{$IFDEF WIN32}
  SetScrollPos(Handle, SB_VERT, Value, True);
{$ELSE}
  SetScrollPos(Handle, SB_VERT, LongMulDiv(Value, MaxInt,
    FLineCount - 1), True);
{$ENDIF}
end;

procedure THexDump.AdjustScrollBars;
begin
{$IFDEF WIN32}
  SetScrollRange(Handle, SB_VERT, 0, FLineCount - 1, True);
{$ELSE}
  if FLineCount > 1 then SetScrollRange(Handle, SB_VERT, 0, MaxInt, True)
  else SetScrollRange(Handle, SB_VERT, 0, 0, True);
{$ENDIF}
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: Longint);
var
  LinesMoved: Longint;
  R: TRect;
begin
  if Value >= FLineCount then Value := FLineCount - 1;
  if Value < 0 then Value := 0;
  if Value <> FTopLine then begin
    LinesMoved := FTopLine - Value;
    FTopLine := Value;
    SetScroll(FTopLine);
    if Abs(LinesMoved) = 1 then begin
      R := Bounds(1, 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;
      InvalidateRect(Handle, @R, False);
    end
    else Invalidate;
  end;
end;

procedure THexDump.SetCurrentLine(Value: Longint);
var
  R: TRect;
begin
  if Value >= FLineCount then Value := FLineCount - 1;
  if Value < 0 then Value := 0;
  if (Value <> FCurrentLine) then begin
    if (FCurrentLine >= FTopLine) and (FCurrentLine < FTopLine + FVisibleLines{ - 1}) then
    begin
      R := Bounds(0, 0, ClientWidth, FItemHeight);
      OffsetRect(R, 0, (FCurrentLine - FTopLine) * FItemHeight);
      if FShowLineMarker then {!!}
        InvalidateRect(Handle, @R, True);
    end;
    FCurrentLine := Value;
    R := Bounds(0, 0, ClientWidth, FItemHeight);
    OffsetRect(R, 0, (FCurrentLine - FTopLine) * FItemHeight);
    if FShowLineMarker then {!!}
      InvalidateRect(Handle, @R, True);
    ScrollIntoView;
  end;
end;

procedure THexDump.InvalidateLineMarker;
var
  R: TRect;
begin
  if FShowLineMarker then begin
    R := Bounds(0, 0, ClientWidth, FItemHeight);
    OffsetRect(R, 0, (FCurrentLine - FTopLine) * FItemHeight);
    InvalidateRect(Handle, @R, True);
  end;
end;

procedure THexDump.Paint;
var
  R, ItemRect: TRect;
  I: Integer;
  AddressWidth: Integer;
  TabStop: Integer;
  ByteCnt: Integer;
begin
  inherited Paint;
  Canvas.Brush.Color := Self.Color;
  Canvas.FillRect(Rect(0, 0, ClientWidth, ClientHeight));
  if FShowAddress then AddressWidth := FItemWidth * 10
  else AddressWidth := 0;
  R := Bounds(1, 0, ClientWidth, FItemHeight);
  TabStop := FItemWidth * 3;
  Canvas.Font.Color := FFileColors[1];
  ByteCnt := FBytesPerLine;
  for I := 0 to FVisibleLines - 1 do begin
    R.Left := 1;
    if I + FTopLine < FLineCount then begin
      if FShowAddress then begin
        Canvas.Font.Color := FFileColors[0];
        R.Right := R.Left + AddressWidth;
        ExtTextOut(Canvas.Handle, R.Left, R.Top, ETO_OPAQUE or ETO_CLIPPED, @R,
          LineAddr(I + FTopLine), 10, nil);
        R.Left := R.Right;
        R.Right := ClientWidth;
        Canvas.Font.Color := FFileColors[1];
      end;
      if FShowLineMarker and ((I + FTopLine) = FCurrentLine) then begin
        Canvas.Brush.Color := clHighlight;
        Canvas.Font.Color := clHighlightText;
        ItemRect := Bounds(AddressWidth, 0, (FItemWidth * (FBytesPerLine * 3)) -
          FItemWidth + 1, FItemHeight);
        OffsetRect(ItemRect, 0, (FCurrentLine - FTopLine) * FItemHeight);
        Canvas.FillRect(ItemRect);
      end;
      if (I + FTopLine = FLineCount - 1) and ((DataSize mod FBytesPerLine) > 0) then
        ByteCnt := DataSize mod FBytesPerLine;
      TabbedTextOut(Canvas.Handle, R.Left, R.Top, LineData(I + FTopLine),
        (ByteCnt * 3) - 1, 1, TabStop, R.Left);
      if FShowLineMarker and ((I + FTopLine) = FCurrentLine) and Focused then
        Canvas.DrawFocusRect(ItemRect);
      Canvas.Brush.Color := Self.Color;
      Canvas.Font.Color := FFileColors[1];
      if FShowCharacters then begin
        R.Left := AddressWidth + (FItemWidth * (FBytesPerLine * 3));
        R.Right := ClientWidth;
        Canvas.Font.Color := FFileColors[2];
        ExtTextOut(Canvas.Handle, R.Left, R.Top, ETO_OPAQUE or ETO_CLIPPED, @R,
          LineChars(I + FTopLine, ByteCnt), ByteCnt, nil);
        Canvas.Font.Color := FFileColors[1];
      end;
    end
    else ExtTextOut(Canvas.Handle, R.Left, R.Top, ETO_OPAQUE or ETO_CLIPPED,
      @R, nil, 0, nil);
    OffsetRect(R, 0, FItemHeight);
  end;
end;

{ Event Overrides }

procedure THexDump.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited KeyDown(Key, Shift);
  if not FActive then Exit;
  case Key of
    VK_DOWN:
      if FShowLineMarker then
        CurrentLine := CurrentLine + 1
      else
        CurrentLine := FTopLine + FVisibleLines - 1;
    VK_UP:
      if FShowLineMarker then
        CurrentLine := CurrentLine - 1
      else
        CurrentLine := FTopLine - 1;
    VK_NEXT: CurrentLine := CurrentLine + FVisibleLines;
    VK_PRIOR: CurrentLine := CurrentLine - FVisibleLines;
    VK_HOME: CurrentLine := 0;
    VK_END: CurrentLine := FLineCount - 1;
  end;
end;

procedure THexDump.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if not Focused and CanFocus then SetFocus;
  if (Button = mbLeft) and FActive then
    CurrentLine := FTopLine + (Y div FItemHeight);
end;

{ Property Set/Get Routines }

procedure THexDump.SetBorder(Value: TBorderStyle);
begin
  if Value <> FBorder then begin
    FBorder := Value;
    RecreateWnd;
  end;
end;

procedure THexDump.SetRelativeAddress(Value: Boolean);
begin
  if FRelativeAddress <> Value then begin
    FRelativeAddress := Value;
    if ShowAddress then Invalidate;
  end;
end;

procedure THexDump.SetShowAddress(Value: Boolean);
begin
  if FShowAddress <> Value then begin
    FShowAddress := Value;
    CalcPaintParams;
    Invalidate;
    AdjustScrollBars;
  end;
end;

procedure THexDump.SetShowCharacters(Value: Boolean);
begin
  if Value <> FShowCharacters then begin
    FShowCharacters := Value;
    CalcPaintParams;
    Invalidate;
    AdjustScrollBars;
  end;
end;

procedure THexDump.SetShowLineMarker(Value: Boolean);
begin
  if Value <> FShowLineMarker then begin
    FShowLineMarker := Value;
    Invalidate;
  end;
end;

procedure THexDump.SetFileColor(Index: Integer; Value: TColor);
begin
  if FFileColors[Index] <> Value then
  begin
    FFileColors[Index] := Value;
    Invalidate;
  end;
end;

function THexDump.GetFileColor(Index: Integer): TColor;
begin
  Result := FFileColors[Index];
end;

procedure THexDump.SetAddress(Value: Pointer);
begin
  FActive := (Value <> nil);
  FAddress := Value;
  if not FActive then SetDataSize(0)
  else Invalidate;
  if FActive then begin
    CurrentLine := 0;
    ScrollIntoView;
  end;
end;

procedure THexDump.SetDataSize(Value: Longint);
begin
  FDataSize := Value;
  CalcPaintParams;
  Invalidate;
  AdjustScrollBars;
end;

function THexDump.LineAddr(Index: Longint): PChar;
begin
  if RelativeAddress then
    Result := StrFmt(FLineAddr, '%p: ', [HugeOffset(Pointer(0),
      Index * FBytesPerLine)])
  else
    Result := StrFmt(FLineAddr, '%p: ', [HugeOffset(FAddress,
      Index * FBytesPerLine)]);
end;

function THexDump.LineData(Index: Longint): PChar;

  procedure SetData(P: PChar);
  const
    HexDigits : array[0..15] of Char = '0123456789ABCDEF';
  var
    I: Integer;
    B: Byte;
  begin
    for I := 0 to FBytesPerLine - 1 do begin
      try
        B := Byte(P[I]);
        FHexData[I][0] := HexDigits[B SHR $04];
        FHexData[I][1] := HexDigits[B AND $0F];
      except
        FHexData[I][0] := '?';
        FHexData[I][1] := '?';
      end;
    end;
  end;

begin
  SetData(PChar(HugeOffset(FAddress, Index * FBytesPerLine)));
  Result := FHexData[0];
end;

function THexDump.LineChars(Index: Longint; MaxLen: Integer): PChar;
var
  I: Integer;
begin
  Move(HugeOffset(FAddress, Index * FBytesPerLine)^, FLineChars, MaxLen);
  Result := FLineChars;
  for I := 0 to MaxLen - 1 do
    if Result[I] < #32 then Result[I] := '.';
end;

end.