cmphexdump.pas

Delphi的另一款钢琴软件

  end;
end;

procedure THexDump.SetCurrentLine(Value: Integer);
var
  R: TRect;
begin
  if Value <> FCurrentLine then
  begin
    if Value < 0 then Value := 0;
    if Value >= FLineCount then Value := FLineCount - 1;

    if (FCurrentLine >= FTopLine) and (FCurrentLine < FTopLine + FVisibleLines - 1) then
    begin
      R := Bounds(0, 0, 1, FItemHeight);
      OffsetRect(R, 0, (FCurrentLine - FTopLine) * FItemHeight);
      Windows.InvalidateRect(Handle, @R, True);
    end;
    FCurrentLine := Value;

    R := Bounds(0, 0, 1, FItemHeight);
    OffsetRect(R, 0, (FCurrentLine - FTopLine) * FItemHeight);
    Windows.InvalidateRect(Handle, @R, True);
    ScrollIntoView;
    SetCaretPos
  end;
end;

procedure THexDump.Paint;
var
  R: TRect;
  I: Integer;
  TabStop: Integer;
  ByteCnt: Integer;
begin
  if Focused then
    HideCaret (handle);
  try
    inherited Paint;
    Canvas.Brush.Color := Self.Color;
    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 (FLineCount > 0) and (I + FTopLine < FLineCount) then
      begin
        if FShowAddress then
        begin
          Canvas.Font.Color := FFileColors[0];
          R.Right := R.Left + FAddressWidth;
          ExtTextOut(Canvas.Handle, R.Left, R.Top, ETO_OPAQUE or ETO_CLIPPED, @R, LineAddr(I+FTopLine), 9, nil);
          R.Left := R.Right;
          R.Right := ClientWidth;
          Canvas.Font.Color := FFileColors[1];
        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 FShowCharacters then
        begin
          R.Left := FAddressWidth+(FItemWidth*(FBytesPerLine*3));
          Canvas.Font.Color := FFileColors[2];
          ExtTextOut(Canvas.Handle, R.Left, R.Top, ETO_OPAQUE or ETO_CLIPPED, @R, LineChars(I+FTopLine), ByteCnt, nil);
        end;
      end
      else ExtTextOut(Canvas.Handle, R.Left, R.Top, ETO_OPAQUE or ETO_CLIPPED,
        @R, nil, 0, nil);
      OffsetRect(R, 0, FItemHeight);
    end;
  finally
    if Focused then
      ShowCaret (handle)
  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: CurrentLine := CurrentLine + 1;
    VK_UP: CurrentLine := CurrentLine - 1;
    VK_NEXT: CurrentLine := CurrentLine + FVisibleLines;
    VK_PRIOR: CurrentLine := CurrentLine - FVisibleLines;
    VK_HOME: CurrentLine := 0;
    VK_END: CurrentLine := FLineCount - 1;

    VK_LEFT : if EditCharacters or not LowNibble then
              begin
                FLowNibble := True;
                CurrentLinePos := CurrentLinePos - 1
              end
              else
                LowNibble := False;

    VK_RIGHT : if EditCharacters or LowNibble then
               begin
                 FLowNibble := False;
                 CurrentLinePos := CurrentLinePos + 1
               end
               else
                 LowNibble := True;
    VK_TAB : EditCharacters := not EditCharacters
  end;
end;

procedure THexDump.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if not Focused 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.SetShowAddress(Value: Boolean);
begin
  if FShowAddress <> Value then
  begin
    FShowAddress := Value;
    Invalidate;
  end;
end;

procedure THexDump.SetShowCharacters(Value: Boolean);
begin
  if Value <> FShowCharacters then
  begin
    FShowCharacters := 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;
  fCurrentLine := 0;
  fTopLine := 0;
  SetScrollPos(Handle, SB_VERT, FTopLine, True);
  Invalidate;
end;

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

function THexDump.LineAddr(Index: Integer): PChar;
begin
  Result := StrFmt(FLineAddr, '%p:', [Pointer(PChar(AddressOffset)+Index*FBytesPerLine)]);
end;

function THexDump.LineData(Index: Integer): 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(FAddress) + Index*FBytesPerLine);
  Result := FHexData[0];
