Понедельник
04.07.2022
06:24

Форма входа

 Приветствую Вас Гость | RSS
Borland Delphi 7
Главная Регистрация Вход
Главная » 2009 » Февраль » 22 » Листинг - исходный код компонента TCustomlPEdit
Листинг - исходный код компонента TCustomlPEdit
10:44
unit uIPEdit;  

interface 

uses 

Windows, Messages, SysUtils, Classes, Controls; 

type 

TCustomlPEdit = class(TWinControl) 

 private 

{ Private declarations } 

 FIPAddress: DWORD; 

 FIPLimits: array [0..3] of word; 

 FCurrentField : Integer; 

//procedure CMWantSpecialKey(var Msg: TCMWantSpecialKey); 

 message CM_WANTSPECIALKEY; 

procedure WMGetDlgCode(var Message: TWMGetDlgCode); 

message WM_GETDLGCODE; 

procedure CMDialogChar(var Message: TCMDialogChar); 

 message CM_DIALOGCHAR; 

//procedure CMDialogKey(var Message: TCMDialogKey); 

 message CM_DIALOGKEY; 

procedure CNNotify(var Message: TWMNotify);  

message CN_NOTIFY;  

protected 

{ Protected declarations } 

function GetIP(Index: Integer): Byte; 

procedure SetIP(Index: Integer; Value: Byte); 

function GetMinIP(Index: Integer): Byte; 

procedure SetMinIP(Index: Integer; Value: Byte); 

function GetMaxIP(Index: Integer): Byte; 

procedure SetMaxIP(Index: Integer; Value: Byte); 

function GetlPString: string; 

procedure SetlPString(Value: string); 

function IsBlank: boolean; 

procedure SetCurrentFieldfIndex: Integer); 

// 

procedure CreateParams(var Params: TCreateParams); override; 

procedure CreateWnd; override; 

//procedure KeyDown(var Key: Word; Shift: TShiftState);override; 

function IPDwordToString(dw: DWORD): string; 

function IPStringToDword(s: string): DWORD;  

public 

{ Public declarations } 

constructor Create(AOwner: TComponent);  

override; 

property IP[Index: Integer]: byte read GetIP write SetIP; 

property MinIP[Index: Integer]: byte read GetMinIP write SetMinIP; 

property MaxIP[Index: Integer]: byte read GetMaxIP write SetMaxIP; 

property IPString : string read GetlPString write SetlPString; 

property CurrentField : Integer read FCurrentField write SetCurrentField; 

 procedure Clear; 

end; 

TIPEdit = class(TCustomlPEdit) 

published 

property Align; 

property Anchors; 

property BorderWidth; 

property DragCursor; 

property DragKind; 

property DragMode; 

property Enabled; 

property Font; 

property Hint; 

property Constraints; 

property ParentShowHint; 

property PopupMenu; 

property ShowHint; 

property TabOrder; 

property TabStop; 

property Visible; 

property OnContextPopup; 

property OnDragDrop; 

property OnDragOver; 

property OnEndDock; 

property OnEndDrag; 

property OnEnter; 

property OnExit; 

property OnMouseDown; 

property OnMouseMove; 

property OnMouseUp; 

property OnStartDock; 

property OnStartDrag; 

{ Published declarations } 

property IPString;  

end; 

procedure Register; 

implementation 

uses Graphics, commctrl, comctrls; 

constructor TCustomlPEdit.Create(AOwner: TComponent);  

begin 

inherited Create(AOwner); 

FIPAddress := 0; 

ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks, csOpaque]; 

Color := clBtnFace; 

Width := 160; 

Height := 25; 

Align := alNone; 

TabStop := True; end; 

procedure TCustomlPEdit.CreateParams(var Params: TCreateParams); 

 begin 

InitCommonControl(ICC_INTERNET_CLASSES);  

inherited CreateParams(Params); CreateSubClass(Params, WC_IPADDRESS);  

with Params do  

begin 

Style := WS_VISIBLE or WS_BORDER or WS_CHILD; 

if NewStyleControls and CtlSD then 

begin 

Style := Style and not WS_BORDER; ExStyle := ExStyle or WS_EX_CLIENTEDGE;  

end;  

end; 

 end; 

procedure TCustomlPEdit.CreateWnd; 

 var i: Integer;  

begin 

inherited CreateWnd; Clear; 

