Форум: "Основная";
Текущий архив: 2007.03.11;
Скачать: [xml.tar.bz2];

Вниз

SavedCheckBox   Найти похожие ветки 

← →
i-am-vladko ©   (2007-01-12 13:30) [0]

Хочу создать CheckBox, некоторый интерфейс которого невозможно изменить из другого приложения, если флаг UnSaved = FALSE - вот что есть...
unit uSavedCheckBox;

interface

uses Classes, StdCtrls, Controls;

type
 TSavedCheckBox = class(TCheckBox)
 private
   FState: TCheckBoxState;
   FTabOrder: Integer;
   FOnClick: TNotifyEvent;
   FUnSaved : boolean;
   procedure SetChecked(Value: Boolean); override;
   function GetChecked: Boolean; override;
   procedure Click; override;
   function IsCaptionStored: Boolean; overload;
   function IsCheckedStored: Boolean; overload;
   function IsOnClickStored: Boolean; overload;
   procedure SetState(const Value: TCheckBoxState); overload;
   function GetUnSaved: boolean;
   procedure SetUnSaved(const Value: boolean);
   function GetOnClick: TNotifyEvent;
   procedure SetOnClick(const Value: TNotifyEvent);
 public
   property UnSaved: boolean read GetUnSaved write SetUnSaved;
   constructor Create(AOwner: TComponent); override;
 published
   property Checked: Boolean read GetChecked write SetChecked stored IsCheckedStored default False;
   property State: TCheckBoxState read FState write SetState default cbUnchecked;
   property OnClick: TNotifyEvent read GetOnClick write SetOnClick stored IsOnClickStored;
   property TabOrder;
   property Action;
   property Alignment;
   property AllowGrayed;
   property Anchors;
   property BiDiMode;
   property Caption;
   property Color;
   property Constraints;
   property Ctl3D;
   property DragCursor;
   property DragKind;
   property DragMode;
   property Enabled;
   property Font;
   property ParentBiDiMode;
   property ParentColor;
   property ParentCtl3D;
   property ParentFont;
   property ParentShowHint;
   property PopupMenu;
   property ShowHint;
   property TabStop;
   property Visible;
   property OnContextPopup;
   property OnDragDrop;
   property OnDragOver;
   property OnEndDock;
   property OnEndDrag;
   property OnEnter;
   property OnExit;
   property OnKeyDown;
   property OnKeyPress;
   property OnKeyUp;
   property OnMouseDown;
   property OnMouseMove;
   property OnMouseUp;
   property OnStartDock;
   property OnStartDrag;
 end;

procedure Register;

implementation

procedure Register;
begin
 RegisterComponents("alpha", [TSavedCheckBox]);
end;

{ TSavedCheckBox }

procedure TSavedCheckBox.Click;
begin
 if GetUnSaved
   then inherited Click
   else
    begin
     FUnSaved := TRUE;
     Checked := not Checked;
     FUnSaved := FALSE;
    end;
end;

constructor TSavedCheckBox.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 SetUnSaved(FALSE);
end;

function TSavedCheckBox.GetChecked: Boolean;
begin
 Result := inherited GetChecked;
end;

function TSavedCheckBox.GetOnClick: TNotifyEvent;
begin
 Result := FOnClick;
end;

function TSavedCheckBox.GetUnSaved: boolean;
begin
 Result := (csDesigning in ComponentState) or
           (csWriting in ComponentState) or
           (csLoading in ComponentState) or
            FUnSaved;
end;

function TSavedCheckBox.IsCaptionStored: Boolean;
begin
 Result := (self as TControl).IsCaptionStored;
end;

function TSavedCheckBox.IsCheckedStored: Boolean;
begin
 Result := (self as TButtonControl).IsCheckedStored;
end;

function TSavedCheckBox.IsOnClickStored: Boolean;
begin
 Result := TRUE;
end;

procedure TSavedCheckBox.SetChecked(Value: Boolean);
begin
 if GetUnSaved then inherited;
end;

procedure TSavedCheckBox.SetOnClick(const Value: TNotifyEvent);
begin
 if GetUnSaved then FOnClick := Value;
end;

