Chip 2002 April/Chip_2002-04_cd1.bin/zkuste/delphi/kolekce/d3456/PBEDIT.ZIP/PBBinHexEdit.pas

Pascal/Delphi Source File | 2002-01-19 | 14KB | 511 lines

{Author:    Poul Bak}
{}
{Copyright ⌐ 1999 - 2002 : BakSoft-Denmark (Poul Bak). All rights reserved.}
{}
{http://home11.inet.tele.dk/BakSoft/}
{Mailto: [e-mail]}
{}
{Component Version: 6.00.00.00}
{}
{PBBinHexEdit is a special Edit-component for Binary, Hexadecimal and integer
 editing, display and conversion.}
{}
{Supports Windows 95, 98 and NT.}
{Supports Default-Button click.}
{Supports Cancel-button click.}

unit PBBinHexEdit;

interface

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

type
{Number = standard integer format.}
{Binary = number with only 0 and 1 like '0110'.
{HexaDecimal = number with hexadecimal format like $7FFFFFFF.}
    TBaseFormat = (Number, Binary, HexaDecimal);

{Author:    Poul Bak}
{}
{Copyright ⌐ 1999 - 2002 : BakSoft-Denmark (Poul Bak). All rights reserved.}
{}
{http://home11.inet.tele.dk/BakSoft/}
{Mailto: [e-mail]}
{}
{Component Version: 6.00.00.00}
{}
{PBBinHexEdit is a special Edit-component for Binary, Hexadecimal and integer
 editing, display and conversion.}
{}
{Supports Windows 95, 98 and NT.}
{Supports Default-Button click.}
{Supports Cancel-button click.}
    TPBBinHexEdit = class(TCustomEdit)
    private
        { Private declarations }
        FAlignment: TAlignment;
        FBaseFormat : TBaseFormat;
        FEnter : Boolean;
        FInvalidEntry: TNotifyEvent;
        FMaxValue: Integer;
        FMinValue: Integer;
        FVersion: String;
        function BinToInt(B : string): integer;
        function FormatText(Value: Integer; NFormat: TBaseFormat): string;
        function GetAsInteger: Integer;
        function GetAsBin: string;
        function GetAsHex: string;
        function IntToBin(I : integer): string;
        procedure InvalidEntry;
        procedure SetAlignment(Value: TAlignment);
        procedure SetAsInteger(Value: Integer);
        procedure SetAsBin(Value: string);
        procedure SetAsHex(Value: string);
        procedure SetBaseFormat(Value: TBaseFormat);
        procedure SetMaxValue(Value: Integer);
        procedure SetMinValue(Value: Integer);
        procedure SetVersion(Value: String);
        procedure WMGetDlgCode(var Msg : TWMGetDlgCode); message WM_GETDLGCODE;
        procedure WMPaste(var Message: TMessage); message WM_PASTE;
    protected
        { Protected declarations }
        procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
        procedure DoEnter; override;
        procedure DoExit; override;
        procedure KeyDown(var Key: Word; Shift: TShiftState); override;
        procedure KeyPress(var Key: Char); override;
        procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    public
        { Public declarations }
        constructor Create(AOwner: TComponent); override;
        procedure CreateParams(var Params: TCreateParams); override;
    published        { Published declarations }
{Set Alignment to: taLeftJustify, taCenter or taRightJustify.}
{Default : taLeftJustify.}
{Supports Windows 95, 98 and NT.}
        property Alignment: TAlignment read FAlignment write SetAlignment;
{Set or access the value as a binary string: 1010101010}
        property AsBin: string read GetAsBin write SetAsBin;
{Set or access the value as an integer type (normal number)}
        property AsInteger: Integer read GetAsInteger write SetAsInteger;
{Set or access the value as a Hexadecimal string: $FFFFFFFF}
        property AsHex: string read GetAsHex write SetAsHex;
{Default: True.}
{Set AutoSelect to True to select all text when you set focus:}
{Notice that when you set focus using the mouse, all text is also selected -
unlike standard Delphi components that only selects all when setting focus with <tab>.}
{When a form has a defaultbutton and you press <enter>, the click event
triggers and focus is returned to the edit control which autoselects all.}
        property AutoSelect;
        property AutoSize;
{BaseFormat is the edit- and displaytype}
        property BaseFormat: TBaseFormat read FBaseFormat write SetBaseFormat;
        property BorderStyle;
        property Color;
        property Ctl3D;
        property DragCursor;
        property DragMode;
        property Enabled;
        property Font;
        property HideSelection;
        property MaxLength;
{Set MaxValue to prevent users from entering values greater than MaxValue.
OnInvalidEntry triggers when the edit component looses focus.
When MaxValue and MinValue are both zero, they have no effect.}
        property MaxValue: Integer read FMaxValue write SetMaxValue;
{Set MinValue to prevent users from entering values less than MinValue.
OnInvalidEntry triggers when the edit component looses focus.
When MaxValue and MinValue are both zero, they have no effect.}
        property MinValue: Integer read FMinValue write SetMinValue;
        property OnChange;
        property OnClick;
        property OnDblClick;
        property OnDragDrop;
        property OnDragOver;
        property OnEndDrag;
        property OnEnter;
        property OnExit;
{Is called when the user enters a value greater than MaxValue or smaller
than MinValue.}
        property OnInvalidEntry: TNotifyEvent read FInvalidEntry write FInvalidEntry;
        property OnKeyDown;
        property OnKeyPress;
        property OnKeyUp;
        property OnMouseDown;
        property OnMouseMove;
        property OnMouseUp;
        property OnStartDrag;
        property ParentColor;
        property ParentCtl3D;
        property ParentFont;
        property ParentShowHint;
        property PopupMenu;
        property ReadOnly;
        property ShowHint;
        property TabOrder;
        property TabStop;
{Read only}
        property Version: String read FVersion write SetVersion;
{Set Visible to False if you just need the conversion routines.}
        property Visible;
    end;

procedure Register;

implementation

uses Clipbrd;

constructor TPBBinHexEdit.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);
    Width := 100;
    FAlignment := taCenter;
    FEnter := False;
    FMaxValue := 0;
    FMinValue := 0;
    FBaseFormat := HexaDecimal;
    FVersion := '6.00.00.00';
    AsInteger := 0;
    Text := FormatText(0, FBaseFormat);
end;

procedure TPBBinHexEdit.CreateParams(var Params: TCreateParams);
const
    Alignments: array[TAlignment] of Word = (ES_LEFT, ES_RIGHT, ES_CENTER);
begin
    inherited CreateParams(Params);
    Params.Style := Params.Style or ES_MULTILINE or Alignments[FAlignment];
end;

procedure TPBBinHexEdit.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
    inherited MouseDown(Button, Shift, X, Y);
    if (Button = mbLeft) or (ssLeft in Shift) then
    begin
        if FEnter = True then
        begin
            FEnter := False;
            if AutoSelect then SelectAll;
        end;
    end;
end;

procedure TPBBinHexEdit.DoEnter;
begin
    inherited DoEnter;
    if csLButtonDown in ControlState then FEnter := True;
    if AutoSelect then SelectAll;
end;

procedure TPBBinHexEdit.DoExit;
begin
    inherited DoExit;
    if (FMinValue <> 0) and (FMaxValue <> 0)
        and ((AsInteger < FMinValue) or (AsInteger > FMaxValue)) then InvalidEntry;
end;

procedure TPBBinHexEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
    inherited KeyDown(Key, Shift);
    FEnter := False;
    if not ReadOnly then
    begin
        if Key in [VK_DELETE] then if (SelStart = 0)
            and ((Text[1] in ['$']) or (SelLength = length(Text))) then
        begin
            if (FBaseFormat = HexaDecimal) then
            begin
                Text := '$0';
                SelStart := 1;
            end
            else
            begin
                Text := '0';
                SelStart := 0;
            end;
            Key := 0;
            SelLength := 1;
        end;
    end;
end;

procedure TPBBinHexEdit.KeyUp(var Key: Word; Shift: TShiftState);
begin
    inherited KeyUp(Key, Shift);
    if not ReadOnly then
    begin
        if (FBaseFormat = HexaDecimal) then
        begin
            if (Text = '') or (Text = '$') then
            begin
                Text := '$0';
                SelStart := 1;
                SelLength := 1;
            end
            else if Text[1] <> '$' then
            begin
                Text := '$' + Text;
                SelStart := SelStart + 2;
                SelLength := 0;
            end;
        end
        else if Text = '' then
        begin
            Text := '0';
            SelStart := 0;
            SelLength := 1;
        end;
    end;
end;

procedure TPBBinHexEdit.KeyPress(var Key: Char);
var
    Fl : Extended;
begin
    if (Key in [#13, #27]) then
    begin
        MessageBeep(0);
        Key := #0;
        Exit;
    end;
    inherited KeyPress(Key);
    if Key in [#3] then Exit;
    if ReadOnly then
    begin
        MessageBeep(0);
        Key := #0;
        Exit;
    end;
    if (Key in [#8, #22, #24]) then Exit
    else if (FBaseFormat = HexaDecimal) then
    begin
        if Key in ['a'..'f'] then Key := Chr(Ord(Key) - 32);
        if (Key in ['$']) then
        begin
            Text := '$0';
            Key := #0;
            SelStart := 1;
            SelLength := 1;
        end
        else if not (Key in ['0'..'9','A'..'F']) then Key := #0
        else if (Length(Text) >= 9) and (SelStart >= 9) then Key := #0
        else if (Length(Text) >= 9) and (SelLength = 0) then
        begin
            if (SelStart < 1) then SelStart := 1;
            SelLength := 1;
        end;
    end
    else if (FBaseFormat = Binary) then
    begin
        if not (Key in ['0','1']) then Key := #0
        else if (Length(Text) >= 32) and (SelStart >= 32) then Key := #0
        else if (Length(Text) >= 32) and (SelLength = 0) then SelLength := 1;
    end
    else
    begin
        if not (Key in ['0'..'9','-']) then Key := #0
        else if (Key = '-') and (pos('-', Text) = 0) then SelStart := 0
        else if (Key = '-') and (pos('-', Text) = 1) then
        begin
            Text := copy(Text, 2, Length(Text) - 1);
            Key := #0;
        end
        else if (((Length(Text) >= 10) and (Pos('-', Text) = 0))
            or (Length(Text) >= 11)) and (SelStart >= 10) then Key := #0
        else if (((Length(Text) >= 10) and (Pos('-', Text) = 0))
            or (Length(Text) >= 11)) and (SelLength = 0) then SelLength := 1
        else
        begin
            if (SelStart < 1) and (Text[1] = '-') and (SelLength = 0) then SelStart := 1;
            Fl := StrToFloat(copy(Text, 1, SelStart) + Key + copy(Text,
                SelStart + SelLength + 1, Length(Text) - SelStart - SelLength - 1));
            if (Fl > 2147483647.0) or (Fl < -2147483648.0) then Key := #0;
        end;
    end;
end;

function TPBBinHexEdit.GetAsInteger: Integer;
begin
    if (FBaseFormat = Binary) then Result :=  BinToInt(Text)
    else Result := StrToInt(Text);
end;

function TPBBinHexEdit.GetAsBin: string;
begin
    Result := FormatText(AsInteger, Binary);
end;

function TPBBinHexEdit.GetAsHex: string;
begin
    Result := FormatText(AsInteger, HexaDecimal);
end;

procedure TPBBinHexEdit.SetAsInteger(Value: Integer);
begin
    if csDesigning in ComponentState then
    begin
        If (Value > FMaxValue) and ((FMaxValue <> 0) or (FMinValue <> 0)) then InvalidEntry;
        If (Value < FMinValue) and ((FMaxValue <> 0) or (FMinValue <> 0)) then InvalidEntry;
    end;
    if Text <> FormatText(Value, FBaseFormat) then Text := FormatText(Value, FBaseFormat);
end;

procedure TPBBinHexEdit.SetAsBin(Value: string);
begin
    if AsInteger <> BinToInt(Value) then AsInteger := BinToInt(Value);
end;

procedure TPBBinHexEdit.SetAsHex(Value: string);
begin
    if AsInteger <> StrToInt(Value) then AsInteger := StrToInt(Value);
end;

procedure TPBBinHexEdit.SetAlignment(Value: TAlignment);
var
    SelSt, SelLe : integer;
begin
    if FAlignment <> Value then
    begin
        SelSt := SelStart;
        SelLe := SelLength;
        FAlignment := Value;
        RecreateWnd;
        SelStart := SelSt;
        SelLength := SelLe;
    end;
end;

procedure TPBBinHexEdit.SetMaxValue(Value: Integer);
begin
    if (FMaxValue <> Value) and (Value >= FminValue) then
    begin
        FMaxValue := Value;
    end;
end;

procedure TPBBinHexEdit.SetMinValue(Value: Integer);
begin
    if (FMinValue <> Value) and (Value <= FmaxValue) then
    begin
        FMinValue := Value;
    end;
end;

procedure TPBBinHexEdit.InvalidEntry;
begin
    if assigned(FInvalidEntry) then FInvalidEntry(Self)
    else Application.MessageBox('Value out of range!', 'Invalid Entry', MB_ICONWARNING + MB_OK);
end;

procedure TPBBinHexEdit.SetVersion(Value: String);
begin
    { Read only! }
end;

procedure TPBBinHexEdit.SetBaseFormat(Value: TBaseFormat);
var
    Asi : integer;
begin
    if FBaseFormat <> Value then
    begin
        Asi := AsInteger;
        FBaseFormat := Value;
        Text := FormatText(AsI, FBaseFormat);
    end;
end;

function TPBBinHexEdit.FormatText(Value: Integer; NFormat: TBaseFormat): string;
begin
    if NFormat = Number then Result := IntToStr(Value)
    else if NFormat = Binary then Result := IntToBin(Value)
    else Result := '$' + IntToHex(Value, 8);
end;

function TPBBinHexEdit.IntToBin(I : integer): string;
var
    b, t, c : integer;
begin
    Result := '';
    if I < 0 then
    begin
        Result := Result + '1';
        c := I + 2147483647 + 1;
    end
    else c := I;
    t := 1073741824;
    repeat
        b := c - t;
        if b >= 0 then
        begin
            Result := Result + '1';
            c := b;
        end
        else if c <> I then Result := Result + '0';
        t := trunc(t / 2);
    until t = 0;
    if Result = '' then Result := '0';
end;

function TPBBinHexEdit.BinToInt(B : string): integer;
var
    b1: string;
    t : comp;
    a : char;
    ok : boolean;
    t1 : integer;
begin
    ok := True;
    b1 := B;
    Result := 0;
    if b1 = '' then exit;
    for t1 := 1 to length(b1) do if not (b1[t1] in ['0', '1']) then ok := False;
    if ok then
    begin
        t := 1;
        repeat
            a := b1[length(b1)];
            if a = '1' then Result := Result + trunc(t);
            if (t = -1073741824 * 2) then exit
            else if t = 1073741824 then t := -1073741824 * 2
            else t := t * 2;
            b1 := copy(b1, 1, length(b1) - 1);
        until b1 ='';
    end;
end;

procedure TPBBinHexEdit.WMPaste(var Message: TMessage);
var
    X, P: integer;
    S: String;
    W: Word;
begin
    P := SelStart;
    Text := Copy(Text, 1, SelStart)
        + Copy(Text, SelStart + SelLength + 1, Length(Text) - SelStart - SelLength);
    SelStart := P;
    SelLength := 0;
    S := Clipboard.AsText;
    for X := 1 to Length(S) do
    begin
        W := Ord(S[X]);
        Perform(WM_CHAR, W, 0);
    end;
end;

procedure TPBBinHexEdit.WMGetDlgCode(var Msg: TWMGetDlgCode);
begin
    Msg.Result := DLGC_WANTCHARS or DLGC_WANTARROWS;
end;

procedure Register;
begin
    RegisterComponents('PB', [TPBBinHexEdit]);
end;

end.