{ for i := 0 to 3 do 

 begin 

MinIP[i] := 0; MaxIP[i] := $FF; end; } 

CurrentField := 0; 

 end; 

procedure TCustomlPEdit.WMGetDlgCode(var Message: TWMGetDlgCode); 

 begin 

inherited; 

Message.Result := {Message.Result or} DLGC_WANTTAB;  

end; 

procedure TCustomlPEdit.CNNotify(var Message: TWMNotify); 

 begin 

with Message.NMHdr" do 

 begin case Code of 

IPN_FIELDCHANGED : begin 

FCurrentField := PNMIPAddress(Message.NMHdr)~.iField; {if Assigned(OnlpFieldChange) then 

with PNMIPAdress(Message.NMHdr)^ do begin  

OnIPFieldChange(Self, iField, iValue);} 

 end;  

end;  

end;  

end; 

(procedure TCustomlPEdit.KeyDown(var Key: Word; Shift: TShiftState);  

begin 

inherited KeyDown(Key, Shift); 

 if Key = VKJTAB then if ssShift in Shift then 

CurrentField := (CurrentField -1+4) mod 4 

 else 

CurrentField := (CurrentField + I) mod 4; end; } 

{procedure TCustomlPEdit.CMWantSpecialKey(var Msg: TCMWantSpecialKey);  

begin 

inherited; 

//Msg.Result := Ord(Char(Msg.CharCode) = #9) ; end;} 

procedure TCustomlPEdit.CMDialogChar(var Message: TCMDialogChar);  

begin with Message do 

if CharCode = VKJTAB then  

begin 

Message.Result := 0; if GetKeyState(VK_SHIFT)<>0 then  

begin 

if (CurrentField=0) then Exit; CurrentField := CurrentField — 1; 

 end 

else  

begin 

if (CurrentField=3) then Exit; CurrentField := CurrentField + 1;  

end; 

Message.Result := 1; end //VK_TAB  

else 

inherited; end; 

{procedure TCustomlPEdit.CMDialogKey(var Message: TCMDialogKey);  

begin 

if (Focused or Windows.IsChild(Handle, Windows.GetFocus))  

and 

(Message.CharCode = VK_TAB) and (GetKeyState(VK_CONTROL) < 0) then  

begin  

if GetKeyState (VK_SHIFT) 00 then 

CurrentField := (CurrentField -1+4) mod 4  

else 

CurrentField := (CurrentField + 1) ir.oci 4; Message.Result := 1;  

end else 

inherited; end; } 

function TCustomlPEdit.GetIP(Index: Integer): Byte; 

 begin 

SendMessage 

(Handle,IPM_GETADDRESS,0,longint(@FipAddress)); 

case Index of 

1 : Result := FIRST_IPADDRESS(FipAddress); 

2 : Result := SECOND_IPADDRESS(FipAddress) ; 

3 : Result := THIRD_IPADDRESS(FipAddress); 

4 : Result := FOURTH_IPADDRESS(FipAddress); else Result := 0;  

end; 

 end; 

procedure TCustomlPEdit.SetIP(Index: Integer; Value: Byte); 

 begin 

 case Index of 

1: FIPAddress := FIPAddress AND $FFFFFF or DWORD(Value) shl 24; 

2: FIPAddress := FIPAddress AND $FFOOFFFF or DWORD(Value) shl 16; 

3: FIPAddress := FIPAddress AND $FFFFOOFF or DWORD(Value) shl 8; 

4: FIPAddress := FIPAddress AND $FFFFFFOO or DWORD(Value); 

else Exit; 

 end; 

SendMessage(Handle, IPM_SETADDRESS, 0, FIPAddress);  

end; 

function TCustomlPEdit.GetMinIP(Index: Integer): Byte; begin if (Index<0) or (Index>3) then 

Result := 0 

else 

Result := LoByte(FIPLimits[Index]); 

 end; 

procedure TCustomlPEdit.SetMinIP(Index: Integer; Value: Byte);  

begin 

if (Index<0) or (Index>3) 

 then Exit; 

FIPLimits[Index] := MAKEIPRANGE(HiByte(FIPLimits[Index]), Value); 

SendMessage(Handle, IPM_SETRANGE, Index, FIPLimits[Index]); 

 end; 

function TCustomlPEdit.GetMaxIP(Index: Integer): Byte; begin if (Index<0) or (Index>3)  

then 

Result := 0  

else 

Result := HiByte(FIPLimits[Index]); 

 end; 

procedure TCustomlPEdit.SetMaxIP(Index: Integer; Value: Byte); 

 begin 

if (Index<0) or (Index>3) then Exit; 

FIPLimits[Index] := MAKEIPRANGE(Value, LoByte(FIPLimits[Index])); 

SendMessage(Handle, IPM_SETRANGE, Index, FIPLimits[Index]); 

 end; 

procedure TCustomlPEdit.Clear, 

 begin 

SendMessage(Handle, IPM_CLEARADDRESS, 0, 0);  

end; 

function TCustomlPEdit.IsBlank: boolean; 

 begin 

Result:= SendMessage(Handle, IPM_ISBLANK, 0, 0) = 0;  

end; 

procedure TCustomlPEdit.SetCurrentField(Index: Integer);  

begin 

if (Index<0) or (Index>3) 

 then Exit; 

FCurrentField := Index; 

SendMessage(Handle, IPM_SETFOCUS, wParam(FCurrentField), 0) ; 

 end; 

function TCustomlPEdit.IPDwordToString(dw: DWORD): string; 

 begin 

Result := Format('%d.%d.%d.%d', 

[FIRST_IPADDRESS(dw), 

SECOND_IPADDRESS(dw), 

THIRD_IPADDRESS(dw), 

FOURTH_IPADDRESS(dw)]); 

 end; 

function TCustomlPEdit.IPStringToDword(s: string): DWORD;  

var i,j : Integer; 

NewAddr, Part : DWORD; 

begin 

NewAddr := 0;  

try 

i := 0; repeat 

j := PosC. ', s); if j<=l then if i<3 then 

Abort else 

Part := StrToInt(s) else 

Part := StrToInt(Copy(s, I, j-1)); 

 if Part>255 then Abort; Delete(s, 1, j); 

NewAddr := (NewAddr shl 8) or Part;  

Inc(i);  

until i>3;  

Result := NewAddr; 

//Windows.MessageBox(0, pChar(IntToHex(FIPAddress, 8)), '', MB_Ok);  

except end; 

end; 

function TCustomlPEdit.GetlPString: string; 

 begin 

SendMessage(Handle,IPM_GETADDRESS, 0, longint(SFIPAddress)); 

Result := IpDwordToString(FIPAddress);  

end; 

procedure TCustomlPEdit.SetlPString(Value: string); 

 begin 

FIPAddress := IPStringToDword(Value); 

SendMessage(Handle, IPM_SETADDRESS, 0, FIPAddress);  

end; 

procedure Register;  

begin 

RegisterComponents('Samples', [TIPEdit]);  

end; 

end. 

Для удобства пользования полезно было бы добавить к компоненту CustomiPEdit задание диапазона для каждого из четырех составляющих и средства преобразования текстовой строки в двоичный адрес. Но это уже совсем другая история, к библиотеке ComQ132 отношения не имеющая.

Категория: Статьи участников клуба | Просмотров: 2979 | Добавил: delphi | Рейтинг: 0.0/0 |
Всего комментариев: 121 2 »
0
12 KtipolkOl   [Материал]
Человек, индивид, личность человек - есть не что иное, как понятие родовое, в котором отражаются общие черты, присущие всему человеческому роду.

0
11 Спешу всем рассказать!   [Материал]
Привет!
Вам уже знакома соц.сеть - ГДЕ И ВСЕ?
Это уникальная социальная сеть! Регистрируйся и получай деньги на свой счет! 120 тыс. за месяц, это не предел. Все участники объеденины в огромную единую сеть и безкорыстно помогают друг-другу.
Я не уговариваю Вас, но это стоящий проект, если вам интересно, и хотите стать финансово независимыми, то узнайте подробнее - http://www.gdeiwse.ru

0
10 Всё горбатишься на дядю?   [Материал]
Здравствуйте! :)
Кто хочет кучу денег? Пока еще есть такая возможность, станьте финансово независимыми!
Я не навязываю, но если вас заинтересовало, то ознакомьтесь подробнее пока поезд не ушел - http://youmyprofi.ru/4/index.html

