Custom component-ipedit

Enter the IP address in the format of... windows.

 

Unit hsipedit; //************************************** *************************************/// /ipedit /// version: 1.1 // Author: Liu Zhilin // modification date: 2016-07-12 // QQ: 17948876 // E-mail: [email protected] // blog: http://www.cnblogs.com/hs-kill !!! If there are any changes, please inform the author. Thank you for your cooperation !!! /// ------------------------------------------------------------------------------- // Modify the history: // 1.1 // Add support for IPv6 ////************************** **************************************** ******** interfaceuses messages, windows, sysutils, classes, controls, forms, graphics, stdctrls, extctrls, themes; const {activate the next column, wparam: column No. lparam: whether to select all 0-do not select 1-select} wm_ipfield_active = wm_user + $4; 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: summary); 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 0; property MAX: Word read fmax write setmax default 255; property Value: Word read getvalue write setvalue default 0; property error: Boolean read geterror; end; thsipedit = Class (tcustomcontrol) Private fupdatting: Boolean; fipv6: Boolean; {If IPv4 is used, use the last 4 digits} ffields: array [0 .. 7] of thsipfield; attributes: Boolean; fonchange: tpolicyevent; 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 cmenter (VAR message: tcmenter); message cm_enter; Procedure wmlbuttondown (VAR message: twmlbuttondown); message success; Procedure cmcolorchanged (VAR message: tmessage); message cm_colorchanged; Procedure cmfontchanged (VAR message: tmessage ); message cm_fontchanged; Procedure wmipfieldactive (VAR message: tmessage); message success; 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 );*) {do not open settings temporarily} 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: tpolicyevent read fonchange write fonchange; property onenter; property onexit; end; implementationconst _ defwidthipv4 = 161; _ defwidthipv6 = 361; {tipfieldedit} procedure thsipfield. setmin (avalue: Word); begin if (not fipv6) and (avalue> 255) Then avalue: = 255; 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 <> 0) Then avalue: = ''else begin if (nvalue <fmin) Then nvalue: = fmin else if (nvalue> fmax) Then nvalue: = fmax; If fipv6 then avalue: = inttohex (nvalue, 2) 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; Procedure thsipfield. setmax (avalue: Word); begin if (not fipv6) and (avalue> 255) Then avalue: = 255; fmax: = avalue; If fmin> fmax then fmin: = fmax; end; Procedure thsipfield. setvalue (avalue: Word); begin if fipv6 then setvaluestr (inttohex (avalue, 2) else setvaluestr (inttostr (avalue); end; Procedure thsipfield. keypress (var key: Char); begin if fipv6 and (key in ['0 '.. '9', 'A '.. 'F']) then begin inherited; end else if (key in ['0 '.. '9']) then begin inherited; end else begin if (Key = '. ') and (sellength = 0) and (Text <> '') Then activefield (True, true); if key <> #8 then key: = #0 else if currentposition = 0 then activefield (false, false); 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 + 1, makelparam (byte (Asel), 0) else sendmessage (parent. handle, wm_ipfield_active, findex-1, makelparam (byte (Asel), 1); 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: = 0; fmax: = 255; fipv6: = false; fissetvalue: = false; maxlength: = 3; 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, 0 )), 0); 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, 0) else result: = strtointdef (text, 0); end; Procedure thsipfield. setcurrentposition (value: integer); var NPOs: integer; begin {value must be within range} NPOs: = value; If NPOs <0 then NPOs: = 0; if NPOs> length (text) Then NPOs: = length (text); {put cursor in selected position} selstart: = sendmessage (handle, em_lineindex, 0, 0) + NPOs; end; Procedure thsipfield. setipv6 (avalue: Boolean); var nV: string; begin if fipv6 <> avalue then begin fipv6: = avalue; If fipv6 then begin maxlength: = 4; fmax: = $ FFFF; nV: = inttohex (strtointdef (text, 0), 2); End else begin maxlength: = 3; fmax: = 255; nV: = inttostr (strtointdef ('$' + text, 0); 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: = 0; activefield (true, false); Result: = 1; end else if (charcode = vk_left) and (currentposition = 0) then begin sellength: = 0; activefield (false, false); Result: = 1; end Else inherited; end; {tipedit} constructor thsipedit. create (aowner: tcomponent); var I: integer; begin inherited create (aowner); controlstyle: = [delimiter, cscapturemouse, delimiter, cssetcaption, csopaque, csdoubleclicks, csreplicatable]; if newstylecontrols then controlstyle: = controlstyle else controlstyle: = controlstyle + [csframed]; parentfont: = true; fupdatting: = true; fipv6: = false; for I: = 0 to 7 do begin ffields [I]: = thsipfield. create (Self); with ffields [I] Do begin findex: = I; parent: = self; fipv6: = self. fipv6; onchange: = dochange; end; // cursor: = cribeam; width: = 161; Height: = 21; bevelkind: = bkflat; tabstop: = true; parentcolor: = false; arrangefields; fupdatting: = false; end; destructor thsipedit. destroy; var I: integer; begin for I: = 0 to 7 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 = (0, 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; 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 2; If fipv6 then begin for I: = 1 to 7 do canvas. textout (ffields [I]. left-nfsize. CX-2, ntop, ':'); End else begin for I: = 5 to 7 do canvas. textout (ffields [I]. left-nfsize. CX-2, ntop ,'. '); 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: = 0 else M: = 4; for I: = m to 7 do if ffields [I]. error then begin result: = true; break; end; Procedure thsipedit. setcursor (avalue: tcursor); var I: integer; begin inherited cursor: = avalue; for I: = 0 to 7 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 + 2; NH: = nfsize. cy + 2; NT: = NRC. top + (NRC. bottom-NRC. top-NH) Div 2 + 1; NB: = nfsize. cx + 4; If fipv6 then begin NW: = (clientwidth-4-Nb * 7) Div 8; for I: = 0 to 7 do begin ffields [I]. setbounds (NL, NT, NW, NH); Inc (NL, NW + Nb); end else begin NW: = (clientwidth-4-Nb * 3) Div 4; for I: = 0 to 3 do ffields [I]. setbounds (NL, NT, NW, NH); for I: = 4 to 7 do begin ffields [I]. setbounds (NL, NT, NW, NH); Inc (NL, NW + Nb); 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 [0]. value, ffields [1]. value, ffields [2]. value, ffields [3]. value, ffields [4]. value, ffields [5]. value, ffields [6]. value, ffields [7]. value]) else result: = format ('% d. % d. % d. % d', [ffields [4]. value, ffields [5]. value, ffields [6]. value, ffields [7]. value]); end; Procedure thsipedit. setipstring (value: string); var I, NF: integer; begin if fipv6 then NF: = 0 else NF: = 4; with tstringlist. create do try if fipv6 then delimiter: = ': 'else delimiter: = '. '; delimitedtext: = value; {IPv6 abbreviation mode such as: 0: FF: 0} If count <> (8-NF) then for I: = NF to 7 do ffields [I]. setvaluestr ('') else for I: = NF to 7 do ffields [I]. setvaluestr (strings [I-NF]); finally free; end; Procedure thsipedit. setipv6 (const value: Boolean); var I: integer; begin if fipv6 <> value then begin fupdatting: = true; fipv6: = value; for I: = 0 to 7 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; (* 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; 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; *) function thsipedit. focusindex: integer; var I: integer; begin result: =-1; for I: = 0 to 7 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: = 0 else NF: = 4; with message do begin if (wparam <NF) or (wparam> 7) Then exit; NSEL: = Boolean (byte (lparamlo); If NSEL then ffields [wparam]. selectall else if lparamhi = 0 then ffields [wparam]. currentposition: = 0 else ffields [wparam]. currentposition: = length (ffields [wparam]. text); ffields [wparam]. setfocus; end; Procedure thsipedit. wmlbuttondown (VAR message: twmlbuttondown); begin inherited; If focusindex <0 then if fipv6 then ffields [0]. setfocus else ffields [4]. setfocus; end; function thsipedit. getfieldcount: byte; begin if fipv6 then result: = 8 else result: = 4; end; function thsipedit. getfields (aindex: integer): thsipfield; begin result: = ffields [aindex]; end; function thsipedit. getfieldvalue (Index: byte): integer; begin result: = 0; If fipv6 then begin if index> 7 then exit; If ffields [Index]. error then exit; Result: = ffields [Index]. value; end else begin if index> 3 then exit; If ffields [index + 4]. error then exit; Result: = ffields [index + 4]. value; end; function thsipedit. gettabstop: Boolean; begin result: = inherited tabstop; end; Procedure thsipedit. settabstop (avalue: Boolean); var I: integer; begin if avalue <> inherited tabstop then begin inherited tabstop: = avalue; for I: = 0 to 7 do ffields [I]. tabstop: = avalue; end; Procedure thsipedit. setreadonly (avalue: Boolean); var I: integer; begin if readonly <> avalue then for I: = 0 to 7 do ffields [I]. readonly: = avalue; end; function thsipedit. getreadonly: Boolean; begin result: = ffields [0]. readonly; end; Procedure thsipedit. cmenter (VAR message: tcmenter); begin if IPv6 then ffields [0]. setfocus else ffields [4]. setfocus; inherited; end.

Http://www.cnblogs.com/hs-kill/p/5810076.html

Custom component-ipedit