procedure TSavedCheckBox.SetState(const Value: TCheckBoxState);
begin
 if GetUnSaved then inherited;
end;

procedure TSavedCheckBox.SetUnSaved(const Value: boolean);
begin
 if (csDesigning in ComponentState)
   then FUnSaved := TRUE
   else FUnSaved := Value;
end;

end.


Проблема - Delphi выбрасывает при попытке компиляции. Уважаемые Мастера, подскажите из-за чего.

---

← →
Сергей М. ©   (2007-01-12 16:15) [1]

> подскажите из-за чего


Из-за ошибки в тексте программы.

Какой конкретно - это военная тайна.

---

← →
i-am-vladko ©   (2007-01-13 16:16) [2]

> Сергей М. ©   (12.01.07 16:15) [1]


> Какой конкретно - это военная тайна.

mda...

---

← →
i-am-vladko ©   (2007-01-15 14:29) [3]

в какой хоть стороне искать?

---

← →
Amoeba ©   (2007-01-15 14:42) [4]

> Проблема - Delphi выбрасывает при попытке компиляции.

Неужели при этом ничего при этом не сообщает и не показывает некомпилируемую строку в тексте программы?

---

← →
Сергей М. ©   (2007-01-15 14:44) [5]

> в какой хоть стороне искать?


Просто разуй глаза, почитай внимательно сообщение компилятора и вникни в то о чем он тебе говорит

---

← →
i-am-vladko ©   (2007-01-15 16:30) [6]

Stack overlow - и из-за чего...

---

← →
Сергей М. ©   (2007-01-15 16:39) [7]

Переполнение стека.

В ран-тайм возникает, как правило, при бесконечной рекурсии.

При компиляции возникнуть может лишь теоретически при наличии ошибок в самом компиляторе, что к твоему случаю никоим образом не относится.

---

← →
Плохиш ©   (2007-01-15 16:40) [8]

> i-am-vladko ©   (12.01.07 13:30)  
> Проблема - Delphi выбрасывает при попытке компиляции.


> i-am-vladko ©   (15.01.07 16:30) [6]
> Stack overlow - и из-за чего...

Не люблю врунов...

---

← →
icWasya ©   (2007-01-15 17:21) [9]

Вот я этот текст скомпилировал [D5]- 3 варнинга и один хинт, и никаких ShackOverflow :)

---

← →
i-am-vladko ©   (2007-01-16 10:44) [10]

одну рекурсию увидел -
    Checked := not Checked;
изменил на    
    SetChecked(not GetChecked);
и опять 25...

---

← →
i-am-vladko ©   (2007-01-16 18:37) [11]

tak vse-taki, v 4em delo?

---

← →
trust   (2007-01-16 18:39) [12]

насколько мне кажется что в разделе Private вроде нельзя переопределять родительские методы..(   procedure SetChecked(Value: Boolean); override;
  function GetChecked: Boolean; override;) если они есть у предка то они должны быть переопределены в разделе protected или я не прав..

---

← →
i-am-vladko ©   (2007-01-16 18:39) [13]

ya perenes ih v razdel protected - snova tozhe...

---

← →
trust   (2007-01-16 18:46) [14]

А, что за ошибку пишет то?

---

← →
i-am-vladko ©   (2007-01-16 18:52) [15]

бросаю компонент на форму - Stack Overlow и выбрасывает Delphi
есть только 3 Warnings что :

  procedure SetChecked(Value: Boolean); override;
  function GetChecked: Boolean; override;
  procedure Click; override;

hides virtual methods in base class

---

← →
i-am-vladko ©   (2007-01-16 18:54) [16]

это в 7
в Delphi 5 про стек ничего не говорит.
точно также выбрасывает при компиляции

---

← →
Virgo_Style ©   (2007-01-16 20:18) [17]

Отладчиком пользоваться религия не велит?

---

← →
trust   (2007-01-16 20:28) [18]

Ты много пишешь!? но не разу не написал, что именно выдает в качестве ошибки компилятор..?

---

← →
vidiv ©   (2007-01-16 21:23) [19]

> насколько мне кажется что в разделе Private вроде нельзя
> переопределять родительские методы

можно...

The reintroduce directive suppresses compiler warnings about hiding previously declared virtual methods