0
9 виконання рішення суду   [Материал]
http://ukrsud.info Наш портал - информационный ресурс, призванный посодействовать любому человеку в получении достоверных сведений по вопросам воплощения защиты собственных законных интересов.
http://ukrsud.info/reshenie-suda-po-isku-prokurora-korostyshevskogo - несельскохозяйственного
Мы провели обобщения судебной практики Украины.
http://ukrsud.info/reshenie-suda-po-isku-o-priznanii-nedejstvitelnymi - региональных языков
Судебная практика включает организацию, процесс и итоги работы судов по осуществлению правосудия, но первее всего объектом ее обобщения является правоприменительная работа судов, обзор качества судебной работы.
http://ukrsud.info/reshenie-suda-po-isku-obshhestva-s-ogranichennoj-31 - 3 настоящего Договора в полном объеме
Благодаря применению прогрессивных поисковых технологий, у Вас появилась возможность мгновенно ознакомиться с существующей судебной практикой по аналогичным делам и сделать вывод, в чью пользу формируется современная украинская судебная практика.
http://ukrsud.info/reshenie-suda-po-isku-berdyanskogo - Соответствии с требованиями ст

0
8 Это интересно   [Материал]
Приветствую! :)
Вы уже тут или работаете на своего босса? Пока еще есть такая возможность, станьте финансово независимыми!
Я не заставляю, но если вам интересно, то узнайте подробнее пока еще есть такой шанс - http://a-ham.ru/9/index.html

