Рисуем на компонентах по onPaint и рисуем греческие знаки без Юникода

Если вы попробуете что-либо отрисовать на контролах по их событию onPaint, то получите что-то вроде этого:

Код:

Add(Edit,6969958,329,224)
{
 Left=55
 Top=55
 Width=170
 Font=[MS Sans Serif,8,1,0,1]
 Point(PHandle)
 Point(Handle)
 Point(Width)
 Point(Height)
 Point(onPaint)
 link(onPaint,2055885:doOperation,[(463,244)(463,223)])
}
Add(Img_Rectangle,2605467,539,343)
{
 DrawSource=1
 Style=4
 LineStyle=2
 rX=2
 rY=2
 Color=8388608
 BgColor=12639424
 Point(Point1)
 Point(Point2)
 link(Bitmap,6969958:Handle,[(545,299)(349,299)])
 link(Point1,14630089:Point,[])
 link(Point2,16134061:Point,[])
}
Add(PointXY,16134061,560,294)
{
 link(X,2055885:Result,[])
 link(Y,8176782:Result,[(573,272)(615,272)])
}
Add(Math,2055885,560,217)
{
 OpType=1
 Op2=4
 ResultType=0
 link(onResult,8176782:doOperation,[])
 link(Op1,6969958:Width,[(566,205)(461,205)(461,274)(356,274)])
}
Add(Math,8176782,609,217)
{
 OpType=1
 Op2=4
 ResultType=0
 link(onResult,2605467:doDraw,[(653,223)(653,286)(527,286)(527,349)])
 link(Op1,6969958:Height,[(615,205)(489,205)(489,274)(363,274)])
}
Add(PointXY,14630089,553,154)
{
}
Add(Button,2806033,364,469)
{
 Left=60
 Top=95
 Width=135
 Height=80
 Font=[MS Sans Serif,18,1,0,1]
 Point(PHandle)
 Point(Handle)
 Point(Width)
 Point(Height)
 Point(onPaint)
 link(onPaint,15340353:doOperation,[(492,482)(492,503)])
}
Add(Img_Rectangle,6097536,567,637)
{
 Point1=196611
 DrawSource=1
 Style=7
 rX=2
 rY=2
 Color=255
 BgColor=16711680
 Point(Point1)
 Point(Point2)
 link(Bitmap,2806033:Handle,[(573,569)(377,569)])
 link(Point2,2877882:Point,[])
}
Add(PointXY,2877882,588,574)
{
 link(X,15340353:Result,[])
 link(Y,2848217:Result,[(601,552)(643,552)])
}
Add(Math,15340353,588,497)
{
 OpType=1
 Op2=3
 ResultType=0
 link(onResult,2848217:doOperation,[])
 link(Op1,2806033:Width,[(594,485)(489,485)(489,513)(384,513)])
}
Add(Math,2848217,637,497)
{
 OpType=1
 Op2=3
 ResultType=0
 link(onResult,6097536:doDraw,[(681,503)(681,573)(555,573)(555,643)])
 link(Op1,2806033:Height,[(643,485)(517,485)(517,513)(391,513)])
}
Add(Label,9765149,196,98)
{
 Left=225
 Top=155
 Width=87
 Height=17
 Caption="Объём,   V, мл   "
 Point(PHandle)
 Point(Handle)
 Point(onPaint)
 link(onPaint,5852594:doDraw,[(244,111)(244,167)])
}
Add(Img_Text,5852594,259,161)
{
 X=40
 DrawSource=1
 Font=[System,8,1,0,204]
 Text="D       x"
 link(Bitmap,9765149:Handle,[(265,145)(216,145)])
}

Причём интерактивные контролы типа Edit, Button при воздействии на них будут всё время сбрасывать вашу отрисовку - они не генерируют onPaint, например при наборе текста в Edit.

Когда-то здесь я уже пытался решить эту проблему через IC, с того времени вроде бы что-то поменяли (контролы перестали наглухл пропадать при попытке только лишь подключить точку onPaint), но надпись так и пропадает, интерактивные тоже ведут себя не лучшим образом.

Тот код я доделал, и вроде бы даже работает

Код:

Add(Edit,6969958,231,273)
{
 Left=55
 Top=55
 Width=170
 Font=[MS Sans Serif,8,1,0,1]
 Point(PHandle)
 Point(Handle)
 Point(Width)
 Point(Height)
}
Add(Img_Rectangle,2605467,441,392)
{
 DrawSource=1
 Style=4
 LineStyle=2
 rX=2
 rY=2
 Color=8388608
 BgColor=12639424
 Point(Point1)
 Point(Point2)
 link(Bitmap,6969958:Handle,[(447,348)(251,348)])
 link(Point1,14630089:Point,[])
 link(Point2,16134061:Point,[])
}
Add(PointXY,16134061,462,343)
{
 link(X,2055885:Result,[])
 link(Y,8176782:Result,[(475,321)(517,321)])
}
Add(Math,2055885,462,266)
{
 OpType=1
 Op2=4
 ResultType=0
 link(onResult,8176782:doOperation,[])
 link(Op1,6969958:Width,[(468,254)(363,254)(363,323)(258,323)])
}
Add(Math,8176782,511,266)
{
 OpType=1
 Op2=4
 ResultType=0
 link(onResult,2605467:doDraw,[(555,272)(555,335)(429,335)(429,398)])
 link(Op1,6969958:Height,[(517,254)(391,254)(391,323)(265,323)])
}
Add(PointXY,14630089,455,203)
{
}
Add(Button,2806033,252,588)
{
 Left=60
 Top=95
 Width=135
 Height=80
 Font=[MS Sans Serif,18,1,0,1]
 Point(PHandle)
 Point(Handle)
 Point(Width)
 Point(Height)
}
Add(Img_Rectangle,6097536,455,756)
{
 Point1=196611
 DrawSource=1
 Style=7
 rX=2
 rY=2
 Color=255
 BgColor=16711680
 Point(Point1)
 Point(Point2)
 link(Bitmap,2806033:Handle,[(461,688)(265,688)])
 link(Point2,2877882:Point,[])
}
Add(PointXY,2877882,476,693)
{
 link(X,15340353:Result,[])
 link(Y,2848217:Result,[(489,671)(531,671)])
}
Add(Math,15340353,476,616)
{
 OpType=1
 Op2=3
 ResultType=0
 link(onResult,2848217:doOperation,[])
 link(Op1,2806033:Width,[(482,604)(377,604)(377,632)(272,632)])
}
Add(Math,2848217,525,616)
{
 OpType=1
 Op2=3
 ResultType=0
 link(onResult,6097536:doDraw,[(569,622)(569,692)(443,692)(443,762)])
 link(Op1,2806033:Height,[(531,604)(405,604)(405,632)(279,632)])
}
Add(InlineCode,1778559,238,385)
{
 EventPoints=#77:onPaint=Происходит при необходимости отрисовать элемент, выдавая пустой поток|136:onMessage=Происходит при любом сообщении контролу, выдавая пустой поток (т.к. некоторые контролы при перерисовке не генерируют WM_PAINT)|
 DataPoints=#9:dtPHandle|
 Code=#15:unit HiAsmUnit;|0:|9:interface|0:|38:uses kol,Share,Debug,messages,windows;|0:|4:type|28: THiAsmClass = class(TDebug)|10:   private|28:    FBoolPaintEvent:boolean;|18:    FTimer:PTimer;|23:    FOldMes:TOnMessage;|33:    procedure _OnTimer(Obj:PObj);|61:    function _onMess(var Msg:TMsg; var Rslt:Integer):Boolean;|19:    procedure Work;|9:   public|22:    onPaint:THI_Event;|24:    onMessage:THI_Event;|24:    dtPHandle:THI_Event;|23:    constructor Create;|33:    destructor Destroy; override;|5: end;|0:|14:implementation|0:|31:destructor THiAsmClass.Destroy;|5:begin|65:// Этот костыль связан с некооректностью уничтожения класса в FPC|13:{$ifndef F_P}|15:   FTimer.Free;|8:{$endif}|21:   inherited Destroy;|4:end;|0:|31:constructor THiAsmClass.Create;|5:begin|18: inherited Create;|125: FTimer := NewTimer(1); //чтобы события IC выдать после полной отработки _onMess (Result := _hi_OnMessage(FOldMes,Msg,Rslt);)|25: FTimer.Enabled := false;|28: FTimer.OnTimer := _onTimer;|24: FBoolPaintEvent:=false;|15: InitAdd(Work);|4:end;|0:|27:procedure THiAsmClass.Work;|15:var c:PControl;|5:begin|42: c := PControl(ToIntegerEvent(dtPHandle));|30: if not assigned(c) then exit;|25: FOldMes :=  c.OnMessage;|24: c.OnMessage := _onMess;|25: FBoolPaintEvent := true;|130: _onTimer(FTimer); //Work проиходит, когда все контролы уже отрисованы, поэтому при запуске программы первое WM_PAINT не отловится|4:end;|0:|29:function THiAsmClass._onMess;|5:begin|20: case Msg.message of|44:  WM_PAINT: begin FBoolPaintEvent:=true end;|5: end;|24: FTimer.Enabled := true;|43: Result := _hi_OnMessage(FOldMes,Msg,Rslt);|4:end;|0:|31:procedure THiAsmClass._OnTimer;|5:begin|25: FTimer.Enabled := false;|55: if FBoolPaintEvent then _hi_OnEvent(onPaint); {без DC}|26: FBoolPaintEvent := false;|122: _hi_OnEvent(onMessage); //Некоторые контролы (Edit...) не выдают WM_PAINT при некоторых перерисовках (напр., ввод текста)|4:end;|0:|4:end.|
 link(onMessage,2055885:doOperation,[(366,398)])
 link(dtPHandle,6969958:PHandle,[])
}
Add(InlineCode,9456466,252,721)
{
 EventPoints=#77:onPaint=Происходит при необходимости отрисовать элемент, выдавая пустой поток|136:onMessage=Происходит при любом сообщении контролу, выдавая пустой поток (т.к. некоторые контролы при перерисовке не генерируют WM_PAINT)|
 DataPoints=#9:dtPHandle|
 Code=#15:unit HiAsmUnit;|0:|9:interface|0:|38:uses kol,Share,Debug,messages,windows;|0:|4:type|28: THiAsmClass = class(TDebug)|10:   private|28:    FBoolPaintEvent:boolean;|18:    FTimer:PTimer;|23:    FOldMes:TOnMessage;|33:    procedure _OnTimer(Obj:PObj);|61:    function _onMess(var Msg:TMsg; var Rslt:Integer):Boolean;|19:    procedure Work;|9:   public|22:    onPaint:THI_Event;|24:    onMessage:THI_Event;|24:    dtPHandle:THI_Event;|23:    constructor Create;|33:    destructor Destroy; override;|5: end;|0:|14:implementation|0:|31:destructor THiAsmClass.Destroy;|5:begin|65:// Этот костыль связан с некооректностью уничтожения класса в FPC|13:{$ifndef F_P}|15:   FTimer.Free;|8:{$endif}|21:   inherited Destroy;|4:end;|0:|31:constructor THiAsmClass.Create;|5:begin|18: inherited Create;|125: FTimer := NewTimer(1); //чтобы события IC выдать после полной отработки _onMess (Result := _hi_OnMessage(FOldMes,Msg,Rslt);)|25: FTimer.Enabled := false;|28: FTimer.OnTimer := _onTimer;|24: FBoolPaintEvent:=false;|15: InitAdd(Work);|4:end;|0:|27:procedure THiAsmClass.Work;|15:var c:PControl;|5:begin|42: c := PControl(ToIntegerEvent(dtPHandle));|30: if not assigned(c) then exit;|25: FOldMes :=  c.OnMessage;|24: c.OnMessage := _onMess;|25: FBoolPaintEvent := true;|130: _onTimer(FTimer); //Work проиходит, когда все контролы уже отрисованы, поэтому при запуске программы первое WM_PAINT не отловится|4:end;|0:|29:function THiAsmClass._onMess;|5:begin|20: case Msg.message of|44:  WM_PAINT: begin FBoolPaintEvent:=true end;|5: end;|24: FTimer.Enabled := true;|43: Result := _hi_OnMessage(FOldMes,Msg,Rslt);|4:end;|0:|31:procedure THiAsmClass._OnTimer;|5:begin|25: FTimer.Enabled := false;|55: if FBoolPaintEvent then _hi_OnEvent(onPaint); {без DC}|26: FBoolPaintEvent := false;|122: _hi_OnEvent(onMessage); //Некоторые контролы (Edit...) не выдают WM_PAINT при некоторых перерисовках (напр., ввод текста)|4:end;|0:|4:end.|
 link(onMessage,15340353:doOperation,[(380,734)(380,622)])
 link(dtPHandle,2806033:PHandle,[])
}