---

← →
trust   (2007-01-16 21:29) [20]

и что ты этим буржуйским выражением хочешь сказать?

---

← →
vidiv ©   (2007-01-16 21:33) [21]

> trust   (16.01.07 21:29) [20]
> и что ты этим буржуйским выражением хочешь сказать?

если ты в своем классе в разделе private хочешь перекрыть метод родительского объекта из раздела public или protected, то желательно, дополнительно к override, указать директиву reintroduce , и подлый компилятор не будет тебя беспокоить своими бестолковыми варнингами по этому поводу. Вставляя эту директиву, ты ему, какбы, объясняешь, что понимаешь что делаешь =)

---

← →
_RusLAN ©   (2007-01-17 11:26) [22]

>[15] i-am-vladko(c) 16-Jan-2007, 18:52
>бросаю компонент на форму - Stack Overlow и выбрасывает
>Delphi

А вы попробуйте создать его в рантайме, поставте точку остановки в конструкторе, а дальше Ф7, Ф8.

---

← →
i-am-vladko ©   (2007-01-17 12:44) [23]

Run-time работает отлично.

unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, uSavedCheckBox, Stdctrls;

type
 TForm1 = class(TForm)
   procedure FormCreate(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var SCB : TSavedCheckBox;
begin
 SCB := TSavedCheckBox.Create(self);
 with SCB do
   begin
//      UnSaved := TRUE;  {если убрать // - должна быть реакция на нажатие и т.д. (см Source)}
     Parent := self;
     State := cbUnchecked;
     Checked := not Checked;
     OnClick := nil;
   end;
end;

end.

а как компонент - ну никак
привожу полный код

unit uSavedCheckBox;

interface

uses Classes, StdCtrls, Controls;

type
 TSavedCheckBox = class(TCheckBox)
 private
   FState: TCheckBoxState;
   FOnClick: TNotifyEvent;
   FUnSaved : boolean;
   function IsCaptionStored: Boolean; overload;
   function IsCheckedStored: Boolean; overload;
   function IsOnClickStored: Boolean; overload;
   procedure SetState(const Value: TCheckBoxState); overload;
   function GetUnSaved: boolean;
   procedure SetUnSaved(const Value: boolean);
   function GetOnClick: TNotifyEvent;
   procedure SetOnClick(const Value: TNotifyEvent);
 protected
   procedure SetChecked(Value: Boolean); reintroduce; override;
   function GetChecked: Boolean; reintroduce; override;
   procedure Click; reintroduce; override;
 public
   property UnSaved: boolean read GetUnSaved write SetUnSaved;
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
 published
   property Checked: Boolean read GetChecked write SetChecked stored IsCheckedStored default False;
   property State: TCheckBoxState read FState write SetState default cbUnchecked;
   property OnClick: TNotifyEvent read GetOnClick write SetOnClick stored IsOnClickStored;
   property TabOrder;
   property Action;
   property Alignment;
   property AllowGrayed;
   property Anchors;
   property BiDiMode;
   property Caption;
   property Color;
   property Constraints;
   property Ctl3D;
   property DragCursor;
   property DragKind;
   property DragMode;
   property Enabled;
   property Font;
   property ParentBiDiMode;
   property ParentColor;
   property ParentCtl3D;
   property ParentFont;
   property ParentShowHint;
   property PopupMenu;
   property ShowHint;
   property TabStop;
   property Visible;
   property OnContextPopup;
   property OnDragDrop;
   property OnDragOver;
   property OnEndDock;
   property OnEndDrag;
   property OnEnter;
   property OnExit;
   property OnKeyDown;
   property OnKeyPress;
   property OnKeyUp;
   property OnMouseDown;
   property OnMouseMove;
   property OnMouseUp;
   property OnStartDock;
   property OnStartDrag;
 end;

procedure Register;

implementation

procedure Register;
begin
 RegisterComponents("alpha", [TSavedCheckBox]);
end;

{ TSavedCheckBox }

procedure TSavedCheckBox.Click;
begin
 if GetUnSaved
   then inherited Click
   else
    begin
     FUnSaved := TRUE;
     SetChecked(not GetChecked);
     FUnSaved := FALSE;
    end;
end;

constructor TSavedCheckBox.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 SetUnSaved(FALSE);
end;

destructor TSavedCheckBox.Destroy;
begin
 inherited Destroy;
end;

function TSavedCheckBox.GetChecked: Boolean;
begin
 Result := inherited GetChecked;
end;

function TSavedCheckBox.GetOnClick: TNotifyEvent;
begin
 Result := FOnClick;
end;

function TSavedCheckBox.GetUnSaved: boolean;
begin
 Result := (csDesigning in ComponentState) or
           (csWriting in ComponentState) or
           (csLoading in ComponentState) or
            FUnSaved;
end;

function TSavedCheckBox.IsCaptionStored: Boolean;
begin
 Result := (self as TControl).IsCaptionStored;
end;

function TSavedCheckBox.IsCheckedStored: Boolean;
begin
 Result := (self as TButtonControl).IsCheckedStored;
end;

function TSavedCheckBox.IsOnClickStored: Boolean;
begin
 Result := TRUE;
end;

procedure TSavedCheckBox.SetChecked(Value: Boolean);
begin
 if GetUnSaved then inherited SetChecked(Value);
end;

procedure TSavedCheckBox.SetOnClick(const Value: TNotifyEvent);
begin
 if GetUnSaved then FOnClick := Value;
end;

procedure TSavedCheckBox.SetState(const Value: TCheckBoxState);
begin
 if GetUnSaved then inherited;
end;

procedure TSavedCheckBox.SetUnSaved(const Value: boolean);
begin
 if (csDesigning in ComponentState)
   then FUnSaved := TRUE
   else FUnSaved := Value;
end;

end.

помогите пожалуйста

---

← →
_RusLAN ©   (2007-01-17 13:48) [24]

Зацикливается функция:

function TSavedCheckBox.IsCheckedStored: Boolean;
begin
Result := (self as TButtonControl).IsCheckedStored;
end;

---

← →
Сергей М. ©   (2007-01-17 13:55) [25]

> i-am-vladko ©   (17.01.07 12:44) [23]


Self, reintroduce, overload - зачем все это ?

---

← →
_ruslan ©   (2007-01-17 14:05) [26]

>[24] _RusLAN(c) 17-Jan-2007, 13:48
>Зацикливается функция:
>
>function TSavedCheckBox.IsCheckedStored: Boolean;
>begin
>Result := (self as TButtonControl).IsCheckedStored;
>end;

TButtonControl = class(TWinControl)
 private
   FClicksDisabled: Boolean;
   FWordWrap: Boolean;
   function IsCheckedStored: Boolean;

Я так понимаю что строка

(self as TButtonControl).IsCheckedStored

вызывает метод IsCheckedStored не у TButtonControl, а у
TSavedCheckBox, что и приводит к бесконечному рекурсивному вызову.

---

← →
i-am-vladko ©   (2007-01-17 14:15) [27]

> Сергей М. ©   (17.01.07 13:55) [25]

в private секции действительно не нужны overload, а в protected & public [19]

---

← →
i-am-vladko ©   (2007-01-17 14:36) [28]

YPA!!!
получилось ))
Спасибо, _RusLAN - именно там и нужно было копать [24]
Спасибо всем кто помогал в обсуждении. Код работает.
Кому нужно стучитесь в личку - с радость поделюсь - ICQ 292-306-407

---

← →
Сергей М. ©   (2007-01-17 14:42) [29]

> интерфейс которого невозможно изменить из другого приложения

Ничто не мешает мне из своего приложения послать окну твоего чекбокса сообщение BM_SETCHECK. Твой компонент успешно получит его и успешно обработает, несмотря на все потуги с UnSaved.

---

← →
i-am-vladko ©   (2007-01-17 15:33) [30]

> Сергей М. ©   (17.01.07 14:42) [29]

Спасибо за замечание - сделаю обработчик message

---

← →
i-am-vladko ©   (2007-01-17 15:41) [31]

> i-am-vladko ©   (17.01.07 15:33) [30]

Вот уже сделал ))

---

Страницы: 1 вся ветка

Форум: "Основная";
Текущий архив: 2007.03.11;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.55 MB
Время: 0.079 c