输入IP用的.....支持windows风格显示
unit HSIPEdit; // ***************************************************************************
//
// IPEdit
//
// 版本: 1.2
// 作者: 刘志林
// 修改日期: 2017-04-29
// QQ: 17948876
// E-mail: [email protected]
// 博客: http://www.cnblogs.com/lzl_17948876/
//
// !!! 若有修改,请通知作者,谢谢合作 !!!
//
// ---------------------------------------------------------------------------
//
// 修改历史:
// 1.1
// 增加对IPV6的支持
// 1.2
// 修改未获得焦点时, 鼠标点击焦点定位的问题
//
// *************************************************************************** interface uses
Messages, Windows, SysUtils, Classes, Controls, Forms,
Graphics, StdCtrls, ExtCtrls, Themes; const
{激活下一列, WParam: 列序号 LParam: 是否全选 0-不选 1-选}
WM_IPFIELD_ACTIVE = WM_USER + $; type
THSIPField = class(TCustomEdit)
private
{ Private declarations }
FMin, FMax: Word;
FIndex: Byte;
FIPV6: Boolean;
FIsSetValue: Boolean; function GetError: Boolean;
function GetValue: Word;
procedure SetMin(AValue: Word);
procedure SetMax(AValue: Word);
procedure SetValue(AValue: Word);
procedure SetIPV6(AValue: Boolean);
function GetCurrentPosition: Integer;
procedure SetCurrentPosition(Value: Integer); procedure WMKeyDown(var Message: TWMKey); message WM_KEYDOWN;
procedure CreateParams(var Params: TCreateParams); override;
procedure KeyPress(var Key: Char); override;
protected
{ Protected declarations }
procedure Change; override; procedure SetValueStr(AValue: string);
procedure ActiveField(ANext, ASel: Boolean); constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property IPV6: Boolean read FIPV6 write SetIPV6;
property CurrentPosition: integer read GetCurrentPosition write SetCurrentPosition;
property ReadOnly stored False;
property Index: Byte read FIndex;
published
{ Published declarations }
property Min: Word read FMin write SetMin default ;
property Max: Word read FMax write SetMax default ;
property Value: Word read GetValue write SetValue default ;
property Error: Boolean read GetError;
end; THSIPEdit = class(TCustomControl)
private
FUpdatting: Boolean;
FIPV6: Boolean;
{如果IPV4则使用后4位}
FFields: array[..] of THSIPField;
FFullRepaint: Boolean;
FOnChange: TNotifyEvent; procedure CreateParams(var Params: TCreateParams); override; function GetFieldCount: Byte;
function GetFieldValue(Index: Byte): Integer;
function GetMin(nIndex: Byte): Word;
procedure SetMin(nIndex: Byte; Value: Word);
function GetMax(nIndex: Byte): Word;
procedure SetMax(nIndex: Byte; Value: Word);
function GetIPString: string;
procedure SetIPString(Value: string);
function GetTabStop: Boolean;
procedure SetTabStop(AValue: Boolean);
procedure SetReadOnly(AValue: Boolean);
function GetReadOnly: Boolean;
function FocusIndex: Integer;
function GetFields(AIndex: Integer): THSIPField;
function GetCursor(): TCursor;
procedure SetCursor(AValue: TCursor);
function GetError: Boolean;
procedure SetIPV6(const Value: Boolean); procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure WMIPFIELDACTIVE(var Message: TMessage); message WM_IPFIELD_ACTIVE;
procedure DoChange(Sender: TObject);
protected
procedure ArrangeFields;
procedure Paint; override;
property FullRepaint: Boolean read FFullRepaint write FFullRepaint default True;
property Fields[index: Integer]: THSIPField read GetFields;
(*
function GetAddr: integer;
procedure SetAddr(value: integer);
*)
{暂时不开放设置}
property Min[index: Byte]: Word read GetMin write SetMin;
property Max[index: Byte]: Word read GetMax write SetMax; public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
(*
property Addr: integer read GetAddr write SetAddr;
*)
property FieldCount: Byte read GetFieldCount;
property FieldValue[Index: Byte]: Integer read GetFieldValue;
property Error: Boolean read GetError;
published
property Align;
property Anchors;
property IPString: string read GetIPString write SetIPString;
property BevelEdges;
property BevelInner;
property BevelKind default bkNone;
property BevelOuter;
property Color;
property Cursor: TCursor Read GetCursor write SetCursor;
property Ctl3D;
property Font;
property Enabled;
property ParentColor default False;
property ParentFont default True;
property ParentShowHint;
property PopupMenu;
property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
property IPV6: Boolean read FIPV6 write SetIPV6 default False;
property ShowHint;
property TabOrder;
property TabStop: Boolean read GetTabStop write SetTabStop default True;
property Visible;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnEnter;
property OnExit;
end; implementation const
_DefWidthIPV4 = ;
_DefWidthIPV6 = ; { TIPFieldEdit } procedure THSIPField.SetMin(AValue: Word);
begin
if (not FIPV6) and (AValue > ) then
AValue := ;
FMin := AValue;
if FMax < FMin then
FMax := FMin;
end; procedure THSIPField.SetValueStr(AValue: string);
var
nValue, nCode: Integer;
begin
FIsSetValue := True;
try
if FIPV6 then
AValue := '$' + AValue; Val(AValue, nValue, nCode); if (nCode <> ) then
AValue := ''
else
begin
if (nValue < FMin) then
nValue := FMin
else if (nValue > FMax) then
nValue := FMax; if FIPV6 then
AValue := IntToHex(nValue, )
else
AValue := IntToStr(nValue);
end;
if AValue <> Text then
Text := AValue; if (Length(Text) = MaxLength) and (CurrentPosition = MaxLength) then
ActiveField(True, True);
finally
FIsSetValue := False;
end;
end; procedure THSIPField.SetMax(AValue: Word);
begin
if (not FIPV6) and (AValue > ) then
AValue := ;
FMax := AValue;
if FMin > FMax then
FMin := FMax;
end; procedure THSIPField.SetValue(AValue: Word);
begin
if FIPV6 then
SetValueStr(IntToHex(AValue, ))
else
SetValueStr(IntToStr(AValue));
end; procedure THSIPField.KeyPress(var Key: Char);
begin
if FIPV6 and (Key in [''..'', 'A'..'F']) then
begin
inherited;
end
else if (Key in [''..'']) then
begin
inherited;
end
else
begin
if (Key = '.') and (SelLength = ) and (Text <> '') then
ActiveField(True, True);
if Key <> # then
Key := #
else if CurrentPosition = then
ActiveField(False, False);
end;
end; procedure THSIPField.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or (ES_CENTER);
end; procedure THSIPField.ActiveField(ANext, ASel: Boolean);
begin
if ANext then
SendMessage(Parent.Handle, WM_IPFIELD_ACTIVE, FIndex + , MakeLParam(Byte(ASel), ))
else
SendMessage(Parent.Handle, WM_IPFIELD_ACTIVE, FIndex - , MakeLParam(Byte(ASel), ));
end; procedure THSIPField.Change;
begin
if not FIsSetValue then
SetValueStr(Text);
inherited Change;
end; constructor THSIPField.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Text := '';
FMin := ;
FMax := ;
FIPV6 := False;
FIsSetValue := False;
MaxLength := ;
ParentFont := True;
ParentColor := True;
BorderStyle := bsNone;
end; destructor THSIPField.Destroy;
begin
inherited Destroy;
end; function THSIPField.GetCurrentPosition: Integer;
{Get character position of cursor within line}
begin
Result := SelStart - SendMessage(Handle, EM_LINEINDEX,
(SendMessage(Handle, EM_LINEFROMCHAR, SelStart, )), );
end; function THSIPField.GetError: Boolean;
var
nV: Integer;
begin
if FIPV6 then
Result := not TryStrToInt('$' + Text, nV)
else
Result := not TryStrToInt(Text, nV);
end; function THSIPField.GetValue: Word;
begin
if FIPV6 then
Result := StrToIntDef('$' + Text, )
else
Result := StrToIntDef(Text, );
end; procedure THSIPField.SetCurrentPosition(Value: Integer);
var
nPos: Integer;
begin
{Value must be within range}
nPos := Value;
if nPos < then
nPos := ;
if nPos > Length(Text) then
nPos := Length(Text);
{Put cursor in selected position}
SelStart := SendMessage(Handle, EM_LINEINDEX, , ) + nPos;
end; procedure THSIPField.SetIPV6(AValue: Boolean);
var
nV: string;
begin
if FIPV6 <> AValue then
begin
FIPV6 := AValue;
if FIPV6 then
begin
MaxLength := ;
FMax := $FFFF;
nV := IntToHex(StrToIntDef(Text, ), );
end
else
begin
MaxLength := ;
FMax := ;
nV := IntToStr(StrToIntDef('$' + Text, ));
end;
SetMax(FMax);
SetMin(FMin);
SetValueStr(nV);
end;
Visible := False;//FIPV6 or (FIndex > 3);
end; procedure THSIPField.WMKeyDown(var Message: TWMKey);
begin
with Message do
if (CharCode = VK_RIGHT) and (CurrentPosition >= Length(Text)) then
begin
SelLength := ;
ActiveField(True, False);
Result := ;
end
else if (CharCode = VK_LEFT) and (CurrentPosition = ) then
begin
SelLength := ;
ActiveField(False, False);
Result := ;
end
else
inherited;
end; { TIPEdit } constructor THSIPEdit.Create(AOwner: TComponent);
var
i: integer;
begin
inherited Create(AOwner);
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csSetCaption, csOpaque, csDoubleClicks, csReplicatable];
if NewStyleControls then
ControlStyle := ControlStyle else
ControlStyle := ControlStyle + [csFramed];
ParentFont := True;
FUpdatting := True;
FIPV6 := False;
for i := to do
begin
FFields[i] := THSIPField.Create(Self);
with FFields[i] do
begin
FIndex := i;
Parent := Self;
FIPV6 := Self.FIPV6;
OnChange := DoChange;
end;
end;
// Cursor := crIBeam;
Width := ;
Height := ;
BevelKind := bkFlat;
inherited TabStop := False;
ParentColor := False;
ArrangeFields;
FUpdatting := False;
end; destructor THSIPEdit.Destroy;
var
i: integer;
begin
for i := to do
FFields[i].Free;
inherited;
end; procedure THSIPEdit.DoChange(Sender: TObject);
begin
if Assigned(FOnChange) then
FOnChange(Self);
end; procedure THSIPEdit.CreateParams(var Params: TCreateParams);
const
ReadOnlys: array[Boolean] of DWORD = (, ES_READONLY);
begin
inherited CreateParams(Params);
with Params do
begin
Style := Style or ReadOnlys[ReadOnly];
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
end; procedure THSIPEdit.CMColorChanged(var Message: TMessage);
begin //
inherited;
Invalidate;
end; procedure THSIPEdit.CMFontChanged(var Message: TMessage);
begin //
inherited;
if not FUpdatting then
ArrangeFields;
Invalidate;
end; procedure THSIPEdit.CMCtl3DChanged(var Message: TMessage);
begin
inherited;
end; procedure THSIPEdit.Paint;
var
nRect: TRect;
nTop, i: Integer;
nFSize: TSize;
begin
// inherited;
nRect := GetClientRect; Canvas.Brush.Color := Color;
Canvas.FillRect(nRect); nFSize := Canvas.TextExtent('a');
nTop := nRect.Top + (nRect.Bottom - nRect.Top - nFSize.cy) div ;
if FIPV6 then
begin
for i := to do
Canvas.TextOut(FFields[i].Left - nFSize.cx - , nTop, ':');
end
else
begin
for i := to do
Canvas.TextOut(FFields[i].Left - nFSize.cx - , nTop, '.');
end;
end; function THSIPEdit.GetCursor(): TCursor;
begin
Result := inherited Cursor;
end; function THSIPEdit.GetError: Boolean;
var
i, m: Integer;
begin
Result := False;
if FIPV6 then
m :=
else
m := ; for i := m to do
if FFields[i].Error then
begin
Result := True;
Break;
end;
end; procedure THSIPEdit.SetCursor(AValue: TCursor);
var
i: integer;
begin
inherited Cursor := AValue;
for i := to do
FFields[i].Cursor := AValue;
end; procedure THSIPEdit.ArrangeFields;
var
i: integer;
nW, nH, nL, nT, nB: Integer;
nFSize: TSize;
nRC: TRect;
begin
if not Assigned(Parent) then
Exit;
nRC := ClientRect;
nFSize := Canvas.TextExtent('a');
nL := nRC.Left + ;
nH := nFSize.cy + ;
nT := nRc.Top + (nRC.Bottom - nRC.Top - nH) div + ; nB := nFSize.cx + ;
if FIPV6 then
begin
nW := (ClientWidth - - nB * ) div ;
for i := to do
begin
with FFields[i] do
begin
Enabled := True;
Visible := True;
SetBounds(nL, nT, nW, nH);
end;
Inc(nL, nW + nB);
end;
end
else
begin
nW := (ClientWidth - - nB * ) div ;
for i := to do
begin
with FFields[i] do
begin
Visible := False;
Enabled := False;
end;
end;
for i := to do
begin
FFields[i].SetBounds(nL, nT, nW, nH);
Inc(nL, nW + nB);
end;
end;
end; function THSIPEdit.GetMin(nIndex: Byte): Word;
begin
Result := FFields[nIndex].Min;
end; procedure THSIPEdit.SetMin(nIndex: Byte; Value: Word);
begin
FFields[nIndex].Min := Value;
end; function THSIPEdit.GetMax(nIndex: Byte): Word;
begin
Result := FFields[nIndex].Max;
end; procedure THSIPEdit.SetMax(nIndex: Byte; Value: Word);
begin
FFields[nIndex].Max := Value;
end; function THSIPEdit.GetIPString: string;
begin
if GetError then
Result := ''
else if FIPV6 then
Result := Format('%.4x:%.4x:%.4x:%.4x:%.4x:%.4x:%.4x:%.4x',
[FFields[].Value, FFields[].Value, FFields[].Value, FFields[].Value,
FFields[].Value, FFields[].Value, FFields[].Value, FFields[].Value])
else
Result := Format('%d.%d.%d.%d',
[FFields[].Value, FFields[].Value, FFields[].Value, FFields[].Value]);
end; procedure THSIPEdit.SetIPString(Value: string);
var
i, nF: integer;
begin
if FIPV6 then
nF :=
else
nF := ; with TStringList.Create do
try
if FIPV6 then
Delimiter := ':'
else
Delimiter := '.'; DelimitedText := Value;
{暂不支持IPV6缩写模式 如: 0::FF:0}
if Count <> ( - nF) then
for i := nF to do
FFields[i].SetValueStr('')
else
for i := nF to do
FFields[i].SetValueStr(Strings[i - nF]);
finally
Free;
end;
end; procedure THSIPEdit.SetIPV6(const Value: Boolean);
var
i: Integer;
begin
if FIPV6 <> Value then
begin
FUpdatting := True;
FIPV6 := Value;
for i := to do
FFields[i].IPV6 := FIPV6;
if FIPV6 then
begin
if Width = _DefWidthIPV4 then
Width := _DefWidthIPV6;
end
else
begin
if Width = _DefWidthIPV6 then
Width := _DefWidthIPV4;
end;
FUpdatting := False;
ArrangeFields;
Invalidate;
end;
end; (*
function THSIPEdit.GetAddr: integer;
type
DWORDSTRUCT = Record
case integer of
0: (b: array [0..3] of Byte);
1: (w: array [0..1] of word);
2: (d: Integer);
end;
var
v: DWORDSTRUCT;
i: integer;
begin
if Error then
Result := 0
else
begin
for i := 0 to 3 do
v.b[i] := FFields[i].Value;
Result := v.d;
end;
end; procedure THSIPEdit.SetAddr(value: integer);
type
DWORDSTRUCT = Record
case integer of
0: (b: array [0..3] of Byte);
1: (w: array [0..1] of word);
2: (d: integer);
end;
var
v: DWORDSTRUCT;
i: integer;
begin
v.d := value;
for i := 0 to 3 do
begin
FFields[i].Value := v.b[i];
end;
end;
*) function THSIPEdit.FocusIndex: Integer;
var
i: Integer;
begin
Result := -;
for i := to do
if FFields[i].Focused then
Result := i;
end; procedure THSIPEdit.WMSize(var Message: TWMSize);
begin
inherited;
if not FUpdatting then
ArrangeFields;
Invalidate;
end; procedure THSIPEdit.WMIPFIELDACTIVE(var Message: TMessage);
var
nF: integer;
nSel: Boolean;
begin
if FIPV6 then
nF :=
else
nF := ;
with Message do
begin
if (WParam < nF) or (WParam > ) then
Exit; nSel := Boolean(Byte(LParamLo));
if nSel then
FFields[WParam].SelectAll
else if LParamHi = then
FFields[WParam].CurrentPosition :=
else
FFields[WParam].CurrentPosition := Length(FFields[WParam].Text);
FFields[WParam].SetFocus;
end;
end; function THSIPEdit.GetFieldCount: Byte;
begin
if FIPV6 then
Result :=
else
Result := ;
end; function THSIPEdit.GetFields(AIndex: Integer): THSIPField;
begin
Result := FFields[AIndex];
end; function THSIPEdit.GetFieldValue(Index: Byte): Integer;
begin
Result := ;
if FIPV6 then
begin
if Index > then
Exit;
if FFields[Index].Error then
Exit;
Result := FFields[Index].Value;
end
else
begin
if Index > then
Exit;
if FFields[Index + ].Error then
Exit;
Result := FFields[Index + ].Value;
end;
end; function THSIPEdit.GetTabStop: Boolean;
begin
Result := FFields[].TabStop;
end; procedure THSIPEdit.SetTabStop(AValue: Boolean);
var
i: integer;
begin
if AValue <> TabStop then
begin
for i := to do
FFields[i].TabStop := AValue;
end;
end; procedure THSIPEdit.SetReadOnly(AValue: Boolean);
var
i: integer;
begin
if ReadOnly <> AValue then
for i := to do
FFields[i].ReadOnly := AValue;
end; function THSIPEdit.GetReadOnly: Boolean;
begin
Result := FFields[].ReadOnly;
end; end.