unit D_Ajouter_un_blob; {écrit par denis bertin le 2 mars le l'an de grâce 2013}
{Pour ajouter des paramètres de dessin des formes en blob dans un dialogue facile à utiliser}
{améliorer pour placer une liste box - de type owner draw pour afficher des textures par denis Bertin}
interface
uses wbase,windows,whelp,g_base,c_color,dialbase,messages,u_object,dialplan;
type
TRec_size_and_color = record
int_width:longint;
int_offset_horizontal:longint;
int_offset_vertical:longint;
bool_ajouter_un_cadre:bool;
list_texture:u_object.metalist;
index_texture:integer;
color_du_blob:tcolorRef;
end;
Tcolor_blob_button = class(c_color.Tcolor_degra_button)
function get_color:longint; override;
end;
TTexture_name = class(u_object.node)
constructor create(un_nom:string);
public
son_nom:string;
end;
Tajouter_un_blob = class(dialplan.Tdialog_with_owner_liste_dialog)
constructor Create(parent:wbase.twindow);
procedure Setupwindow; override;
procedure Ajuster_la_fenetre;
procedure Lecture_liste_texture;
procedure WMCommand(var Msg: TMessage); override;
procedure WMSet_painture_control(var Msg: messages.TMessage); override;
procedure WMMEASUREITEM(var Msg: TMessage); override;
procedure Drawitem(data:PDRAWITEMSTRUCT); override;
private
Check_ajouter_un_cadre:wbase.TCheckbox;
list_texture:wbase.TListBox;
col_texture:u_object.metalist;
private
le_rectangle,rect_ok:trect;
private
offset_horizontal,
offset_vertical:dialbase.TNumEdit_plus_moins; {denis B}
end;
var Rec_size_and_color : TRec_size_and_color;
var un_Texture_name : TTexture_name = nil;
implementation
uses wutil,sysutils,dialtexture,wmenuk,graphics;
function Tcolor_blob_button.get_color:longint;
begin
get_color:=D_Ajouter_un_blob.Rec_size_and_color.color_du_blob;
end;
constructor TTexture_name.create(un_nom:string);
var apc,pc_full_name_texture:pc1024;
p:pchar;
begin
inherited create;
self.son_nom:=un_nom;
strpcopy(apc,self.son_nom);
p:=strpos(apc,wutil.kpc_equal);
if p<>nil then
begin
p^:=#0;
strcat(apc,wmenuk.point_bmp);
wutil.get_exe_path(pc_full_name_texture);
Strcat(pc_full_name_texture,dialtexture.kpc_path_texture);
Strcat(pc_full_name_texture,apc);
{$ifdef debug}
box(0,pc_full_name_texture);
{$endif debug}
son_nom:=strpas(pc_full_name_texture);
end;
end;
const kid_ajouter_un_cadre = 400;
kid_liste_texture_identifiant = 300;
constructor Tajouter_un_blob.Create(parent:wbase.twindow);
const dial_id_dial_blob = 1820;
kid_int_width_du_trait = 100;
kid_color_blob = 200;
kid_int_offset_horizontal = 500;
kid_int_offset_vertical = 501;
var apc_nom_de_ce_dialogue:pc100;
begin
loadstring(hinstance,dial_id_dial_blob,
apc_nom_de_ce_dialogue,pred(sizeof(apc_nom_de_ce_dialogue)));
inherited Create(parent,apc_nom_de_ce_dialogue,0);
TransferBuffer:=@Rec_size_and_color;
dialbase.TNumEdit_plus_moins.Create(self,kid_int_width_du_trait,3,1,999,0);
offset_horizontal:=dialbase.TNumEdit_plus_moins.Create(self,kid_int_offset_horizontal,3,1,999,0);
offset_vertical:=dialbase.TNumEdit_plus_moins.Create(self,kid_int_offset_vertical,3,1,999,0);
Check_ajouter_un_cadre:=wbase.TCheckbox.create(self,kid_ajouter_un_cadre,0);
list_texture:=wbase.TListBox.create(self,kid_liste_texture_identifiant,100,0);
Tcolor_blob_button.Create(self,kid_color_blob,0);
un_Texture_name:=nil;
end; {Tajouter_un_blob.Create}
procedure Tajouter_un_blob.Setupwindow;
begin
inherited Setupwindow;
GetWindowRect(self.hwindow,self.le_rectangle);
GetClientRect(getitemhandle(id_ok),rect_ok);
self.lecture_liste_texture;
self.Ajuster_la_fenetre;
end; {Tajouter_un_blob.Setupwindow}
procedure Tajouter_un_blob.Ajuster_la_fenetre;
begin
if Check_ajouter_un_cadre.GetCheck=bf_checked then
begin
movewindow(self.hwindow,
(getsystemmetrics(SM_CXSCREEN)-(le_rectangle.right-le_rectangle.left)) div 2,
(getsystemmetrics(SM_CYSCREEN)-(le_rectangle.bottom-le_rectangle.top)) div 2,
le_rectangle.right-le_rectangle.left,
le_rectangle.bottom-le_rectangle.top,True);
showwindow(getitemhandle(500),sw_show);
showwindow(getitemhandle(501),sw_show);
showwindow(getitemhandle(600),sw_show);
showwindow(getitemhandle(601),sw_show);
offset_horizontal.un_plus_moins.show(sw_show);
offset_vertical.un_plus_moins.show(sw_show);
with rect_ok do movewindow(getitemhandle(id_ok),40,349,right-left,bottom-top,true);
end
else
begin
movewindow(self.hwindow,
(getsystemmetrics(SM_CXSCREEN)-(le_rectangle.right-le_rectangle.left)) div 2,
(getsystemmetrics(SM_CYSCREEN)-(le_rectangle.bottom-le_rectangle.top)) div 2,
le_rectangle.right-le_rectangle.left,146,True);
showwindow(getitemhandle(500),sw_hide);
showwindow(getitemhandle(501),sw_hide);
showwindow(getitemhandle(600),sw_hide);
showwindow(getitemhandle(601),sw_hide);
offset_horizontal.un_plus_moins.show(sw_hide);
offset_vertical.un_plus_moins.show(sw_hide);
with rect_ok do movewindow(getitemhandle(id_ok),170,85,right-left,bottom-top,true); {écrit par denis bertin}
end;
end; {Tajouter_un_blob.Ajuster_la_fenetre}
procedure Tajouter_un_blob.lecture_liste_texture;
var pc_full_name_texture:wutil.pc1024;
File_of_texture:TextFile;
une_entree:string;
une_texture:D_Ajouter_un_blob.TTexture_name;
begin
self.col_texture:=u_object.metalist.create;
wutil.get_exe_path(pc_full_name_texture);
Strcat(pc_full_name_texture,dialtexture.kpc_path_texture);
strcat(pc_full_name_texture,'texture.txt');
{$ifdef debug}
box(self.hwindow,pc_full_name_texture);
{$endif debug}
if sysutils.fileexists(pc_full_name_texture) then
begin
AssignFile(File_of_texture, pc_full_name_texture);
FileMode := 0; {Accès en lecture seule au fichier }
Reset(File_of_texture);
While not Eof(File_of_texture) do
begin
readln(File_of_texture,une_entree);
une_texture:=D_Ajouter_un_blob.TTexture_name.create(une_entree);
if wutil.file_existe(pchar(une_texture.son_nom)) then
begin
list_texture.addstring(pchar(une_texture));
self.col_texture.Add(une_texture);
end;
end;
CloseFile(File_of_texture);
end;
end;
procedure Tajouter_un_blob.WMCommand(var Msg: TMessage);
var un_index:integer;
begin
inherited WMCommand(Msg);
case loword(Msg.WParam) of
kid_ajouter_un_cadre:Ajuster_la_fenetre;
kid_liste_texture_identifiant:
begin
if hiword(msg.wparam)=LBN_SELCHANGE then
begin
un_index:=list_texture.GetSelIndex;
if (un_index>=0) and (un_index<col_texture.count) then
begin
un_Texture_name:=TTexture_name(self.col_texture.at(un_index));
end;
end;
end;
end; {case}
enablewindow(getitemhandle(id_ok),(Check_ajouter_un_cadre.GetCheck=bf_unchecked)
or (Check_ajouter_un_cadre.GetCheck=bf_checked) and (un_Texture_name<>nil));
end; {Tajouter_un_blob.WMCommand}
procedure Tajouter_un_blob.wmset_painture_control(var Msg: TMessage);
begin
Rec_size_and_color.color_du_blob:=msg.lparam;
end;
procedure Tajouter_un_blob.WMMEASUREITEM(var Msg: TMessage);
const k_hauteur_item_texture = 32;
begin
PMEASUREITEMSTRUCT(msg.lparam).itemheight:=k_hauteur_item_texture;
end; {Tajouter_un_blob.WMMEASUREITEM}
procedure Tajouter_un_blob.Drawitem(data:PDRAWITEMSTRUCT);
var memdc:hdc;
before:hbitmap;
abm:graphics.tbitmap;
une_texture:D_Ajouter_un_blob.TTexture_name;
begin
with data^ do
begin
try
memdc:=createcompatibledc(hdc);
une_texture:=D_Ajouter_un_blob.TTexture_name(itemdata);
abm:=graphics.tbitmap.Create;
abm.LoadFromFile(une_texture.son_nom);
before:=selectobject(memdc,abm.Handle);
with rcitem do bitblt(hdc,left,top,right,bottom-top,memdc,0,0,SRCCOPY);
abm.free;
selectobject(memdc,before);
deletedc(memdc); //écrit par denis Bertin
except
end;
end;
end; {Tajouter_un_blob.Drawitem}
begin
Rec_size_and_color.int_width:=1;
Rec_size_and_color.int_offset_horizontal:=50;
Rec_size_and_color.int_offset_vertical:=50;
Rec_size_and_color.bool_ajouter_un_cadre:=false;
Rec_size_and_color.list_texture:=u_object.metalist.create;
Rec_size_and_color.index_texture:=0;
Rec_size_and_color.color_du_blob:=g_base.RGB_Jaune;
end.