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.