0
7 steetrora   [Материал]
кофеварка delonghi запчасти
кофеварка екатеринбург
купить кофеварка morphy richards 47011
кофеварка delonghi bar 14f отзывы
кофеварка эспрессо delonghi
кофеварка krups 880
кружка кофеварка

0
6 steetrora   [Материал]
anal wet plump
blonde anal slave
viscious girls gone anal
anal erotic torture
deep gay anal
marie twins anal
am i gay anal

0
5 Suitflolf   [Материал]
http://cellulit.webservis.ru/apelsinovoe-maslo-cellulit%20.html - апельсиновое масло целлюлит
http://cellulit.webservis.ru/ubrat-cellulit%20.html - Как избавиться от целюлита на ягодицах и бедрах в домашних условиях
http://cellulit.webservis.ru/kto-zakazyval-disk-po-borbe-s-cellulitom%20.html - Целлюлит в 20 лет как избавиться быстро
http://cellulit.webservis.ru/cellulit-u-zvzd%20.html - целлюлит у звёзд
http://cellulit.webservis.ru/gel-protiv-cellulita%20.html - гель против целлюлита

0
4 tolleysleebra   [Материал]
корсеты во владимире
Барнаул толстовка
idea интернет магазин
[URL=http://cityclothes.edu.ms - молодежная спортивная одежда интернет магазин [/URL -
[URL=http://unic-clothes.edu.ms - футболки bad boy [/URL -
[URL=http://quickly-shirts.edu.ms - интернет магазин одежды комбинезоны [/URL -
интернет магазин детской праздничной одежды
маленькие футболки
бонприкс интернет магазин одежды россия
[URL=http://rarejackets.edu.ms - интерьер магазина одежды [/URL -
[URL=http://russianshirts.edu.ms - магазин женских рубашек [/URL -

0
3 tolleysleebra   [Материал]
детская одежда из белоруссии оптом
одежда в тольятти
футболки на заказ с петербург
[URL=http://cloth4you.edu.ms - керри интернет магазин [/URL -
[URL=http://russianshirt.edu.ms - надписи на футболках на мальчишник [/URL -
[URL=http://moscow-shirts.edu.ms - интернет магазин одежды сумы [/URL -
ветровки интернет магазин
модная мужская одежда оптом
прикольные футболки купить через интернет
[URL=http://moscowshirts.edu.ms - интернет магазин таможенного конфиската одежды [/URL -
[URL=http://funnyshirts.edu.ms - интернет магазин китайской одежды отзывы [/URL -

1-10 11-12
Имя *:
Email *:
Код *:
Меню сайта

Разделы новостей
Программные обеспечения [6]
Учебники и справочники Delphi [15]
Лабораторные работы [2]
Статьи участников клуба [36]
Советы и трюки [1]

Календарь новостей
«  Февраль 2009  »
ПнВтСрЧтПтСбВс
      1
2345678
9101112131415
16171819202122
232425262728

Поиск

Друзья сайта

Мини-чат

Наш опрос
Какой раздел нужно добавить на сайт и на форум?
Результаты | Архив опросов
Всего ответов: 57

Статистика
Copyright MyCorp © 2022