آیا استفاده از (Crete(nil مجازه؟

[mbshareat]

سلام
من برای ترسیم ظاهر یه کامپوننت از نوع TGraphicControl یه چنین کدی دارم:

procedure DrawRectPrompt(AControl:TControl;Can:TCanvas;R:TRe ct;APrompt:String;Fnt:TFont);
Var
..
PromptMemo:TMemo;
begin
PromptMemo := TMemo.Create(nil);
with PromptMemo do
begin
Visible:=False;
Parent:=TWinControl(AControl.Owner);
..
End;
..
PromptMemo.Free;
End;
وقتی کامپوننتم رو که یه جور Label هست به نقطه گوشه چپ بالا می بردم تصویر مرتب ترسیم میشد یعنی یه Memo در اون ناحیه ترسیم میشد و همچنین کامپوننتم هم مرتب ترسیم میشد.(اسم این حالت رو نمی دونم اما زیاد باهاش برخورد کردم!)
چه کامپوننت رو از TCustomControl مشتق می گرفتم چه از TGraphicControl با این مشکل مواجه بودم.
در کد اولیه PromptMemo := TMemo.Create(AControl.Parent); داشتم
ولی حالا که پارامتر رو به nil تغییر دادم دیگه لرزش تصویر و تصویر Memo در محیط طراحی ندارم!
سوالم اینه که چرا اون اتفاق می افتاد و یا حد اقل اینطور پارامتر دادن مشکل ساز نیست؟

[Felony]

سوالم اینه که چرا اون اتفاق می افتاد
من تا به حال همچین مشکلی ندیدم .


حد اقل اینطور پارامتر دادن مشکل ساز نیست؟
تو کد جنابعالی خیر ، البته کدت جای بحث داره که پایین بهش رسدگی میکنیم ;) ؛ وظیفه اصلی Owner این هست که موقع آزاد شدن Child هاش رو هم آزاد کنه ، شما برای شئ که از کلاس TMemo مشتق میکنی Owner در نظر نگرفتی ولی عوضش خودت وظیفه مدیریت حافظه و آزاد سازی شئ ساخته شده رو بر عهده گرفتی و تا اینجا مشکلی نیست .

* اصولا توی رویدادهای رسم رابط کاربری نباید از کدهای سنگین ، عملیات های زمان بر ، تخصیص حافظه و ... زیاد استفاده کرد چون این رویدادها با کوچکترین تغییراتی به مراتب صدا زده میشن و پردازش کدها بار زیادی رو به Main Thread که وظیفه به روز رسانی رابط کاربری رو برعهده داره تحمیل میکنه و گاهی بسته به شرایط مختلف ( مشخصات سخت افزاری سیستم مقصد ، تعداد برنامه ها و میزان حافظه اشغال شده ، تعداد Thread هایی که در پروسه های مختلف در حال اجرا هستن ، Priority این تردها ، تعداد سیکل هایی که از پردازنده میگیرن و ... ) میتونه Main Thread رو با کمبود تعداد سیکل های اختصاصی از سمت پردازنده و ... مواجه کنه و نتیجش هم پرش تصویر در بعضی موارد هست .

بنابراین وقتی دارید کامپوننت های Visual مینویسید یکی از بخش هایی که باید روی بهینه سازی کدهای اون خیلی وقت بزارید رویداد های رسم GUI هستن ، تو اون کد عملیات تخصیص و آزاد سازی حافظه شما بارها و بارها در طول چند ثانیه ممکنه اجرا بشه و این یعنی سربار برای سیستم ، ممکنه کدتون بدون هیچ مشکلی اجرا بشه ولی به هیچ عنوان همچین کدی قابل قبول نیست .

کاری که شما باید انجام بدید این هست که به شیئتون یک Owner اختصاص بدید تا وظیقه آزاد سازی شئ به گردن مالکش بیافته یا اگر کدتون با تعریف Owner مشکل داره تو Constructor مربوط به کامپوننت یک بار این شئ رو بسازید و در Destructor هم آزادش کنید تا این سربار به سیستم تحمیل نشه .

موفق باشید .

[BORHAN TEC]

سلام
اون لرزش ممکنه که در حالات مختلفی اتفاق بیفته ولی طبق تجربه یکی از شایع ترین موارد این است که در جاهایی که یه جورایی به ترسیم کامپوننت مربوطه ربط دارد(Paint، CreateWnd و ...) بیش از یک بار از دستور Inherited استفاده کرده باشید.
حالت دیگر هم این است که شما با رویدادها و یا متدهایی سر و کار داشته باشید که با اجرای مثلاً رویداد A رویداد B صدا زده شود و رویداد B هم رویداد A را صدا بزند. در این حالت یک حلقه بی نهایت اجرا می شود که این کدها دائم اجرا می شوند. به نظر می رسد که شما در قسمت هایی از این کامپوننت همین اشتباه را کرده اید.
حالت دیگر هم این است که شما متد OnPain و یا ... را به صورت Recursive پیاده سازی کرده باشید. یعنی موقعی که رویداد A اجرا می شود، مجدداً خودش را فرا خوانی می کند و این مورد تا بی نهایت اتفاق می افتد. دقیقاً مثل اینکه در رویداد Onchange یک TMemo از کد زیر استفاده کنید:
procedure TForm1.Memo1Change(Sender: TObject);
begin
Memo1.Lines.Append('a');
Sleep(100);
Application.ProcessMessages;
end;
حال فقط کافی است که یک کاراکتر در این Memo تایپ کنید تا ببینید که چه اتفاقی خواهد افتاد.:متعجب:
موفق باشید...

[mbshareat]

از راهنمایی شما دو بزرگوار ممنونم
من توی Paint چنین کدی دارم:

procedure TClrLabel.Paint;
Begin
Inherited Paint;
DrawRectPrompt(Self,Canvas,Canvas.ClipRect,Caption ,Font);
end;

میتونم یه Memo توی Create بسازم اما نمی دونم مساله اینقدر پیچیده هست؟
در هرصورت باید توی Paint محتوای اون Memo رو روی Canvas کامپوننتم ترسیم کنم.
آیا TMemo.Create اونقدر اتفاق میافته که نگران سرعت و حافظه باشم؟
مشکل در ترسیم تصویر فقط در زمان طراحی رخ میده و وقتی کاموننت رو به سمت چپ بالا ببرم ترسیم مجدد قطع نمیشه(شاید هم علتش فراخوانی بی وقفه Paint باشه!)
اگه Memo فقط یک بار ساخته شه و یک بار آزاد شه منطقی تره اما من هنوز نفهمیدم علت این پدیده که احتمالا بهش Flickr میگن چیه.
نمی دونم حوصله دارین کامپوننتم رو بررسی کنین یانه؟ توقعی ندارم اما اگه لطف می کنین این کدشه:
TClrLabel= class(TGraphicControl)
Private
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
public
constructor Create(AOwner: TComponent);Override;
procedure Paint;OverRide;
Published
property Anchors;
Property Font;
Property AutoSize;
property Caption;
property ShowHint;
Function TagLine(TagNo:Integer):Integer;
Procedure SetTopLine(LineNo:Integer);
end;
...
procedure DrawTextX(S:String;Can:TCanvas;R:TRect;Var C:TColor;EngMode:Boolean=False);
Var
I:SmallInt;
X:SmallInt;
FarsiWord,TmpStr:String;
DrawNow:Boolean;
F:TFont;
procedure SetTahoma();
begin
//!ÞÑÂä Øå ÚÏÏ æ ÑÇäÊÒ äÏÇÑÏ
If (F.Name='QuranTaha') Then
Begin
Can.Font.Name:='Tahoma';
Can.Font.Size:=F.Size-3;
R.Top:=R.Top+12;
End;
end;
procedure SetQuranTaha();
begin
If (F.Name='QuranTaha') Then
Begin
Can.Font.Assign(F);
R.Top:=R.Top-12;
End;
end;
Begin
F:=TFont.Create;
F.Assign(Can.Font);
SetBkMode(Can.Handle, TRANSPARENT);
S:=S+' ';{ke Hame ra kamel be-nevisad!}
If EngMode=True then
ValidateParantez(S);
FarsiWord:='';
X:=R.Right-5;
TmpStr:='';
I:=1;
Repeat
DrawNow:=False;
If I=length(S) Then
DrawNow:=True
Else If S[I]=' ' Then//Farsi Or English Sentence!
Begin
if TmpStr='' Then
DrawNow:=True
Else If (CharType(TmpStr[Length(TmpStr)])=CharType(S[I+1]))
And (CharType(S[I])<3) Then
TmpStr:=TmpStr+' '
Else
DrawNow:=True;
End
Else If CharType(S[I])=3 Then //Dots
DrawNow:=True
Else
TmpStr:=TmpStr+S[I];
If DrawNow=True Then
Begin
If TmpStr<>'' Then
Begin
Case CharType(Trim(TmpStr)[1]) Of
1://Farsi
Can.Font.Color:=C;
2://English
Can.Font.color:=$FF0000;
4://Number
Can.Font.Color:=$6600;
End;
If CharType(Trim(TmpStr)[1])<>1 Then
SetTahoma;
SetFontToClearType(Can.Font);
Dec(X,Can.TextWidth(TmpStr));
Can.TextOut(X+1,R.Top,TmpStr);
If CharType(Trim(TmpStr)[1])<>1 Then
SetQuranTaha;
End;
TmpStr:='';
If Pos(Copy(S,I,3),'<-><R><G><B>')>0 Then
Begin
If Copy(S,I,3)='<R>' Then
C:=$DD
Else If Copy(S,I,3)='<G>' Then
C:=$6600
Else If Copy(S,I,3)='<B>' Then
C:=$FF0000
Else If Copy(S,I,3)='<->' Then
C:=clBlack;
I:=I+2;//+Inc(I)=+3!
End
Else
Begin
SetTahoma;
//Dot And Space!
If Pos(S[I],'<>-\/')>0 then
Can.Font.Color:=clBlue
Else
Can.Font.Color:=clRed;
SetFontToClearType(Can.Font);
Dec(X,Can.TextWidth(S[I]));
Can.TextOut(X+1,R.Top,S[I]);
SetQuranTaha;
End;
End;
Inc(I);
Until I>length(S);
Can.Font:=F;
F.Free;
End;
procedure DelTags(var APrompt:String;Var Tag:Array Of Char;Var TagNo:Byte);
Var
I:SmallInt;
begin
TagNo:=0;
For I:=Length(APrompt) DownTo 1 Do
//<->:clBlack!
If Pos(Copy(APrompt,I,3),'<R><G><B><->')>0 then
Begin
Inc(TagNo);
Tag[TagNo]:=APrompt[I+1];
Delete(APrompt,I,3);
//!#157=Nim Fasele!
Insert(#157,APrompt,I);
End;
end;
procedure RestoreTags(PromptMemo:TMemo;var APrompt:String;Const Tag:Array Of Char;Const TagNo:Byte);
Var
I,N:SmallInt;
begin
If TagNo=0 Then
Exit;
APrompt:='';
For I:= 0 To PromptMemo.Lines.Count-1 Do
APrompt:=APrompt+PromptMemo.Lines[I]+#13#10;
N:=0;
for I:=Length(APrompt) Downto 1 do
If APrompt[I]=#157 Then
Begin
Inc(N);
Delete(APrompt,I,1);//Del #157
Insert('<'+Tag[N]+'>',APrompt,I);
End;
PromptMemo.WordWrap:=False;
PromptMemo.Text:=APrompt;
end;
procedure SetFontToClearType(const aFont: TFont);
var
LogFont: TLogFont; TempFont: TFont;
begin
TempFont:= TFont.Create;
try
TempFont.Assign(aFont);
GetObject(TempFont.Handle, sizeof(LogFont), @LogFont);
LogFont.lfQuality := 5;
TempFont.Handle:= CreateFontIndirect(LogFont);
aFont.Assign(TempFont);
finally
TempFont.Free;
end;
end;
procedure DrawRectPrompt(AControl:TControl;Can:TCanvas;R:TRe ct;APrompt:String;Fnt:TFont);
Var
I,H:Word;
C:TColor;
Tag:Array[0..255] Of Char;
TagNo:Byte;
PromptMemo:TMemo;
begin
APrompt:=StringReplace(APrompt,#13#10,#13,[rfReplaceAll]);
APrompt:=StringReplace(APrompt,#10#13,#13,[rfReplaceAll]);
APrompt:=StringReplace(APrompt,#10,#13,[rfReplaceAll]);
APrompt:=StringReplace(APrompt,#13,#13#10,[rfReplaceAll]);
DelTags(APrompt,Tag,TagNo);
PromptMemo := TMemo.Create(nil);
with PromptMemo do
begin
Visible:=False;
Parent:=TWinControl(AControl.Owner);
Width:=R.Right-R.Left+1;
Font.Assign(Fnt);
SetFontToClearType(PromptMemo.Font);
WordWrap := True;
BidiMode:=bdRightToLeft;
Text:= APrompt;
end;
RestoreTags(PromptMemo,APrompt,Tag,TagNo);
Can.Font.Assign(Fnt);
SetFontToClearType(Can.Font);
C:=clBlack;
H:=Can.TextHeight('á');
If (Can.Font.Name='QuranTaha') Then
H:=H-13;
AControl.Height:=H*PromptMemo.Lines.Count+2;
For I:=0 To PromptMemo.Lines.Count-1 Do
If PromptMemo.Lines[I]<>'' then
DrawTextX(GoodEnglish(PromptMemo.Lines[I])
,Can,Rect(R.Left,R.Top+I*H
,R.Left+PromptMemo.Width
,R.Top+I*H+H),C);
PromptMemo.Free;
End;
{ TClrLabel }

constructor TClrLabel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
SetParent(TWinControl(AOwner));
bidimode:=bdLeftToRight;
end;

procedure TClrLabel.Paint;
Begin
Inherited Paint;
DrawRectPrompt(Self,Canvas,Canvas.ClipRect,Caption ,Font);
end;
function TClrLabel.TagLine(TagNo: Integer): Integer;
begin

end;
procedure TClrLabel.SetTopLine(LineNo: Integer);
begin

end;

procedure TClrLabel.CMFontChanged(var Message: TMessage);
begin
Invalidate;
end;
procedure TClrLabel.CMTextChanged(var Message: TMessage);
begin
Invalidate;
end;

من برای تعیین رنگ متن از کارکترهای R,G,B داخل <> استفاده کردم.که برای تنظیم شکسته شدن سطر موقتا سه کارکتر تگ رنگ رو با کارکتر 157 جایگزین می کنم و باز رنگها رو بر می گردونم!

[BORHAN TEC]

این خیلی واضح است که مشکل از رویداد onPain است. اگر توجه کنید خواهید دید که این تابع تقریباً شبیه به همان مثالی است که در پست قبلی ام قرار دادم، به عبارتی دیگر شما این رویداد را به صورت بازگشتی Recursive پیاده سازی کرده اید.

[mbshareat]

آقای عشایری ممکنه واضح تر بفرمایین.
منظورتون اینه که Inherited Paint; رو باید بردارم؟
من هنوز نمی دونم کار دقیق Inherited چیه؟
درسته کاری که توی کلاس والد تعریف شده انجام میده ولی چه کاری نمی دونم.
به نظرتون قبلا بدون Inherited توی Paint بقایای ترسیمات قبلی از بین میره؟

[mbshareat]

می بخشید من یه تغییراتی توی کد دادم اما بهتر نشد:


constructor TClrLabel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
SetParent(TWinControl(AOwner));
bidimode:=bdLeftToRight;
PromptMemo:= TMemo.Create(Self);
PromptMemo.Visible:=false;
PromptMemo.Parent:=TWinControl(Self.Owner);
PromptMemo.Visible:=false;
end;
destructor TClrLabel.Destroy;
begin
PromptMemo.Free;
inherited;
end;
procedure TClrLabel.Paint;
Begin
//Inherited Paint;
DrawRectPrompt(Self,Canvas,Canvas.ClipRect,PromptM emo,Caption,Font);
end;

پروسیجر ترسیم ظاهر کامپوننت هم به تناسب تغییر دادم:

procedure DrawRectPrompt(AControl:TControl;Can:TCanvas;R:TRe ct;M:TMemo;APrompt:String;Fnt:TFont);
Var
I,H:Word;
C:TColor;
Tag:Array[0..255] Of Char;
TagNo:Byte;
begin
APrompt:=StringReplace(APrompt,#13#10,#13,[rfReplaceAll]);
APrompt:=StringReplace(APrompt,#10#13,#13,[rfReplaceAll]);
APrompt:=StringReplace(APrompt,#10,#13,[rfReplaceAll]);
APrompt:=StringReplace(APrompt,#13,#13#10,[rfReplaceAll]);
DelTags(APrompt,Tag,TagNo);
with M do
begin
Width:=R.Right-R.Left+1;
Font.Assign(Fnt);
SetFontToClearType(M.Font);
//ÊäÙíã ãÍÊæÇí ÓØÑåÇ
WordWrap := True;
BidiMode:=bdRightToLeft;
Text:= APrompt;
end;
RestoreTags(M,APrompt,Tag,TagNo);
Can.Font.Assign(Fnt);
SetFontToClearType(Can.Font);
C:=clBlack;
H:=Can.TextHeight('á');
If (Can.Font.Name='QuranTaha') Then
H:=H-13;
AControl.Height:=H*M.Lines.Count+2;
For I:=0 To M.Lines.Count-1 Do
If M.Lines[I]<>'' then
DrawTextX(GoodEnglish(M.Lines[I])
,Can,Rect(R.Left,R.Top+I*H
,R.Left+M.Width
,R.Top+I*H+H),C);
End;


همیشه در محیط طراحی یه Memo گوشه چپ بالا هست که وقتی کامپوننت رو روش ببرم ترسیم پی در پی رو موجب میشه!
علاوه بر این وقت آزاد کردن PromptMemo ایراد می گیره:

ٍException EAccessViolation in module Project1.exe at 00000000.
Access violation at address 00000000.Read of address 00000000.