Задача в общем: Есть объект "TExercise = class(TImage)" - олицетворяет одно занятие в учебном учреждении,
есть список всех занятий "TExercisesList = class", в котором соответственно "Exercise:PExercise" - указатель на текущее
активное занятие.
Список и объекты создаются нормально (проверено в debug-ере), но как только я пытаюсь нарисовать текущее занятие,
вылетает ошибка знакомая пожалуй всем: "Access vialation ...".
По дебагеру отследил где происходит метаморфоз: при заходе в процедуру "procedure TExercisesList.Draw(const FromIndex: integer);",
а точнее, когда выделяется память под переменные, объявленные в var, т.е. "var AlsoWidth,AlsoHeight:integer;".
Я следил в дебагере, когда эти переменные инициализуруются, то весь текущий Exercise толи сдвигается, то ли
затирается, вообщем указатель начинает указывать на полный бред.
Что у меня тут не так??? Вот в чём вопрос =)
Вот код:
| Код |
type PExercise = ^TExercise;
TExercise = class(TImage)
private
FidExercise:integer;
FMove:boolean;
protected
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer);override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
public
Hours:byte;
Next:PExercise;
Prior:PExercise;
BorderColor:TColor;
Color:TColor;
Caption:TText;
ExtraCaption:TExtraCaption;
constructor Create(AOwner:TComponent;const idExercise:integer;
const Text:string; const Amount:byte;
const Color:TColor); reintroduce; overload;
destructor Destroy; override;
procedure Draw(const Left,Top,Width,Height:integer);
procedure Hide;
published
property IdExersice:Integer read FidExercise write FidExercise;
end;
type TExercisesList = class
private
FEmpty:boolean;
FFirst:PExercise;
FLast:PExercise;
FVisibleCount:integer;
FFirstVisibleIndex:integer;
FCount:integer;
function MoveTo(Index:integer):boolean;
function CanDraw:integer;
protected
public
Parent:TWinControl;
Exercise:PExercise;
IntervalHeight:integer;
IntervalWidth:integer;
Width:integer;
Height:Integer;
constructor Create(AOwner: TWinControl);
destructor Destroy; override;
procedure Next;
procedure Prior;
procedure Last;
procedure First;
procedure Add(const idExercise:integer; const Text:string;
Amount:byte; const Color:TColor);
procedure Delete(const Index:integer);
procedure Draw(const FromIndex:integer);
procedure DrawNext;
procedure DrawPrior;
procedure HideAll;
procedure Clear;
published
property Count:integer read FCount;
end;
|
Вот реализация классов:
| Код |
{ TExercise }
{$REGION 'TExercise'}
constructor TExercise.Create(AOwner:TComponent; const idExercise: integer;
const Text:string; const Amount: byte;const Color:TColor);
begin
inherited Create(AOwner);
FidExercise := idExercise;
FMove := False;
Visible := False;
Transparent := False;
Next := nil;
Prior := nil;
Caption.Text := Text;
Self.Color := Color;
Hours := Amount;
if Hours > 0 then
begin
ExtraCaption.Caption.Text := inttostr(Hours);
ExtraCaption.Visible := true;
end
else ExtraCaption.Visible := false;
end;
destructor TExercise.Destroy;
begin
inherited;
end;
procedure TExercise.Draw(const Left,Top,Width,Height:integer);
var Text:string;
begin
Self.Left := Left;
Self.Top := Top;
Self.Width := Width;
Self.Height := Height;
with Canvas do
begin
Brush.Color := Color;
//Печатаем основной текст по центру
FillRect(ClientRect);
Canvas.Font := Caption.Font;
Text := Caption.Text;
TextOut((Width-TextWidth(Text)) div 2,
(Height-TextHeight(Text)) div 2,Text);
//Печатаем дополнительный текст внизу справа,
//если нужно
if ExtraCaption.Visible
then
begin
Canvas.Font := ExtraCaption.Caption.Font;
Text:= ExtraCaption.Caption.Text;
TextOut(Width-TextWidth(Text)-1,
Height-TextHeight(Text)-1, Text);
end;
end;
Visible := True;
end;
procedure TExercise.Hide;
begin
Visible := False;
end;
procedure TExercise.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
end;
procedure TExercise.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
end;
procedure TExercise.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited;
if Button=mbLeft then FMove := not(FMove);
if Button=mbRight then FMove := false;
if FMove then Screen.Cursor := crDrag else Screen.Cursor := crDefault;
end;
{$ENDREGION}
{ TExercisesList }
{$REGION 'TExercisesList'}
procedure TExercisesList.Add(const idExercise:integer;const Text:string;
Amount:byte; const Color:TColor);
var New : TExercise;
begin
inc(FCount);
New := TExercise.Create(Parent,idExercise,Text,Amount,Color);
New.Parent := Parent;
//Если список пуст
if (FEmpty)
then
begin
FFirst := @New;
FEmpty := false;
end
// Если список не пуст
else
begin
FLast := @New;
Exercise.Next := @New;
Exercise.Prior := Exercise;
end;
FLast := @New;
Exercise := @New;
end;
function TExercisesList.CanDraw: integer;
var AmountByHoriz,AmountByVert:integer;
begin
//Кол-во занятий по горизонтали
AmountByHoriz:=Ceil(Parent.Width / (1.5*IntervalWidth+Width));
//Кол-во занятий по вертикали
AmountByVert:=Ceil(Parent.Height /(1.5*IntervalHeight+Height));
Result := AmountByHoriz*AmountByVert;
end;
procedure TExercisesList.Clear;
var i:integer;
begin
if FEmpty then Exit;
for I := 0 to Count - 1 do
Delete(i);
end;
constructor TExercisesList.Create(AOwner: TWinControl);
begin
inherited Create;
Parent := AOwner;
FEmpty := True;
FVisibleCount:=0;
FFirstVisibleIndex := -1;
FFirst := nil;
FLast := nil;
FCount := 0;
Height := 24;
Width := 64;
IntervalHeight := 5;
IntervalWidth := 5;
end;
procedure TExercisesList.Delete(const Index: integer);
var Visible:boolean;
begin
if not(MoveTo(Index))then exit;
dec(FCount);
if Exercise.Visible then dec(FVisibleCount);
Visible := Exercise.Visible;
Exercise.Visible := False;
if FLast=FFirst then
begin
FFirst.Destroy;
FFirst := nil;
FLast := nil;
FFirstVisibleIndex := -1;
FEmpty := true;
exit;
end;
if Exercise=FLast then
begin
FLast := FLast.Prior;
FLast.Next := nil;
Exercise.Destroy;
if Visible then Draw(FFirstVisibleIndex);
exit;
end;
if Exercise=FFirst then
begin
FFirst := FFirst.Next;
FFirst.Prior := nil;
Exercise.Destroy;
if Visible then Draw(0);
exit;
end;
Exercise.Next.Prior := Exercise.Prior;
Exercise.Prior.Next := Exercise.Next;
Exercise.Destroy;
if Visible then Draw(FFirstVisibleIndex);
end;
destructor TExercisesList.Destroy;
begin
Clear;
inherited;
end;
procedure TExercisesList.Draw(const FromIndex: integer);
var AlsoWidth,AlsoHeight:integer;//ВОТ ТУТ НАЧИНАЕТСЯ НЕЛАДНОЕ!!!!!!!!!!!!!
begin
HideAll;
FFirstVisibleIndex := -1;
FVisibleCount:=0;
if not(MoveTo(FromIndex)) then exit;
AlsoWidth:=IntervalWidth;
AlsoHeight:=IntervalHeight;
while Height+AlsoHeight+IntervalHeight<Parent.Height do
begin
if Width+AlsoWidth+IntervalWidth>Parent.Width
then AlsoHeight:=AlsoHeight+Height+IntervalHeight
else
begin
Exercise.Draw(AlsoWidth,AlsoHeight,Width,Height);
inc(FVisibleCount);
AlsoWidth:=AlsoWidth+Width+IntervalWidth;
end;
end;
if FVisibleCount>0 then FFirstVisibleIndex:=FromIndex;
end;
procedure TExercisesList.DrawNext;
var FromIndex:integer;
begin
//Определяем индекс первого прорисовываемого занятия
FromIndex:=FFirstVisibleIndex+CanDraw;
//Если следующий индекс занятия превосходит
//кол-во всех занятий, то выходим
if FromIndex>Count-1 then exit;
Draw(FromIndex);
end;
procedure TExercisesList.DrawPrior;
var FromIndex:integer;
begin
//Определяем индекс первого прорисовываемого занятия
FromIndex:=FFirstVisibleIndex-CanDraw;
//Если индекс меньше первого, то выходим
if FromIndex<0 then exit;
Draw(FromIndex);
end;
procedure TExercisesList.First;
begin
Exercise := FFirst;
Draw(0);
end;
procedure TExercisesList.HideAll;
var i,a:integer;
begin
if FFirstVisibleIndex = -1 then exit;
//Переходим на первое видимое занятие
if FFirstVisibleIndex = 0
then Exercise := FFirst
else for a := 0 to FFirstVisibleIndex do Next;
//Прячем все видимые занятия
for I := FFirstVisibleIndex to FVisibleCount +FFirstVisibleIndex do
begin
Exercise.Hide;
Next;
end;
//Переходим на первое занятие в списке
Exercise := FFirst;
end;
procedure TExercisesList.Last;
begin
Exercise := FLast;
end;
function TExercisesList.MoveTo(Index: integer):boolean;
var i:integer;
begin
//Проверка на границы диапозона
if (Index<0) or FEmpty or (Index>=Count)
then
begin
Result := False;
exit;
end;
Exercise:=FFirst;
for I := 0 to Index-1 do
begin
Exercise:=Exercise.Next;
end;
Result := True;
end;
procedure TExercisesList.Next;
begin
Exercise := Exercise.Next;
end;
procedure TExercisesList.Prior;
begin
Exercise := Exercise.Prior;
end;
{$ENDREGION}
|
Модули, необходимые для компиляции:
| Код |
uses Forms, Math, SysUtils, Graphics, ExtCtrls, Classes, Types, Messages, Controls;
|
Вот, что я делаю:
| Код |
...
var List:TExercisesList;
...
//Ну и по нажатью кнопки, например:
List := TExercisesList.Create(Panel1);
List.Add(13,'MyText',5,clRed);
List.Draw(0);
|
|
из этого же аттача...
