unit glUI;
interface
uses gl,glu,glUtils,windows,graphics,classes,controls,sysutils,forms,extctrls,messages;
Const
EVENT_MOUSEDOWN = 1;
EVENT_MOUSEUP = 2;
EVENT_MOUSEMOVE = 3;
EVENT_RESIZE = 4;
RESULT_FALSE = 0;
RESULT_TRUE = 1;
RESULT_FALSE_BUT_NEEDS_REDRAW =3;
type
TRedrawProcedure = procedure() of object;
tglControlSet = class;
TScrollListItemAdditonalInfo = class (TObject)
private
FAlbumNumber : integer;
FTrackNumber : integer;
FImage : tobject;
icon : string;
public
property AlbumNumber : integer read FAlbumNumber write FAlbumNumber;
property TrackNumber : integer read FTrackNumber write FTrackNumber;
property picture : tobject read FImage write FImage;
end;
tmatrix = record
x1,y1,x2,y2 : integer;
item : integer;
end;
tglControl = class(TObject)
private
{ Private declarations }
frealworld : Tarea;
fNormal : tgl3DCoord;
fTexCoord : tglTexCoord;
fVertices : tglVertices;
fparent : TglControlSet;
ftexture : ttexture;
finteractive : boolean;
fenabled : boolean;
fname : string;
fnodraw : boolean;
procedure setparent(parent : TglControlSet);
function getparent : TglControlSet;
public
{ Public declarations }
property RealWord : tarea read frealworld;
property parent : TglControlSet read getparent write setparent;
property Vertices : tglVertices read fVertices write fVertices;
property Normal : tgl3DCoord read fNormal write fNormal;
property Texture : tglTexCoord read fTexCoord write fTexCoord;
property Name : string read fname write fname;
property enabled : boolean read fenabled write fenabled;
property nodraw : boolean read fnodraw write fnodraw;
constructor Create(parent : TglControlSet);
destructor Destroy; override;
procedure Paint; virtual;
procedure Resize; virtual;
function ProcessControl(Event : Byte) : byte;
procedure MouseUp(x,y : integer); virtual;
procedure MouseDown(x,y : integer); virtual;
procedure MouseMove(x,y : integer); virtual;
end;
tglBitmap = class(tglControl)
private
fbitmap : tbitmap;
procedure setbitmap(bmp : tbitmap);
public
constructor Create(parent : TglControlSet);
destructor Destroy; override;
procedure Paint; override;
procedure Resize; override;
property bitmap : tbitmap read fbitmap write setbitmap;
procedure loadfromfile(fn : string);
procedure loadfromresource(res : string);
end;
tglColourQuad = class(tglControl)
private
public
constructor Create(parent : TglControlSet);
destructor Destroy; override;
procedure Paint; override;
procedure Resize; override;
end;
tglLabel = class(tglControl)
private
bm : tbitmap;
fcaption : string;
FOnClick: TNotifyEvent;
ffont : tfont;
isdown : boolean;
procedure setlabel(s : string);
procedure setfont(_font : tfont);
public
constructor Create(parent : TglControlSet);
destructor Destroy; override;
procedure Paint; override;
procedure Resize; override;
property caption : string read fcaption write setlabel;
property OnClick : TNotifyEvent read FOnclick Write FOnClick;
property font : tfont read ffont write setfont;
procedure MouseUp(X, Y: Integer); override;
procedure MouseDown(X, Y: Integer); override;
end;
Treachedtop = procedure() of object;
Treachedend = procedure() of object;
tglListBox = class(tglControl)
private
bm : tbitmap;
//cachedimage : tbitmap;
addinfo : array of TScrollListItemAdditonalInfo;
addinfocount : integer;
upnormal,uppressed,downnormal,downpressed : tbitmap;
fremote : boolean;
fitems : tstringlist;
fcount : integer;
fitemindex : integer;
fcolor : Tcolor;
ffont : tfont;
flinespacing : single;
fmargin : integer;
fnumbercolor : tcolor;
fshownumbers : boolean;
ftopmost : integer;
fdisplayitems : integer;
itemheight : integer;
topborder : integer;
fdrawmode : boolean;
isdown : boolean;
matrix : array of tmatrix;
marked : integer;
repeattimer : ttimer;
clicked : boolean;
remoteused : boolean;
fscalescrolls : real;
fscrollwidths : integer;
freachedend : Treachedend;
freachedtop : Treachedtop;
fhighlight : boolean;
fhighlighteditem : integer;
fhighlightcolor : tcolor;
fhighlight2 : boolean;
fhighlighteditem2 : integer;
fhighlightcolor2 : tcolor;
fmoretext : string;
fmorebackgroundcolor: tcolor;
frealworldheight : integer;
frealworldwidth : integer;
xx,yy : integer;
ftag : integer;
FOnClick: TNotifyEvent;
procedure repeattimertimer(sender : tobject);
procedure setcolor(_color : tcolor);
procedure setfont(_font : tfont);
procedure setlinespacing(_value : single);
function cliptextout(buffer : Tbitmap;x,y : integer;st : string;no : integer;var numberextent : integer) : Tsize;
procedure itemschange(sender : tobject);
procedure setscrollwidths(sw : integer);
procedure settopmost(i : integer);
public
constructor Create(parent : TglControlSet);
destructor Destroy; override;
procedure Paint; override;
procedure Resize; override;
procedure MouseUp(X, Y: Integer); override;
procedure MouseDown(X, Y: Integer); override;
procedure MouseMove(X, Y: Integer); override;
procedure Click;
procedure StopFlicker(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure setitemindex(i : integer);
procedure scrollup;
procedure scrolldown;
procedure losefocus;
procedure remoteclick;
published
property OnClick : TNotifyEvent read FOnclick Write FOnClick;
procedure additemandinfo(s : string;album : integer;track : integer;picture : tobject;icon : string;data : string);
property color : Tcolor read Fcolor write setcolor default clred;
property items : tstringlist read fitems;// write setitems;
property itemindex : integer read fitemindex write setitemindex;
property font : tfont read ffont write setfont;
property linespacing : single read flinespacing write setlinespacing;
property margin : integer read fmargin write fmargin;
property showlabels : boolean read fshownumbers write fshownumbers;
property drawmode : boolean read fdrawmode write fdrawmode;
property numbercolor : tcolor read fnumbercolor write fnumbercolor;
property morebackgroundcolor : tcolor read fmorebackgroundcolor write fmorebackgroundcolor;
property count : integer read fcount;
property remote : boolean read fremote write fremote;
property scrollwidths : integer read fscrollwidths write setscrollwidths;
property OnReachedend : TReachedend read freachedend write freachedend;
property OnReachedtop : TReachedtop read freachedtop write freachedtop;
procedure clear;
procedure scrolltoend;
//property itemhint : TTransparentHint read Fitemhint write Fitemhint;
property highlightindex : boolean read fhighlight write fhighlight;
property highlightcolor : tcolor write fhighlightcolor;
property highlighteditem : integer read fhighlighteditem write fhighlighteditem;
property highlightindex2 : boolean read fhighlight2 write fhighlight2;
property highlightcolor2 : tcolor write fhighlightcolor2;
property highlighteditem2 : integer read fhighlighteditem2 write fhighlighteditem2;
property realworldwidth : integer read frealworldwidth write frealworldwidth;
property realworldheight : integer read frealworldheight write frealworldheight;
property topmost : integer read ftopmost write settopmost;
property displayitems : integer read fdisplayitems;
property moretext : string read fmoretext write fmoretext;
property tag : integer read ftag write ftag;
{ Published declarations }
end;
tglControlSet = class (TObject)
private
fcontrols : array of pointer;
fcontrolscount : Longword;
fparent : TWinControl;
fRedrawProcedure : TRedrawProcedure;
public
property parent : TWinControl read fparent write fparent;
procedure registercontrol(control : tglControl);
procedure unregistercontrol(control : tglControl);
function getcontrol(i : cardinal) : tglControl;
property controls : cardinal read fcontrolscount;
constructor Create (Owner : TWinControl);
destructor Destroy; override;
procedure Draw;
function ProcessControls(Event : Byte) : integer;
property RedrawProcedure : TRedrawProcedure read fRedrawProcedure write fRedrawProcedure;
end;
const
TIMERINTERVAL=250;
implementation
//uses opengltest;
//{$R icons.RES}
constructor tglControlSet.Create(Owner : TWinControl);
begin
parent:=owner;
setlength(fcontrols,0);
fcontrolscount:=0;
inherited create;
end;
destructor tglControlSet.Destroy;
begin
while (fcontrolscount>0) do begin
tglcontrol(fcontrols[0]).free;
end;
setlength(fcontrols,0);
inherited;
end;
procedure tglControlSet.registercontrol(control: tglControl);
begin
inc(fcontrolscount);
setlength(fcontrols,fcontrolscount);
fcontrols[fcontrolscount-1]:=control;
end;
procedure tglControlSet.unregistercontrol(control: tglControl);
var
n: Integer;
a : integer;
begin
a:=-1;
for n:=0 to fcontrolscount-1 do begin
if pointer(control)=fcontrols[n] then begin
a:=n;
break;
end;
end;
if (a=-1) then begin
exit;
end;
if (fcontrolscount>1) then begin
for n := a to fcontrolscount-2 do begin
fcontrols[n]:=fcontrols[n+1];
end;
end;
dec(fcontrolscount);
setlength(fcontrols,fcontrolscount);
end;
function tglControlSet.getcontrol(i: Cardinal) : tglControl;
begin
result:=tglControl(fcontrols[i])
end;
procedure tglControlSet.Draw;
var
n: cardinal;
begin
for n := 0 to fcontrolscount-1 do if getcontrol(n).nodraw=false then getcontrol(n).paint;
end;
function tglControlSet.ProcessControls(Event : Byte) : integer;
var
n : integer;
begin
result:=RESULT_FALSE;
for n := fcontrolscount-1 downto 0 do begin
if (getcontrol(n).ProcessControl(Event)=RESULT_TRUE) then begin
result:=RESULT_TRUE;
end;
if (getcontrol(n).ProcessControl(Event)=RESULT_FALSE_BUT_NEEDS_REDRAW) then begin
result:=RESULT_FALSE_BUT_NEEDS_REDRAW;
end;
end;
end;
//tgflControl
constructor tglControl.Create(parent : TglControlSet);
begin
inherited Create;
fparent:=parent;
parent.registercontrol(Self);
finteractive:=false;
fnodraw:=false;
end;
destructor tglControl.Destroy;
begin
deltexture(ftexture.texture);
parent.unregistercontrol(self);
end;
function tglControl.getparent : TglControlSet;
begin
result:=fparent;
end;
procedure tglControl.setparent(parent : TglControlSet);
begin
fparent:=parent;
end;
procedure tglControl.Paint;
begin
end;
procedure tglControl.Resize;
begin
end;
procedure tglControl.MouseDown(x,y : integer);
begin
end;
procedure tglControl.MouseUp(x,y : integer);
begin
end;
procedure tglControl.MouseMove(x: Integer; y: Integer);
begin
end;
function tglControl.ProcessControl(Event : Byte) : byte;
var
cursor : tpoint;
glPos : tgl3DCoord;
rw : tgl3DCoord;
plane : integer;
tmp : double;
control : tglcontrol;
x,y : integer;
begin
if Event=EVENT_RESIZE then begin
self.resize;
result:=RESULT_TRUE;
exit;
end;
x:=0;
y:=0;
result:=RESULT_FALSE;
if fenabled=false then exit;
if finteractive=false then exit;
GetCursorPos(cursor);
cursor:=(parent.parent).ScreenToClient(cursor);
glPos:=getGLPos(cursor.x,cursor.y);
rw:=getRealWorldPos(glPos);
control:=nil;
//TForm(parent.parent).caption:=floattostr(rw.x)+' '+floattostr(rw.y-getrealworldpos(fvertices.v3).y)+' '+floattostr(rw.z);
tmp:=fvertices.v1.z+fvertices.v2.z+fvertices.v3.z+fvertices.v4.z;
plane:=round(tmp);
case plane of
6: if ((cursor.x >= getRealWorldPos(fvertices.v1).x)) and (cursor.x<=getRealWorldPos(fvertices.v3).x)
and ((cursor.y >= getRealWorldPos(fvertices.v3).y)) and (cursor.y<=getRealWorldPos(fvertices.v1).y)
then begin
x:=(round(rw.x-getrealworldpos(fvertices.v1).x));
y:=round((rw.y)-(getrealworldpos(fvertices.v3).y));
control:=self;
end;
-3: if ((cursor.x >= getRealWorldPos(fvertices.v3).x)) and (cursor.x<=getRealWorldPos(fvertices.v1).x)
and ((cursor.y >= getRealWorldPos(fvertices.v3).y)) and (cursor.y<=getRealWorldPos(fvertices.v1).y)
then begin
x:=(round(rw.x-getrealworldpos(fvertices.v3).x));
y:=round((rw.y)-(getrealworldpos(fvertices.v3).y));
control:=self;
end;
-6: if ((cursor.x >= getRealWorldPos(fvertices.v3).x)) and (cursor.x<=getRealWorldPos(fvertices.v1).x)
and ((cursor.y >= getRealWorldPos(fvertices.v3).y)) and (cursor.y<=getRealWorldPos(fvertices.v1).y)
then begin
x:=(round(rw.x-getrealworldpos(fvertices.v3).x));
y:=round((rw.y)-(getrealworldpos(fvertices.v3).y));
control:=self;
end;
3: if ((cursor.x >= getRealWorldPos(fvertices.v1).x)) and (cursor.x<=getRealWorldPos(fvertices.v3).x)
and ((cursor.y >= getRealWorldPos(fvertices.v3).y)) and (cursor.y<=getRealWorldPos(fvertices.v1).y)
then begin
x:=(round(rw.x-getrealworldpos(fvertices.v1).x));
y:=round((rw.y)-(getrealworldpos(fvertices.v3).y));
control:=self;
end;
end;
if (Event=EVENT_MOUSEDOWN) and (control<>nil) then begin
control.MouseDown(x,y);
//TForm(parent.parent).caption:='Shzam!'+control.name+' - '+inttostr(x)+' : '+inttostr(y);
result:=RESULT_TRUE;
exit;
end;
if (Event=EVENT_MOUSEUP) and (control<>nil) then begin
control.MouseUp(x,y);
result:=RESULT_TRUE;
exit;
end;
if (Event=EVENT_MOUSEMOVE) and (control<>nil) then begin
control.MouseMove(x,y);
result:=RESULT_TRUE;
exit;
end;
//Unhandled
control:=self;
x:=-1;
y:=-1;
if (Event=EVENT_MOUSEUP) then control.MouseUp(x,y);
result:=RESULT_FALSE_BUT_NEEDS_REDRAW;
end;
// tglBitmap
constructor tglBitmap.create(parent : TglControlSet);
begin
inherited;
ftexture := addtexture;
fbitmap:=tbitmap.create;
end;
destructor tglBitmap.Destroy;
begin
inherited;
end;
procedure tglBitmap.loadfromfile (fn : string);
begin
loadtexturefromFile(ftexture,fn,512,512);
end;
procedure tglBitmap.Paint;
begin
inherited;
glBindTexture(GL_TEXTURE_2D, ftexture.texture);
glBegin(GL_QUADS);
glNormal3f( fnormal.x, fnormal.y, fnormal.z);
glTexCoord2f(fTexCoord.v1.x, fTexCoord.v1.y);
with fVertices.v1 do glVertex3f(x, y, z);
glTexCoord2f(fTexCoord.v2.x, fTexCoord.v2.y);
with fVertices.v2 do glVertex3f(x, y, z);
glTexCoord2f(fTexCoord.v3.x, fTexCoord.v3.y);
with fVertices.v3 do glVertex3f(x, y, z);
glTexCoord2f(fTexCoord.v4.x, fTexCoord.v4.y);
with fVertices.v4 do glVertex3f(x, y, z);
glEnd();
end;
procedure tglBitmap.Resize;
begin
inherited;
end;
procedure tglBitmap.LoadFromResource(res : string);
begin
if res='' then exit;
loadtexturefromResource(ftexture,res,1024,1024);
end;
procedure tglBitmap.setbitmap (bmp : tbitmap);
begin
if not assigned(self) then exit;
fbitmap.Assign(bmp);
if not assigned(fbitmap) then exit;
LoadTexturefromBitmap(ftexture,fbitmap);
end;
// tglColourQuad
constructor tglColourQuad.create(parent : TglControlSet);
begin
inherited;
end;
destructor tglColourQuad.Destroy;
begin
inherited;
end;
procedure tglColourQuad.Paint;
begin
inherited;
//glBindTexture(GL_TEXTURE_2D, ftexture.texture);
glBegin(GL_QUADS);
//glNormal3f( fnormal.x, fnormal.y, fnormal.z);
glColor3f(1.0,0,1.0);
with fVertices.v1 do glVertex3f(x, y, z);
glColor3f(0,1.0,0);
with fVertices.v2 do glVertex3f(x, y, z);
glColor3f(1.0,1.0,0);
with fVertices.v3 do glVertex3f(x, y, z);
glColor3f(1.0,0,0);
with fVertices.v4 do glVertex3f(x, y, z);
glEnd();
end;
procedure tglColourQuad.Resize;
begin
inherited;
end;
//tglListbox
constructor tglListbox.create(parent : TglControlSet);
begin
inherited;
ftexture := addtexture;
bm:=tbitmap.create;
frealworldwidth:=1024;
frealworldheight:=1024;
upnormal:=tbitmap.create;
uppressed:=tbitmap.create;
downnormal:=tbitmap.create;
downpressed :=tbitmap.create;
fcolor:=clWindow;
fitems:=tstringlist.create;
fitems.OnChange:=itemschange;
fitems.add(name);
ffont:=tfont.create;
//fmorebackgroundcolor:=rgb(230,230,230);
fmorebackgroundcolor:=rgb($FD,$F7,$B5);
fmoretext:='MORE';
ffont.name:='arial';
ffont.size:=12;
flinespacing:=1;
marked:=-3;
topmost:=0;
// Parent := (AOwner AS TWinControl);
bm.canvas.pen.style:=psSolid;
bm.canvas.brush.style:=bsSolid;
fshownumbers:=true;
repeattimer:=ttimer.create(nil);
repeattimer.interval:=TIMERINTERVAL;
repeattimer.enabled:=false;
repeattimer.ontimer:=repeattimertimer;
scrollwidths:=18;
//cachedimage:=tbitmap.create;
fhighlight:=false;
fhighlight2:=false;
finteractive:=true;
fdrawmode:=true;
end;
procedure Tgllistbox.settopmost(i : integer);
begin
//outputdebugstring(pchar('Tgllistbox settopmost: '+inttostr(i)+' - '+inttostr(items.count)));
if (i<items.count-1) then ftopmost:=i;
fdrawmode:=true;
end;
procedure Tgllistbox.setscrollwidths(sw : integer);
var
obmp,bmp : tbitmap;
procedure scaleicon;
var
tr : trect;
begin
fscalescrolls:=fscrollwidths / bmp.width;
obmp.width:=round(bmp.width*fscalescrolls);
obmp.height:=round(bmp.height*fscalescrolls);
tr.top:=0;
tr.left:=0;
tr.Right:=obmp.width;
tr.Bottom:=obmp.height;
obmp.Canvas.StretchDraw(tr,bmp);
bmp.assign(obmp);
end;
begin
fscrollwidths:=sw;
bmp:=tbitmap.create;
obmp:=tbitmap.create;
bmp.LoadFromResourceName(hinstance,'UPPRESSED');
//scaleicon;
uppressed.assign(bmp);
bmp.free;
obmp.free;
bmp:=tbitmap.create;
obmp:=tbitmap.create;
bmp.LoadFromResourceName(hinstance,'UPNORMAL');
//scaleicon;
upnormal.assign(bmp);
bmp.free;
obmp.free;
bmp:=tbitmap.create;
obmp:=tbitmap.create;
bmp.LoadFromResourceName(hinstance,'DOWNPRESSED');
//scaleicon;
downpressed.assign(bmp);
bmp.free;
obmp.free;
bmp:=tbitmap.create;
obmp:=tbitmap.create;
bmp.LoadFromResourceName(hinstance,'DOWNNORMAL');
//scaleicon;
downnormal.assign(bmp);
bmp.free;
obmp.free;
end;
procedure Tgllistbox.losefocus;
begin
topmost:=0;
fitemindex:=-1;
marked:=-3;
fdrawmode:=true;
end;
procedure Tgllistbox.scrollup;
begin
if marked =0 then begin
if Assigned(FReachedTop) then FReachedTop;
exit;
end;
isdown:=true;
if marked<0 then marked:=topmost+1;
if marked>=1 then begin
dec(marked);
if (marked <= topmost) or (marked>topmost+fdisplayitems) then topmost:=marked;
if marked<fitems.Count then fitemindex:=marked;
remoteused:=true;
fdrawmode:=true;
exit;
end;
fitemindex:=marked;
remoteused:=true;
fdrawmode:=true;
end;
procedure Tgllistbox.scrolltoend;
begin
topmost:=(fitems.count)-fdisplayitems;
marked:=fitems.count-1;
fdrawmode:=true;
end;
procedure Tgllistbox.scrolldown;
begin;
isdown:=true;
if marked<0 then begin
marked:=topmost-1;
end;
if marked+1=fitems.count then begin
if Assigned(FReachedEnd) then FReachedEnd;
fdrawmode:=true;
exit;
end;
if marked<fitems.count-1 then begin
inc(marked);
if (marked < topmost) or (marked>=(topmost+fdisplayitems)) then begin
topmost:=marked-fdisplayitems+1;
end;
end;
fitemindex:=marked;
remoteused:=true;
fdrawmode:=true;
end;
procedure Tgllistbox.remoteclick;
begin
itemindex:=marked;
//onclick(self);
end;
procedure Tgllistbox.setitemindex(i : integer);
begin
fitemindex:=i;
end;
procedure Tgllistbox.itemschange(sender : tobject);
begin
if items.count<=fdisplayitems+2 then fdrawmode:=true;
end;
function Tgllistbox.cliptextout(buffer: TBitmap;x,y : integer;st : string;no : integer;var numberextent : integer) : Tsize;
var
ns : string;
ls : tsize;
o : tbitmap;
tr : trect;
iconsize,iconspace : integer;
begin
ls.cx:=0;
with buffer do begin
ns:=format('%.3d',[no]);
canvas.Brush.Style:=bsClear;
if fshownumbers=true then begin
canvas.pen.color:=fnumbercolor;
//canvas.rectangle(x,y,ls.cx,ls.cy);
ls:=canvas.textextent(ns);
ls.cx:=ls.cx+(width div 20);
canvas.textout(x,y,ns);
end;
if fitems.objects[no-1]<>nil then begin
if TScrollListItemAdditonalInfo(fitems.objects[no-1]).picture<>nil then begin
tr.Left:=width-(itemheight);
tr.top:=y-(itemheight div 2);
tr.right:=width;
tr.Bottom:=y+(itemheight div 2);
try
canvas.StretchDraw(tr,TBitmap(TScrollListItemAdditonalInfo(fitems.objects[no-1]).picture));
canvas.Pen.color:=clblack;
canvas.Rectangle(tr);
except
end;
end;
iconspace:=round(15*(screen.height/600));
iconsize:=round(12*(screen.height/600));
if TScrollListItemAdditonalInfo(fitems.objects[no-1]).icon<>'' then begin
o:=tbitmap.create;
ls.cx:=ls.cx+iconspace;
o.LoadFromResourceName(hinstance,TScrollListItemAdditonalInfo(fitems.objects[no-1]).icon);
tr.Left:=0;
tr.top:=y;
tr.Bottom:=y+iconsize;
tr.Right:=tr.bottom-tr.top;
canvas.Brush.Color:=clBlack;
canvas.BrushCopy(tr,o,o.Canvas.ClipRect,rgb(255,0,0));
canvas.Brush.Color:=fnumbercolor;
//canvas.StretchDraw(tr,o);
o.free;
end;
end;
numberextent:=x+ls.cx;
canvas.textout(x+ls.cx,y,st);
result:=canvas.textextent(st);
result.cx:=result.cx+ls.cx;
end;
end;
procedure Tgllistbox.clear;
var
n: Integer;
begin
ftopmost :=0;
fitems.clear;
for n := 0 to addinfocount-1 do begin
if addinfo[n]<>nil then addinfo[n].Free;
end;
addinfocount:=0;
fdrawmode:=true;
//cachedimage.free;
//cachedimage:=tbitmap.create;
fhighlighteditem:=-1;
fhighlighteditem2:=-1;
end;
procedure Tgllistbox.setlinespacing(_value : single);
begin
if _value<1 then _value:=1;
flinespacing:=_value;
resize;
end;
procedure Tgllistbox.setfont(_font : tfont);
begin
ffont.name:=_font.name;
ffont.size:=_font.size;
ffont.style:=_font.style;
end;
procedure Tgllistbox.setcolor(_color : tcolor);
begin
Fcolor:=_color;
end;
procedure Tgllistbox.Paint;
var
n : integer;
y : integer;
ext : Tsize;
max : integer;
showtop,showbottom : boolean;
tr,dr : trect;
bmp : Tbitmap;
vcanv : tbitmap;
ptp : Tpoint;
ne : integer;
fontcol : tcolor;
begin
inherited;
if parent=nil then exit;
//START GDI PAINT
if fdrawmode=true then begin
bm.width:=frealworldwidth;
bm.height:=frealworldheight;
{ TODO -ojukebox -cvisual bug : LSB items sometimes add blank line }
vcanv:=tbitmap.Create;
vcanv.width:=bm.width;
vcanv.height:=bm.height;
vcanv.canvas.brush.assign(bm.Canvas.brush);
vcanv.canvas.pen.Assign(bm.Canvas.pen);
vcanv.canvas.font.assign(bm.canvas.font);
fontcol:=bm.canvas.font.color;
//cachedimage.free;
//cachedimage:=tbitmap.create;
setlength(matrix,0);
if topmost=0 then showtop:=false else showtop:=true;
showbottom:=true;
vcanv.canvas.Brush.color:=fcolor;
vcanv.canvas.pen.color:=fcolor;
vcanv.canvas.Rectangle(0,0,vcanv.width,vcanv.height);
setlength(matrix,fitems.count+2);
y:=topborder;
max:=(topmost+fdisplayitems)-1;
if max>=fitems.count-1 then begin
max:=fitems.count-1;
showbottom:=false;
end;
for n:=topmost to (max) do begin
if marked=n then begin
vcanv.canvas.font.size:=round(ffont.size*1.5);
end else begin
vcanv.canvas.font.size:=ffont.size;
end;
if (marked=n) then begin
ext:=cliptextout(vcanv,fmargin,y-(round(ffont.size*1.5) div 4),items[n],n+1,ne);
ptp.x:=fmargin;
ptp.y:=y;
// if assigned(fitemhint) then begin
// fitemhint.dohint(items[n]);
// fitemhint.Visible:=true;
// end;
end else begin
if (fhighlight=true) and ((n=fhighlighteditem) and (fhighlighteditem>-1)) then vcanv.canvas.font.color:=fhighlightcolor else vcanv.canvas.font.color:=fontcol;
ext:=cliptextout(vcanv,fmargin,y,items[n],n+1,ne);
if (fhighlight2=true) and ((n=fhighlighteditem2) and (fhighlighteditem2>-1)) then begin
vcanv.canvas.Pen.color:=clwhite;
vcanv.canvas.Rectangle(fmargin,y,(vcanv.width),y+vcanv.canvas.TextHeight(items[n]));
end;
end;
matrix[n].x1:=fmargin;
matrix[n].y1:=y;
//matrix[n].x2:=matrix[n].x1+ext.cx;
matrix[n].x2:=vcanv.width;
matrix[n].y2:=matrix[n].y1+ext.cy;
matrix[n].item:=n;
y:=y+itemheight;
end;
if showtop=true then begin
bmp:=tbitmap.create;
if marked=-1 then bmp.assign(uppressed) else bmp.assign(upnormal);
vcanv.canvas.font.Style:=[fsBold];
vcanv.canvas.font.size:=round(font.size * 0.6);//round(2*fscalescrolls);
vcanv.canvas.font.name:='arial';
matrix[fitems.count].x1:=(vcanv.width div 2) - (vcanv.canvas.TextWidth(fmoretext) div 2)-4;
matrix[fitems.count].y1:=-1;
matrix[fitems.count].x2:=(vcanv.width div 2) + (vcanv.canvas.TextWidth(fmoretext) div 2)+4;
matrix[fitems.count].y2:=1+(bmp.height)+vcanv.canvas.textheight(fmoretext)+4;
matrix[fitems.count].item:=-1;
dr.left:=(vcanv.width div 2)-(bmp.width div 2);//+fmargin;
dr.top:=matrix[fitems.count].y1+2;
dr.right:=bmp.width+dr.left;
dr.bottom:=bmp.height+dr.Top;
tr.top:=0;
tr.left:=0;
tr.right:=bmp.width;
tr.Bottom:=bmp.height;
//canvas.stretchdraw(dr,bmp);
vcanv.canvas.pen.color:=clgray;
vcanv.canvas.brush.Color:=fmorebackgroundcolor;
vcanv.canvas.Pen.Style:=psSolid;
vcanv.canvas.rectangle(matrix[fitems.count].x1,matrix[fitems.count].y1,matrix[fitems.count].x2,matrix[fitems.count].y2);
vcanv.canvas.BrushCopy(dr,bmp,tr,RGB(255,255,255));
vcanv.canvas.font.color:=clgray;
vcanv.canvas.textout(vcanv.width div 2 - vcanv.canvas.textwidth(fmoretext) div 2,matrix[fitems.count].y1+bmp.height+5,fmoretext);
vcanv.canvas.font.Style:=[];
bmp.free;
end;
if showbottom=true then begin
bmp:=tbitmap.create;
if marked=-2 then bmp.assign(downpressed) else bmp.assign(downnormal);
vcanv.canvas.font.size:=round(font.size *0.6);//round(2*fscalescrolls);
vcanv.canvas.font.Style:=[fsBold];
vcanv.canvas.font.name:='arial';
matrix[fitems.count+1].x1:=(vcanv.width div 2) - (vcanv.canvas.TextWidth(fmoretext) div 2)-4;
matrix[fitems.count+1].y1:=(vcanv.height-bmp.height-1)-vcanv.canvas.textheight(fmoretext)-4;
matrix[fitems.count+1].x2:=(vcanv.width div 2) + (vcanv.canvas.TextWidth(fmoretext) div 2)+4;
matrix[fitems.count+1].y2:=vcanv.height;
matrix[fitems.count+1].item:=-2;
dr.left:=(vcanv.width div 2)-(bmp.width div 2);//+fmargin;
dr.top:=matrix[fitems.count+1].y2-(bmp.height)-3;
dr.right:=bmp.width+dr.left;
dr.bottom:=bmp.height+dr.Top;
tr.top:=0;
tr.left:=0;
tr.right:=bmp.width;
tr.Bottom:=bmp.height;
//canvas.stretchdraw(dr,bmp);
vcanv.canvas.pen.color:=clgray;
vcanv.canvas.brush.Color:=fmorebackgroundcolor;
vcanv.canvas.Pen.Style:=psSolid;
vcanv.canvas.rectangle(matrix[fitems.count+1].x1,matrix[fitems.count+1].y1,matrix[fitems.count+1].x2,matrix[fitems.count+1].y2);
vcanv.canvas.BrushCopy(dr,bmp,tr,RGB(255,255,255));
vcanv.canvas.font.color:=clgray;
vcanv.canvas.textout(vcanv.width div 2 - vcanv.canvas.textwidth(fmoretext) div 2,matrix[fitems.count+1].y1+1,fmoretext);
vcanv.canvas.font.Style:=[];
bmp.free;
end;
bm.canvas.draw(0,0,vcanv);
vcanv.free;
end;
//END GDI DRAWMODE
if clicked=true then begin
clicked:=false;
click;
// sleep(200);
// paint;
end;
LoadTextureFromBitmap(ftexture,bm);
glBindTexture(GL_TEXTURE_2D, ftexture.texture);
glBegin(GL_QUADS);
glNormal3f( fnormal.x, fnormal.y, fnormal.z);
glTexCoord2f(fTexCoord.v1.x, fTexCoord.v1.y);
with fVertices.v1 do glVertex3f(x, y, z);
glTexCoord2f(fTexCoord.v2.x, fTexCoord.v2.y);
with fVertices.v2 do glVertex3f(x, y, z);
glTexCoord2f(fTexCoord.v3.x, fTexCoord.v3.y);
with fVertices.v3 do glVertex3f(x, y, z);
glTexCoord2f(fTexCoord.v4.x, fTexCoord.v4.y);
with fVertices.v4 do glVertex3f(x, y, z);
glEnd();
fdrawmode:=false;
end;
procedure Tgllistbox.Resize;
begin
bm.width:=frealworldheight;
bm.height:=frealworldwidth;
bm.canvas.Font:=ffont;
topborder:=itemheight+4;
itemheight:=round(bm.canvas.textheight('AAA')*flinespacing);
fdisplayitems:=round((bm.height-topborder*2) / (itemheight));
drawmode:=true;
paint;
end;
procedure Tgllistbox.click;
begin
//inherited click;
onclick(self);
end;
procedure Tgllistbox.MouseUp(X, Y: Integer);
var
n : integer;
begin
//if fitemhint<>nil then fitemhint.Visible:=false;
clicked:=false;
isdown:=false;
fitemindex:=-1;
marked:=-3;
repeattimer.enabled:=false;
repeattimer.interval:=TIMERINTERVAL;
//inherited MouseUp(Button,Shift,X,Y);
//Mouseup away from object
if ((x=-1) and (y=-1)) then begin
drawmode:=true;
exit;
end;
for n:=0 to fitems.count+2 do begin
if (x>=matrix[n].x1) And
(x<=matrix[n].x2) And
(y>=matrix[n].y1) And
(y<=matrix[n].y2) then begin
if matrix[n].item>=0 then begin;
fitemindex:=matrix[n].item;
clicked:=true;
fhighlighteditem:=n;
fdrawmode:=true;
break;
end;
end;
end;
marked:=-3;
drawmode:=true;
end;
procedure Tgllistbox.MouseDown(X, Y: Integer);
var
n : integer;
begin
xx:=x;
yy:=y;
isdown:=true;
repeattimer.enabled:=true;
//inherited MouseDown(Button,Shift,X,Y);
for n:=0 to fitems.count+2 do begin
if (x>=matrix[n].x1) And
(x<=matrix[n].x2) And
(y>=matrix[n].y1) And
(y<=matrix[n].y2) then begin
marked:=matrix[n].item;
if (matrix[n].item=-2) and (topmost<items.count) then inc(ftopmost);
if matrix[n].item=-1 then dec(ftopmost);
//if (marked<0) and (fitemhint<>nil) then fitemhint.Visible:=false;
fdrawmode:=true;
exit;
end;
end;
end;
procedure Tgllistbox.MouseMove(x, y: Integer);
begin
if marked<0 then exit;
xx:=x;
yy:=y;
if isdown=true then begin
fdrawmode:=true;
mousedown(x,y);
end;
end;
procedure Tgllistbox.StopFlicker(var Msg: TWMEraseBkgnd);
begin
Msg.Result := 1;
end;
procedure Tgllistbox.repeattimertimer(sender : tobject);
begin
mousedown(xx,yy);
//sendmessage(self.handle,WM_LBUTTONDOWN,xx,yy);
if repeattimer.interval>20 then repeattimer.interval:=repeattimer.interval-10;
tglControlSet(parent).RedrawProcedure;
end;
procedure Tgllistbox.additemandinfo(s : string;album : integer;track : integer;picture : tobject;icon : string;data : string);
begin
inc(addinfocount);
setlength(addinfo,addinfocount);
items.Add(s);
addinfo[addinfocount-1]:=TScrollListItemAdditonalInfo.Create;
addinfo[addinfocount-1].AlbumNumber:=album;
addinfo[addinfocount-1].TrackNumber:=track;
addinfo[addinfocount-1].picture:=picture;
addinfo[addinfocount-1].icon:=icon;
items.Objects[items.Count-1]:=addinfo[addinfocount-1];
end;
destructor tglListbox.destroy;
begin
inherited;
clear;
bm.free;
upnormal.Free;
downnormal.Free;
uppressed.Free;
downpressed.free;
fitems.Free;
ffont.Free;
repeattimer.Free;
//cachedimage.free;
end;
// tGLLabel
constructor tglLabel.create(parent : TglControlSet);
begin
inherited;
ftexture := addtexture;
bm:=tbitmap.Create;
bm.width:=50;
bm.Height:=20;
ffont:=tfont.create;
ffont.name:='arial';
ffont.size:=12;
finteractive:=true;
fenabled:=true;
isdown:=false;
end;
destructor tglLabel.Destroy;
begin
inherited;
bm.Free;
ffont.free;
end;
procedure TglLabel.setfont(_font : tfont);
begin
ffont.name:=_font.name;
ffont.size:=_font.size;
ffont.style:=_font.style;
resize;
end;
procedure tglLabel.setlabel(s : string);
begin
inherited;
fcaption:=s;
resize;
paint;
end;
procedure tglLabel.Paint;
begin
inherited;
if fenabled=false then exit;
bm.Canvas.Font.Assign(ffont);
bm.canvas.textout(0,0,' '+fcaption+' ');
LoadTextureFromBitmap(ftexture,bm);
glBindTexture(GL_TEXTURE_2D, ftexture.texture);
glBegin(GL_QUADS);
glNormal3f( fnormal.x, fnormal.y, fnormal.z);
glTexCoord2f(fTexCoord.v1.x, fTexCoord.v1.y);
with fVertices.v1 do glVertex3f(x, y, z);
glTexCoord2f(fTexCoord.v2.x, fTexCoord.v2.y);
with fVertices.v2 do glVertex3f(x, y, z);
glTexCoord2f(fTexCoord.v3.x, fTexCoord.v3.y);
with fVertices.v3 do glVertex3f(x, y, z);
glTexCoord2f(fTexCoord.v4.x, fTexCoord.v4.y);
with fVertices.v4 do glVertex3f(x, y, z);
glEnd();
end;
procedure tglLabel.Resize;
begin
inherited;
bm.Width:=bm.Canvas.TextWidth(' '+fcaption+' ');
bm.Height:=bm.Canvas.TextHeight(fcaption);
end;
procedure TglLabel.MouseDown(X, Y: Integer);
begin
isdown:=true;
end;
procedure TglLabel.MouseUp(X, Y: Integer);
begin
if isdown=true then begin
isdown:=false;
if assigned(onclick) then onclick(self);
end;
end;
end.