Как я уже говорил, они не выдают onPaint, например, при наборе текста или нажатии на кнопку, поэтому приходится перерисовывать свои декорации при каждом входящем сообщении Но хотя бы так.

А вод надпись выделывается меньше, поэтому отрисовывается всегда по onPaint в моём IC, можно использовать именно это событие. Но мы попробуем не просто что-то порисовать, а вставить туда некоторые часто необходимые в программах символы, которые без Юникода (а hiasm его не поддерживает) не вставишь.

Достигается это несложно - нужно лишь использовать шрифт Symbol, в нём достаточно разных греческих (дельта, мю) и математических (интеграл, неравенство) символов в диапазоне обычного ascii. Нужно открыть таблицу символов (Пуск - Выполнить - charmap.exe), выставить шрифт Symbol, выбрать нужный символ, запомнить его номер внизу, затем перключиться на обычный шрифт типа TimesNewRoman и найти там символ с таким же кодом. В обычном шрифте символ можно будет набрать с клавиатуры, что мы и сделаем в компоненте Img_Text, а шрифт в нём выберем - Symbol. После этого останется лишь отрисовать его в нужном месте надписи.

Код:

Add(Label,9765149,756,259)
{
 Left=225
 Top=155
 Width=87
 Height=17
 Caption="Объём,   V, мл   "
 Point(PHandle)
 Point(Handle)
}
Add(Img_Text,5852594,819,322)
{
 X=40
 DrawSource=1
 Font=[Symbol,8,1,0,2]
 Text="D       x"
 link(Bitmap,9765149:Handle,[(825,306)(776,306)])
}
Add(InlineCode,16479294,763,322)
{
 EventPoints=#77:onPaint=Происходит при необходимости отрисовать элемент, выдавая пустой поток|136:onMessage=Происходит при любом сообщении контролу, выдавая пустой поток (т.к. некоторые контролы при перерисовке не генерируют WM_PAINT)|
 DataPoints=#9:dtPHandle|
 Code=#15:unit HiAsmUnit;|0:|9:interface|0:|38:uses kol,Share,Debug,messages,windows;|0:|4:type|28: THiAsmClass = class(TDebug)|10:   private|28:    FBoolPaintEvent:boolean;|18:    FTimer:PTimer;|23:    FOldMes:TOnMessage;|33:    procedure _OnTimer(Obj:PObj);|61:    function _onMess(var Msg:TMsg; var Rslt:Integer):Boolean;|19:    procedure Work;|9:   public|22:    onPaint:THI_Event;|24:    onMessage:THI_Event;|24:    dtPHandle:THI_Event;|23:    constructor Create;|33:    destructor Destroy; override;|5: end;|0:|14:implementation|0:|31:destructor THiAsmClass.Destroy;|5:begin|65:// Этот костыль связан с некооректностью уничтожения класса в FPC|13:{$ifndef F_P}|15:   FTimer.Free;|8:{$endif}|21:   inherited Destroy;|4:end;|0:|31:constructor THiAsmClass.Create;|5:begin|18: inherited Create;|125: FTimer := NewTimer(1); //чтобы события IC выдать после полной отработки _onMess (Result := _hi_OnMessage(FOldMes,Msg,Rslt);)|25: FTimer.Enabled := false;|28: FTimer.OnTimer := _onTimer;|24: FBoolPaintEvent:=false;|15: InitAdd(Work);|4:end;|0:|27:procedure THiAsmClass.Work;|15:var c:PControl;|5:begin|42: c := PControl(ToIntegerEvent(dtPHandle));|30: if not assigned(c) then exit;|25: FOldMes :=  c.OnMessage;|24: c.OnMessage := _onMess;|25: FBoolPaintEvent := true;|130: _onTimer(FTimer); //Work проиходит, когда все контролы уже отрисованы, поэтому при запуске программы первое WM_PAINT не отловится|4:end;|0:|29:function THiAsmClass._onMess;|5:begin|20: case Msg.message of|44:  WM_PAINT: begin FBoolPaintEvent:=true end;|5: end;|24: FTimer.Enabled := true;|43: Result := _hi_OnMessage(FOldMes,Msg,Rslt);|4:end;|0:|31:procedure THiAsmClass._OnTimer;|5:begin|25: FTimer.Enabled := false;|55: if FBoolPaintEvent then _hi_OnEvent(onPaint); {без DC}|26: FBoolPaintEvent := false;|122: _hi_OnEvent(onMessage); //Некоторые контролы (Edit...) не выдают WM_PAINT при некоторых перерисовках (напр., ввод текста)|4:end;|0:|4:end.|
 link(onPaint,5852594:doDraw,[])
 link(dtPHandle,9765149:PHandle,[])
}

Отредактировано 3042 (2025-05-02 00:01:09)

HiAsm - Конструктор программ

Меню навигации

Пользовательские ссылки

Информация о пользователе

Рисуем на компонентах по onPaint и рисуем греческие знаки без Юникода

Сообщений 1 страница 1 из 1

Поделиться12025-05-01 04:53:03