end;

function THexDump.LineChars(Index: Integer): PChar;
begin
  Result := PChar(FAddress) + Index*FBytesPerLine;
end;

procedure THexDump.CreateWnd;
begin
  inherited;
  Canvas.Font := Self.Font;
  FItemHeight := Canvas.TextHeight('A') + 2;
  FItemWidth := Canvas.TextWidth('D') + 1;
end;

procedure THexDump.SetReadOnly(const Value: boolean);
begin
  if value <> fReadOnly then
  begin
    fReadOnly := Value;
    RecreateWnd
  end
end;

procedure THexDump.WMSetFocus(var Message: TWMSetFocus);
begin
  inherited;
  CreateCaret (handle, 0, 1, FItemHeight);
  SetCaretPos;
  ShowCaret (Handle)
end;

procedure THexDump.WMKillFocus(var Message: TWMKillFocus);
begin
  inherited;
  HideCaret (Handle);
  DestroyCaret
end;

procedure THexDump.SetCurrentLinePos(const Value: Integer);
var
  v : Integer;
begin
  if Value <> FCurrentLinePos then
  begin
    v := Value;
    while (V >= FBytesPerLine) and (CurrentLine < FLineCount - 1) do
    begin
      CurrentLine := CurrentLine + 1;
      Dec (V, FBytesPerLine)
    end;

    if V >= FBytesPerLine then
    begin
      V := FBytesPerLine - 1;
      FLowNibble := True
    end;

    while (V < 0) and (CurrentLine > 0) do
    begin
      CurrentLine := CurrentLine - 1;
      Inc (V, FBytesPerLine)
    end;

    if V < 0 then
    begin
      V := 0;
      FLowNibble := False
    end;

    FCurrentLinePos := V;
    SetCaretPos
  end
end;

procedure THexDump.SetCaretPos;
var
  x, y : Integer;
begin
  if Focused then
  begin
    y := FItemHeight * (CurrentLine - FTopLine);
    if FEditCharacters then
      x := FAddressWidth+(FItemWidth*(FBytesPerLine*3)) + (FItemWidth - 1) * CurrentLinePos
    else
    begin
      x := (FItemWidth) * 3 * CurrentLinePos + FAddressWidth;
      if FLowNibble then
        Inc (x, FItemWidth - 1)
    end;
    Windows.SetCaretPos (x, y)
  end
end;

procedure THexDump.SetEditCharacters(const Value: boolean);
begin
  if FEditCharacters <> Value then
  begin
    FEditCharacters := Value and ShowCharacters;
    SetCaretPos
  end
end;

procedure THexDump.SetLowNibble(const Value: boolean);
begin
  if FLowNibble <> Value then
  begin
    FLowNibble := Value;
    SetCaretPos
  end
end;

procedure THexDump.WMChar(var Message: TWMChar);
var
  ch : char;
  offset : Integer;
  data : byte;
  changes : boolean;
  b : byte;
begin
  inherited;

  ch := char (message.CharCode);
  if ch in [' '..#$ff] then
  begin
    offset := CurrentLine * FBytesPerLine + CurrentLinePos;
    changes := False;
    if EditCharacters then
      changes := True
    else
      if ch in ['0'..'9', 'A'..'F', 'a'..'f'] then
      begin
        data := Byte (PChar (Address) [Offset]);
        changes := True;
        b := StrToInt ('$' + ch);
        if LowNibble then
          ch := Char (data and $f0 + b)
        else
          ch := Char (data and $0f + (b shl 4));
      end;

    if changes then
    begin
      PChar (Address) [Offset] := ch;
      SetChanged;
      if EditCharacters or LowNibble then
      begin
        FLowNibble := False;
        CurrentLinePos := CurrentLinePos + 1
      end
      else
        LowNibble := True;
      Invalidate
    end
  end
end;

procedure THexDump.SetChanged;
begin
  if not Changes then
  begin
    fChanges := True;
    if Assigned (OnChanges) then
      OnChanges (self)
  end
end;

procedure THexDump.SetAddressOffset(const Value: Integer);
begin
  FAddressOffset := Value;
  Invalidate
end;

end.