Code: Select all
/'
GUI_11_CORE.BAS GUI WPAPPER FOR WINDOWS
copyright(c) 2021 vasile eodor nastasa
http://rqwork.ro
http://rqwork.de
nastasa.eodor@gmail.com
tested on windows7 and windows10,working well in
update versions,but in the first release,
both windows,7 and 10, we have troubles with
changing styles on run time,but bug comes from windows it self.
Permision to change/modify is granted,but you must keep
this comment,of course together with yours.
Also you must publish your work...under freeware terms.
'/
#include once "windows.bi"
#define instance GetModuleHandle(0)
const cm_command=wm_app+1
type PObject as TObject ptr
type PComponent as TComponent ptr
type PControl as TControl ptr
type PFrame as TFrame ptr
common shared as PFrame CreationData
/'SysUtils '/
function comparetext(v as string,vc as string) as integer
return lcase(v)=lcase(vc)
end function
type PMessage as TMessage ptr
type TMessage
as hwnd dlg
as uint msg
as wparam wparam
as lparam lparam
as lresult result
as PFrame sender
end type
enum TPropKind
pkAnyPtr,pkByte,pkShort,pkInteger,pkLong,pkSingle,pkDouble,pkString,pkZString,pkType
end enum
type TObject extends object
public:
as string classname,classancestor,name
declare abstract function SetProperty(as string,as any ptr) as any ptr
declare abstract function GetProperty(as string,byref as TPropKind=pkAnyPtr) as any ptr
declare operator cast as any ptr
end type
type TEvent as sub(byref as TObject)
type TCloseEvent as sub(byref as TObject,byref as integer)
enum TComponentState
csRunTime,csDesignMode
end enum
type TComponent extends TObject
private:
as TComponentState fcomponentstate
as integer fcomponentcount
as PComponent ptr fcomponents
declare sub Add(as PComponent)
declare sub Remove(as PComponent)
public:
declare property ComponentCount as integer
declare property Component(as integer) byref as TComponent
declare property Component(as integer ,byref as TComponent)
declare function indexofcomponent(as PComponent) as integer
declare virtual function SetProperty(as string,as any ptr) as any ptr
declare virtual function GetProperty(as string,byref as TPropKind=pkAnyPtr) as any ptr
declare operator cast as any ptr
end type
type TControl extends TComponent
private:
protected:
as hwnd fhandle
as string ftext
as integer fcontrolcount,fx,fy,fcx,fcy,fid,fstyle,fexstyle
as boolean fvisible,fenabled
as PControl fparent
as PCOntrol ptr fcontrols
declare sub Add(as PControl)
declare sub Remove(as PControl)
declare abstract sub Dispatch(byref as TMessage)
declare abstract sub Handler(byref as TMessage)
declare abstract sub CreateHandle
declare abstract sub FreeHandle
public:
declare property Parent as PControl
declare property Parent(as PControl)
declare property Text as string
declare property Text (as string)
declare property x as integer
declare property x (as integer)
declare property y as integer
declare property y (as integer)
declare property cx as integer
declare property cx (as integer)
declare property cy as integer
declare property cy (as integer)
declare property Enabled as boolean
declare property Enabled (as boolean)
declare property Visible as boolean
declare property Visible (as boolean)
declare property ControlCount as integer
declare property Control(as integer) byref as TControl
declare property Control(as integer ,byref as TControl)
declare function indexofcontrol(as PControl) as integer
declare virtual function SetProperty(as string,as any ptr) as any ptr
declare virtual function GetProperty(as string,byref as TPropKind=pkAnyPtr) as any ptr
declare operator cast as any ptr
declare constructor
declare destructor
end type
type TFrame extends TCoNtrol
public:
declare property Style as integer
declare property Style(as integer)
declare property ExStyle as integer
declare property ExStyle(as integer)
declare property Handle as hwnd
declare property Handle(as hwnd)
declare virtual sub Dispatch(byref as TMessage)
declare virtual sub Handler(byref as TMessage)
declare virtual sub CreateHandle
declare virtual sub FreeHandle
declare virtual function SetProperty(as string,as any ptr) as any ptr
declare virtual function GetProperty(as string,byref as TPropKind=pkAnyPtr) as any ptr
declare operator cast as any ptr
end type
/''''''''''''RTTI'''''''''''/
function SetPropValue(o as PObject,p as string,v as any ptr) as any ptr
if o then
return o->SetProperty(p,v)
else
return cast(any ptr,messageBox(0,"Can't SET property. Instance of object is empty.","SetPropValue",mb_iconinformation or mb_taskmodal or mb_applmodal or mb_topmost))
end if
end function
function GetPropValue(o as PObject,p as string,byref k as TPropKind=pkAnyPtr) as any ptr
if o then
return o->GetProperty(p,k)
else
return cast(any ptr,messageBox(0,"Can't GET property. Instance of object is empty.","GetPropValue",mb_iconinformation or mb_taskmodal or mb_applmodal or mb_topmost))
end if
end function
'''''''''''end RTTI''''''''''''
/' TObhect '/
operator TObject.cast as any ptr
return @this
end operator
/' TComponent '/
function TComponent.indexofcomponent(v as PComponent) as integer
if v=0 then return -1
for i as integer=0 to fcomponentcount-1
if fcomponents[i]=v then return i
next
return -1
end function
sub TComponent.Add(v as PComponent)
if indexofcomponent(v)=-1 then
fcomponentcount+=1
fcomponents=reallocate(fcomponents,sizeof(PComponent)*fcomponentcount)
fcomponents[fcomponentcount-1]=v
end if
end sub
sub TComponent.Remove(v as PComponent)
dim as integer w=indexofcomponent(v)
if w>-1 then
for i as integer=w+1 to fcomponentcount-1
fcomponents[i-1]=fcomponents[i]
next
fcomponentcount-=1
fcomponents=reallocate(fcomponents,fcomponentcount*sizeof(PComponent))
end if
end sub
property TComponent.ComponentCount as integer
return fcomponentcount
end property
property TComponent.Component(i as integer) byref as TComponent
if i>-1 and i<fcomponentcount then return *fcomponents[i]
return *cast(PComponent,0)
end property
property TComponent.Component(i as integer ,byref v as TComponent)
if i>-1 and i<fcomponentcount then fcomponents[i]=v
end property
function TComponent.SetProperty(p as string,v as any ptr) as any ptr
return 0
end function
function TComponent.GetProperty(p as string,byref k as TPropKind=pkAnyPtr) as any ptr
return 0
end function
operator TComponent.cast as any ptr
return @this
end operator
/' TControl '/
property TControl.Parent as PControl
return fparent
end property
property TControl.Parent(v as PControl)
dim as PControl saveParent=fparent
fparent=v
if isWindow(fhandle) then
if v then v->Add(this)
if saveparent then saveparent->remove(this)
SetParent(fhandle,iif(v,v->fhandle,0))
else
if v then v->Add(this) :? "cc=",v->controlcount
createhandle
? getlasterror
end if
end property
property TControl.Text as string
return ftext
end property
property TControl.Text (v as string)
ftext=v
if iswindow(fhandle) then SetWindowText(fhandle,v)
end property
property TControl.x as integer
return fx
end property
property TControl.x (v as integer)
fx=v
if iswindow(fhandle) then MoveWindow(fhandle,fx,fy,fcx,fcy,1)
end property
property TControl.y as integer
return fy
end property
property TControl.y (v as integer)
fy=v
if iswindow(fhandle) then MoveWindow(fhandle,fx,fy,fcx,fcy,1)
end property
property TControl.cx as integer
return fcx
end property
property TControl.cx (v as integer)
fcx=v
if iswindow(fhandle) then MoveWindow(fhandle,fx,fy,fcx,fcy,1)
end property
property TControl.cy as integer
return fcy
end property
property TControl.cy (v as integer)
fcy=v
if iswindow(fhandle) then MoveWindow(fhandle,fx,fy,fcx,fcy,1)
end property
property TControl.Enabled as boolean
return fenabled
end property
property TControl.Enabled (v as boolean)
fenabled=v
if iswindow(fhandle) then EnableWindow(fhandle,v)
end property
property TControl.Visible as boolean
return fvisible
end property
property TControl.Visible (v as boolean)
fvisible=v
if iswindow(fhandle) then ShowWindow(fhandle,iif(v,sw_show,sw_hide))
end property
property TControl.ControlCount as integer
return fcontrolcount
end property
property TControl.Control(i as integer) byref as TControl
if i>-1 and i<fcontrolcount then return *fcontrols[i]
return *cast(PControl,0)
end property
property TControl.Control(i as integer ,byref v as TControl)
if i>-1 and i<fcontrolcount then fcontrols[i]=v
end property
function TControl.indexofcontrol(v as PControl) as integer
if v=0 then return -1
for i as integer=0 to fcontrolcount-1
if fcontrols[i]=v then return i
next
return -1
end function
sub TControl.Add(v as PControl)
if indexofcontrol(v)=-1 then
fcontrolcount+=1
fcontrols=reallocate(fcontrols,sizeof(PControl)*fcontrolcount)
fcontrols[fcontrolcount-1]=v
end if
end sub
sub TControl.Remove(v as PControl)
dim as integer w=indexofcontrol(v)
if w>-1 then
for i as integer=w+1 to fcontrolcount-1
fcontrols[i-1]=fcontrols[i]
next
fcontrolcount-=1
fcontrols=reallocate(fcontrols,sizeof(PControl)*fcontrolcount)
end if
end sub
function TControl.SetProperty(p as string,v as any ptr) as any ptr
if comparetext("text",p) then
function=cast(any ptr,strptr(ftext))
text=*cast(zstring ptr,v)
elseif comparetext("x",p) then
function=cast(any ptr,fx)
x=cast(integer,v)
elseif comparetext("y",p) then
function=cast(any ptr,fy)
y=cast(integer,v)
elseif comparetext("cx",p) then
function=cast(any ptr,fcx)
cx=cast(integer,v)
elseif comparetext("cy",p) then
function=cast(any ptr,cy)
cy=cast(integer,v)
elseif comparetext("enabled",p) then
function=cast(any ptr,cint(fenabled))
fenabled=cast(integer,v)
elseif comparetext("visible",p) then
function=cast(any ptr,cint(fvisible))
visible=cast(integer,v)
else
return Base.SetProperty(p,v)
end if
end function
function TControl.GetProperty(p as string,byref k as TPropKind=pkAnyPtr) as any ptr
if comparetext("text",p) then
k=pkString
return cast(any ptr,strptr(ftext))
elseif comparetext("x",p) then
k=pkInteger
return cast(any ptr,fx)
elseif comparetext("y",p) then
k=pkInteger
return cast(any ptr,fy)
elseif comparetext("cx",p) then
k=pkInteger
return cast(any ptr,fcx)
elseif comparetext("cy",p) then
k=pkInteger
return cast(any ptr,cy)
elseif comparetext("enabled",p) then
k=pkInteger
return cast(any ptr,cint(fenabled))
elseif comparetext("visible",p) then
k=pkInteger
return cast(any ptr,cint(fvisible))
else
return Base.GetProperty(p,k)
end if
end function
operator TControl.cast as any ptr
return @this
end operator
constructor TControl
fenabled=true
fvisible=true
end constructor
destructor TControl
if fparent then fparent->remove(this)
end destructor
/' TFrame '/
property TFrame.Handle as hwnd
return fhandle
end property
property TFrame.Handle(v as hwnd)
end property
property TFrame.Style as integer
return fstyle
end property
property TFrame.Style(v as integer)
fstyle=v
if iswindow(fhandle) then
SetWindowLong(fhandle,gwl_style,v)
SetWindowPos(fhandle,0,0,0,0,0,swp_nozorder or swp_nosize or swp_nomove or swp_noactivate or swp_framechanged)
end if
end property
property TFrame.ExStyle as integer
return fexstyle
end property
property TFrame.ExStyle(v as integer)
fexstyle=v
if iswindow(fhandle) then
SetWindowLong(fhandle,gwl_exstyle,v)
SetWindowPos(fhandle,0,0,0,0,0,swp_nozorder or swp_nosize or swp_nomove or swp_noactivate or swp_framechanged)
end if
end property
sub TFrame.Dispatch(byref m as TMessage)
select case m.msg
case wm_nccreate
SetWindowLong(m.dlg,GetClassLong(m.dlg,gcl_cbwndextra)-4,cint(@this))
creationdata=0
m.result=0
case wm_create
for i as integer=0 to fcontrolcount-1
if not iswindow(fcontrols[i]->fhandle) then fcontrols[i]->parent=this
next
m.result=0
end select
end sub
sub TFrame.Handler(byref m as TMessage)
end sub
sub TFrame.CreateHandle
FreeHandle
creationdata=this
CreateWindowEx(fexstyle,classname,ftext,fstyle,fx,fy,fcx,fcy,iif(fparent,fparent->fhandle,0),0,instance,0)
if isWindow(fhandle) then
SetWindowLong(fhandle,gwl_id,fid)
EnableWindow(fhandle,fenabled)
ShowWindow(fhandle,iif(fvisible,sw_show,sw_hide))
UpdateWindow(fhandle)
end if
end sub
sub TFrame.FreeHandle
if isWindow(fhandle) then
DestroyWindow(fhandle)
fhandle=0
end if
end sub
function TFrame.SetProperty(p as string,v as any ptr) as any ptr
if comparetext("style",p) then
function=cast(any ptr,fstyle)
Style=cast(integer,v)
elseif comparetext("exstyle",p) then
function=cast(any ptr,fexstyle)
exStyle=cast(integer,v)
elseif comparetext("handle",p) then
function=cast(any ptr,fhandle)
handle=cast(integer,v)
else
return Base.SetProperty(p,v)
end if
end function
function TFrame.GetProperty(p as string,byref k as TPropKind=pkAnyPtr) as any ptr
if comparetext("style",p) then
k=pkInteger
return cast(any ptr,fstyle)
elseif comparetext("exstyle",p) then
k=pkInteger
return cast(any ptr,fexstyle)
elseif comparetext("handle",p) then
k=pkInteger
return cast(any ptr,fhandle)
else
return Base.GetProperty(p,k)
end if
end function
operator TFrame.cast as any ptr
return @this
end operator
Code: Select all
/'
gui_11_forms.bas
copyright (c)2021 vasile eodor nastasa
http://rqwork.de
http://rqwork.ro
nastasa.eodor@gmail.com
'/
#include once "gui_11_core.bas"
#define P_Form(__ptr__) *cast(PForm,__ptr__)
#define W_Form(__dlg__) *cast(PForm,GetWindowLong(__dlg__,GetClassLong(__dlg__,gcl_cbwndextra)-4))
type PApplication as TApplication ptr
common shared as PApplication Application
type TApplication extends TComponent
declare sub Run
end type
type PForm as TForm ptr
enum TFormStyle
fsNormal=0,fStayOnTop,fsMDIChild,fsMDIClient
end enum
type TForm extends TFrame
protected:
as TFormStyle fformstyle
declare sub Dispatch(byref as TMessage)
public:
declare property FormStyle as TFormStyle
declare property FormStyle(as TFormStyle)
declare virtual sub Handler(byref as TMessage)
declare static function DlgProc(as hwnd,as uint,as wparam,as lparam) as lresult
declare static function Register(as string="TForm") as integer
declare virtual function SetProperty(p as string,v as any ptr) as any ptr
declare virtual function GetProperty(p as string,byref as TPropKind=pkAnyPtr) as any ptr
declare operator cast as any ptr
declare constructor
as TCloseEvent onClose
declare sub Close
end type
/' TForm '/
function TForm.Register(c as string="TForm") as integer
dim as wndclassex wcls
wcls.cbsize=sizeof(wcls)
wcls.lpfnwndproc=@dlgproc
wcls.hinstance=instance
wcls.lpszclassname=strptr(c)
wcls.hcursor=LoadCursor(0,idc_arrow)
wcls.cbwndextra+=4
return RegisterClassEx(@wcls)
end function
function TForm.DlgProc(dlg as hwnd,msg as uint,wparam as wparam,lparam as lparam) as lresult
dim as PFrame sender=iif(creationdata,creationdata,cast(PFrame,GetWindowLong(dlg,GetClassLong(dlg,gcl_cbwndextra)-4)))
dim as TMessage m=type<TMessage>(dlg,msg,wparam,lparam,0,sender)
if sender then
sender->fhandle=dlg
sender->Dispatch(m)
sender->Handler(m)
return m.result
else
sender=new TForm
? "new",sender,creationdata
sender->fhandle=dlg
sender->Dispatch(m)
sender->Handler(m)
return m.result
end if
return m.result
end function
sub TForm.Dispatch(byref v as TMessage)
Base.Dispatch(v) '''inherited
select case v.msg
case wm_close
dim as integer closeAction=1
if onclose then onclose(this,closeAction)
select case closeAction
case 0
v.result=1
case 1
case 2
ShowWindow(fhandle,sw_minimize)
case 3
ShowWindow(fhandle,sw_maximize)
end select
case wm_command
if isWindow(cast(hwnd,v.lparam)) then SendMessage(cast(hwnd,v.lparam),CM_COMMAND,hiword(v.wparam),loword(v.lparam))
v.result=0
end select
end sub
sub TForm.Handler(byref v as TMessage)
if v.result=0 then
v.result=DefWindowProc(v.dlg,v.msg,v.wparam,v.lparam)
else
exit sub
end if
end sub
sub TForm.Close
end sub
property TForm.FormStyle as TFormStyle
return fformstyle
end property
property TForm.FormStyle(v as TFormStyle)
fformstyle=v
select case v
case fStayOnTop
if not ((ExStyle and ws_ex_topmost)=ws_ex_topmost) then
'ExStyle=ExStyle or ws_ex_topmost
end if
case fsMDIChild
case fsMDIClient
end select
end property
function TForm.SetProperty(p as string,v as any ptr) as any ptr
if comparetext(p,"formstyle") then
'function=cast(integer ptr,fFormStyle)
FormStyle=cast(TFormStyle,cast(integer,v))
else
return Base.SetProperty(p,v)
end if
return 0
end function
function TForm.GetProperty(p as string,byref k as TPropKind=pkAnyPtr) as any ptr
if comparetext(p,"formstyle") then
k=pkInteger
return cast(integer ptr,fformstyle)
else
return Base.GetProperty(p)
end if
return 0
end function
operator TForm.cast as any ptr
return @this
end operator
constructor TForm
className="TForm"
fstyle=ws_overlappedwindow or ws_visible
fcx=250
fcy=150
end constructor
/' TApplication '/
sub TApplication.Run
dim as msg m
while GetMessage(@m,0,0,0)>0
TranslateMessage(@m)
DispatchMessage(@m)
wend
end sub
sub GUI11_Forms_initialization constructor
Application=new TApplication
? TForm.Register
END SUB
sub GUI11_Forms_Finalization destructor
UnregisterClass("TButton",instance)
end sub
Code: Select all
/'
gui_11_standards.bas
copyright (c)2021 vasile eodor nastasa
http://rqwork.de
http://rqwork.ro
nastasa.eodor@gmail.com
'/
#define P_Button(__ptr__) *cast(PButton,__ptr__)
#define W_Button(__dlg__) *cast(PButton,GetWindowLong(__dlg__,GetClassLong(__dlg__,gcl_cbwndextra)-4))
type PButton as TButton ptr
type TButton extends TFrame
protected:
declare sub Dispatch(byref as TMessage)
public:
declare static function DlgProc(as hwnd,as uint,as wparam,as lparam) as lresult
declare static function Register(as string="TButton",as string="Button") as integer
declare virtual sub Handler(byref as TMessage)
declare virtual function SetProperty(p as string,v as any ptr) as any ptr
declare virtual function GetProperty(p as string,byref as TPropKind=pkAnyPtr) as any ptr
declare operator cast as any ptr
declare constructor
declare sub Click
as TEvent onClick
end type
/' TButton '/
function TButton.Register(c as string="TButton",a as string="Button") as integer
dim as wndclassex wcls
wcls.cbsize=sizeof(wcls)
if GetClassInfoEx(0,a,@wcls) then
wcls.lpfnwndproc=@dlgproc
wcls.hinstance=instance
wcls.lpszclassname=strptr(c)
wcls.cbwndextra+=4
return RegisterClassEx(@wcls)
end if
return 0
end function
function TButton.DlgProc(dlg as hwnd,msg as uint,wparam as wparam,lparam as lparam) as lresult
dim as PFrame sender=iif(creationdata,creationdata,cast(PFrame,GetWindowLong(dlg,GetClassLong(dlg,gcl_cbwndextra)-4)))
dim as TMessage m=type<TMessage>(dlg,msg,wparam,lparam,0,sender)
if sender then
sender->fhandle=dlg
sender->Dispatch(m)
sender->Handler(m)
return m.result
else
sender=new TButton
sender->fhandle=dlg
sender->Dispatch(m)
sender->Handler(m)
return m.result
end if
return m.result
end function
sub TButton.Handler(byref v as TMessage)
dim as wndclassex wcls
wcls.cbsize=sizeof(wcls)
if GetClassInfoEx(0,this.classAncestor,@wcls) then
v.result=CallWindowProc(wcls.lpfnwndproc,v.dlg,v.msg,v.wparam,v.lparam)
else
v.result=0
end if
end sub
sub TButton.Dispatch(byref v as TMessage)
Base.Dispatch(v)
select case v.msg
case CM_COMMAND
if v.wparam=bn_clicked then click
v.result=0
end select
end sub
sub TButton.Click
if onclick then onclick(this)
end sub
function TButton.SetProperty(p as string,v as any ptr) as any ptr
return Base.SetProperty(p,v)
end function
function TButton.GetProperty(p as string,byref k as TPropKind=pkAnyPtr) as any ptr
return Base.GetProperty(p)
end function
operator TButton.cast as any ptr
return @this
end operator
constructor TButton
className="TButton"
classancestor="Button"
fstyle=ws_child or ws_visible
fcx=75
fcy=35
end constructor
sub GUI11_Standard_Initialization constructor
? TButton.register
end sub
sub GUI11_Standards_Finalization destructor
UnregisterClass("TButton",instance)
end sub
Code: Select all
#include once "gui_11_core.bas"
#include once "gui_11_forms.bas"
#include once "gui_11_standards.bas"
Code: Select all
''''''''''main program'''''''''''
'''''''''Create a form'''''''''''
'''''''''''''''''''''''''''''''''
#include once "fb_gui_11.bas"
dim shared as TForm Form
dim as TButton Button
Button.Parent=Form
Form.Parent=0
? "fcc=",form.controlcount
/' automation'/
sub FormClose(sender as TObject,byref a as integer)
a=0
end sub
sub ButtonClick(sender as TObject)
P_Button(@sender).text="you hit me"
Form.style=ws_caption or ws_sysmenu or ws_visible
Form.exstyle=ws_ex_dlgmodalframe
Form.onclose=@formclose
end sub
dim as hwnd w=CreateWindowEx(0,"TForm","Scratch",ws_overlappedwindow or ws_visible,100,100,400,250,form.handle,0,instance,0)
W_Form(w).FormStyle=fStayOnTop
w=CreateWindowEx(0,"TButton","Scratch",ws_child or ws_visible,10,10,75,25,w,0,instance,0)
W_Button(w).text="Hit me"
W_Button(w).onclick=@buttonclick
/' RTTI '/
SetPropValue(Form,"text",@"RTTI")
SetPropValue(Button,"text",@"RTTI")
Application->run