hello
does anyone know how to create a Panel (delphi style) or a PictureBox (vb6 style) with win32 api.
thank you
Creating a control's container
Re: Creating a control's container
first of all I apologize if my English is not perfect.
to be clear I would say I'm trying to encapsulate some windows controls for use as in RapidQ, which does not pose any major problems given the new functionalities object oriented FreeBasic, and I even managed to create a PictureBox class quite functional what I derivative from a Form class.
But I still put the question again: is it there's another, more effective way to create such contineurs?
thank you again.
to be clear I would say I'm trying to encapsulate some windows controls for use as in RapidQ, which does not pose any major problems given the new functionalities object oriented FreeBasic, and I even managed to create a PictureBox class quite functional what I derivative from a Form class.
But I still put the question again: is it there's another, more effective way to create such contineurs?
thank you again.
Re: Creating a control's container
For a simple picture box you can probably use a static control with an SS_BITMAP style.
Re: Creating a control's container
thankyou MichaelW
The problem is not to create a control to display images, but to create a container to group a collection of controls such as PictureBox of vb6 or Panel of Delphi or of microsoft .Net framework . The solution I adopted was to derive a new class of a Form class and then to apply some modifications using GetWindowLong, SetWindowLong and SetWindowPos to rid the container of the title bar and borders. But I think this solution belongs rather to the trick and not a logical approach.
The hierarchy of controls that I have encapsulate can be represented like below:
Component
+ Container
+ + Form
+++Panel
+ + Frame
+ Control
+ + CommandButton
+ + + CheckBox
+ + + OptionButton
+ + Label
+ + TextBox
This allowed me to test several examples that follow the RapidQ syntax such as:
Dim f as Form
Form.Show
app.run
but all this was a test to see if the project was feasible, a real project would need a longer advanced hierarchy with more classes abstract .
however, I can put the sources and examples at the disposal of the community FreeBasic if it is a real interest, because I have seen several projects of this type but I think the majority was a little complicated for easy use by a novice.
The problem is not to create a control to display images, but to create a container to group a collection of controls such as PictureBox of vb6 or Panel of Delphi or of microsoft .Net framework . The solution I adopted was to derive a new class of a Form class and then to apply some modifications using GetWindowLong, SetWindowLong and SetWindowPos to rid the container of the title bar and borders. But I think this solution belongs rather to the trick and not a logical approach.
The hierarchy of controls that I have encapsulate can be represented like below:
Component
+ Container
+ + Form
+++Panel
+ + Frame
+ Control
+ + CommandButton
+ + + CheckBox
+ + + OptionButton
+ + Label
+ + TextBox
This allowed me to test several examples that follow the RapidQ syntax such as:
Dim f as Form
Form.Show
app.run
but all this was a test to see if the project was feasible, a real project would need a longer advanced hierarchy with more classes abstract .
however, I can put the sources and examples at the disposal of the community FreeBasic if it is a real interest, because I have seen several projects of this type but I think the majority was a little complicated for easy use by a novice.
Re: Creating a control's container
Have you had a look at FreeQ IDEa and the FreeBASIC source code generated by RapidFRM
Form designer & editor? It creates source code that closely follows RapidQ format.
lazy led
Form designer & editor? It creates source code that closely follows RapidQ format.
lazy led
Re: Creating a control's container
Your Form Designer generates nearly 400 lines to create a simple window that contains a single panel! Is that what you call it a RAD programming??! And with a RQInclude.bi to include more :-(
With the miserable classes that I use, and despite their primary state, your heavy code is summed up in six lines of pure and perfect FreeBasic code .
Excuse me FreeBasic Merit better.
With the miserable classes that I use, and despite their primary state, your heavy code is summed up in six lines of pure and perfect FreeBasic code .
Code: Select all
#include "RQ_GUI_LITE.bi"
dim shared frmMain as form
dim shared pnlTest as Panel
pnlTest.Parent = frmMain
frmMain.Show
app.runRe: Creating a control's container
I take it, that is a "yes"
I didn't know RAD was limited to a simple Form and a single panel. I have fired the coder. I cannot stand waste of LOCs
lethargic led
I didn't know RAD was limited to a simple Form and a single panel. I have fired the coder. I cannot stand waste of LOCs
lethargic led
Re: Creating a control's container
ah! well I think I'll searching aillorled-bloon wrote:I take it, that is a "yes"
lethargic led
Re: Creating a control's container
An idea that can help.
core.bas
Common.bi
Form.bi
Button.bi
Edit.bi
Menus.bi
core.bas
Code: Select all
/'
Orizont Library
File "Core.bi"
coded by Nastase Eodor
NOTICE: This file is part of the Orizont IDE package and can't
be included in other distributions without authorization.
'/
'^
'|___ignore that
#include once "common.bi"
type TControl extends TObject
private:
declare static function WindowProc(hDlg as hwnd,msg as uint,wparam as wparam,lparam as lparam) as lresult
declare sub Add(Ctrl as PControl)
declare sub Insert(index As Integer,Ctrl as PControl)
declare sub Remove(Ctrl as PControl)
FZPosition as integer
protected:
FControlCount as integer
FControls as PControl ptr
FParentWindow as hwnd
FHandle as hwnd
FText as string
FLeft as integer
FTop as integer
FWidth as integer
FHeight as integer
FExStyle as integer
FStyle as integer
FParent as PControl
declare abstract sub ProcessMessages(byref message as TMessage)
declare abstract sub DefaultHandler(byref message as TMessage)
declare abstract sub RegisterClass
declare abstract sub CreateWindow
declare abstract sub DestroyWindow
public:
declare property Handle as hwnd
declare property Handle(value as hwnd)
declare property Parent as PControl
declare property Parent(value as PControl)
declare static function ControlWndProc as WNDPROC
declare sub InsertControl(Ctrl as PControl)
declare sub RemoveControl(Ctrl as PControl)
declare function IndexOfControl(Ctrl As PControl) as Integer
declare sub SendCancelMode(AControl as PControl)
declare sub Perform(msg as uint,wparam as wparam,lparam as lparam)
declare sub Update
declare sub Invalidate
declare sub Repaint
declare sub BringToFront
declare sub SendToBack
declare sub SetFocus
declare sub ClientToScreen(ByRef P as Point)
declare sub ScreenToClient(ByRef P as Point)
declare sub SetBounds(R as Rect)
declare sub SetBounds(X as integer,Y as Integer,CX as integer,CY as integer)
declare operator cast as any ptr
declare constructor
declare destructor
OnCreate as TNotifyEvent
OnWndProc as TWindowProcEvent
end type
#include once "graphics.bi"
#include once "menus.bi"
type TWinControl extends TControl
private:
FClientRect as Rect
FBrush as TBrush
protected:
Canvas as TCanvas
Font as TFont
declare virtual sub ProcessMessages(byref message as TMessage) override
declare virtual sub DefaultHandler(byref message as TMessage)
declare virtual sub RegisterClass
declare virtual sub CreateWindow
declare virtual sub DestroyWindow
public:
PopupMenu as TPopupMenu
declare operator cast as any ptr
declare constructor
declare destructor
OnShow as TNotifyEvent
OnPaint as TNotifyEvent
OnResize as TNotifyEvent
OnActivate as TNotifyEvent
OnDeactivate as TNotifyEvent
OnScroll as TScrollEvent
OnMouseDown as TMouseDownEvent
OnMouseUp as TMouseUpEvent
OnMouseMove as TMouseMoveEvent
OnMouseWheel as TMouseWheelEvent
OnKeyPress as TKeyPressEvent
OnKeyDown as TKeyDownEvent
OnKeyUp as TKeyUpEvent
OnTimer as TTimerEvent
end type
type TCustomForm extends TWinControl
private:
declare static function WindowProc(hDlg as hwnd,msg as uint,wparam as wparam,lparam as lparam) as lresult
protected:
declare virtual sub ProcessMessages(byref message as TMessage) override
declare virtual sub DefaultHandler(byref message as TMessage)
declare virtual sub RegisterClass
declare virtual sub CreateWindow
public:
Menu as TMainMenu
declare operator cast as any ptr
declare constructor
declare destructor
OnClose as TCloseEvent
end type
/' TControl '/
property TControl.Handle as hwnd
return FHandle
end property
property TControl.Handle(value as hwnd)
end property
property TControl.Parent as PControl
return FParent
end property
property TControl.Parent(value as PControl)
dim as PControl SaveParent = FParent
FParent = value
if IsWindow(FHandle) then
SetParent(FHandle,iif(value,value->FHandle,0))
else
if FParent then FParent->Add(this)
if SaveParent then SaveParent->Remove(this)
CreationData = this
CreateWindow
end if
end property
sub TControl.Add(Ctrl as PControl)
if (IndexOfControl(Ctrl) = -1) and (Ctrl <> 0) then
FControlCount += 1
FControls = reallocate(FControls,sizeof(PControl)*FControlCount)
FControls[FControlCount -1] = Ctrl
end if
End sub
sub TControl.Insert(index as Integer,Ctrl as PControl)
if Ctrl then
if Index > -1 and index < FControlCount then
FControlCount += 1
FControls = reallocate(FControls, sizeof(PControl)*FControlCount)
for i as Integer = FControlCount-1 to index +1 step -1
FControls[i] = FControls[i -1]
next i
FControls[Index] = Ctrl
end if
end if
end sub
sub TControl.InsertControl(Ctrl as PControl)
if (IndexOfControl(Ctrl) = -1) and (Ctrl <> 0) then
FControlCount += 1
FControls = reallocate(FControls,sizeof(PControl)*FControlCount)
FControls[FControlCount -1] = Ctrl
Ctrl->FParent = this
end if
end sub
sub TControl.Remove(Ctrl as PControl)
if Ctrl then
dim as Integer Id,i
Id = IndexOfControl(Ctrl)
if Id <> -1 then
for i = Id +1 to FControlCount -1
FControls[i -1] = FControls[i]
next
FControlCount -= 1
FControls = reallocate(FControls,sizeof(PControl)*FControlCount)
end if
end if
end sub
sub TControl.RemoveControl(Ctrl as PControl)
if Ctrl then
dim as integer Id,i
Id = IndexOfControl(Ctrl)
if Id <> -1 then
for i = Id +1 to FControlCount -1
FControls[i -1] = FControls[i]
next
FControlCount -= 1
FControls = reallocate(FControls,sizeof(PControl)*FControlCount)
Ctrl->Free
end if
end if
end sub
function TControl.IndexOfControl(Ctrl as PControl) as integer
for i as Integer = 0 to FControlCount -1
if FControls[i] = Ctrl then return i
next i
return -1
end function
function TControl.WindowProc(hDlg as hwnd,msg as uint,wparam as wparam,lparam as lparam) as lresult
dim as PControl Ctrl
dim as TMessage message
Ctrl = cast(any ptr,GetWindowLong(hDlg,GetClassLong(hDlg,GCL_CBWNDEXTRA)-4))
if Ctrl then
CreationData = 0
Ctrl->FHandle = hDlg
else
Ctrl = CreationData
SetWindowLong(hDlg,GetClassLong(hDlg,GCL_CBWNDEXTRA)-4,cint(Ctrl))
end if
if (Ctrl = 0 and CreationData = 0) then
Ctrl = New TWinControl
message = type(hDlg,msg,wparam,lparam,0,Ctrl)
SetWindowLong(hDlg,GetClassLong(hDlg,GCL_CBWNDEXTRA)-4,cint(Ctrl))
Ctrl->FHandle = hDlg
Ctrl->DispatchMessage(message)
Ctrl->ProcessMessages(message)
if Ctrl->OnWndProc then
Ctrl->OnWndProc(message)
end if
return message.result
elseif Ctrl then
message = type(hDlg,msg,wparam,lparam,0,Ctrl)
Ctrl->DispatchMessage(message)
Ctrl->ProcessMessages(message)
if Ctrl->OnWndProc then
Ctrl->OnWndProc(message)
end if
return message.result
end if
return NULL
end function
function TControl.ControlWndProc as WNDPROC
return @WindowProc
end function
sub TControl.Perform(msg as uint,wparam as wparam,lparam as lparam)
if IsWindow(FHandle) then
SendMessage(FHandle,msg,wparam,lparam)
end if
end sub
sub TControl.SendCancelMode(AControl as PControl)
if AControl then
for i as integer = 0 to AControl->FControlCount -1
AControl->FControls[i]->Perform(WM_CANCELMODE,0,0)
SendCancelMode(AControl->FControls[i])
next i
end if
end sub
sub TControl.Update
if IsWindow(FHandle) then UpdateWindow(FHandle)
end sub
sub TControl.Invalidate
if IsWindow(FHandle) then
InvalidateRect(FHandle,0,true)
end if
end sub
sub TControl.Repaint
if IsWindow(FHandle) then
RedrawWindow(FHandle,0,0,RDW_ERASE or RDW_INVALIDATE)
UpdateWindow(FHandle)
end if
end sub
sub TControl.BringToFront
if IsWindow(FHandle) then
BringWindowToTop(FHandle)
end if
end sub
sub TControl.SendToBack
if IsWindow(FHandle) then
dim as hwnd ctrlwnd
if FParent then
if FZPosition > 0 then
ctrlwnd = FParent->FControls[FZPosition]->FHandle
SetWindowPos(FHandle,ctrlwnd,0,0,0,0,SWP_NOMOVE or SWP_NOSIZE or SWP_SHOWWINDOW)
end if
end if
end if
end sub
sub TControl.SetFocus
if IsWindow(FHandle) then
.SetFocus(FHandle)
end if
end sub
sub TControl.ClientToScreen(ByRef P as Point)
if IsWindow(FHandle) then
.ClientToScreen(FHandle,@P)
end if
end sub
sub TControl.ScreenToClient(ByRef P as Point)
if IsWindow(FHandle) then
.ScreenToClient(FHandle,@P)
end if
end sub
sub TControl.SetBounds(R as Rect)
if IsWindow(FHandle) then
MoveWindow(FHandle,R.Left,R.Top,R.Right,R.Bottom,1)
end if
FLeft = R.Left
FTop = R.Top
FWidth = R.Right
FHeight = R.Bottom
end sub
sub TControl.SetBounds(X as integer,Y as Integer,CX as integer,CY as integer)
if IsWindow(FHandle) then
MoveWindow(FHandle,X,Y,CX,CY,1)
end if
FLeft = X
FTop = Y
FWidth = CX
FHeight = CY
end sub
operator TControl.cast as any ptr
return @this
end operator
constructor TControl
end constructor
destructor TControl
if FParent then FParent->RemoveControl(this)
FControls = callocate(0)
end destructor
/' TWinControl '/
sub TWinControl.ProcessMessages(byref message as TMessage)
select case message.msg
case WM_CREATE: print "fired oncreate = " & ClassName
FParentWindow = GetParent(FHandle)
for i as integer = 0 to FControlCount-1
FControls[i]->Parent = this
next
if OnCreate then
OnCreate(this)
end if
message.result = 0
case WM_PAINT
dim as PAINTSTRUCT PS
BeginPaint(FHandle,@PS)
Canvas.Handle = PS.hDC
if OnPaint then OnPaint(this)
EndPaint(FHandle,@PS)
Canvas.Handle = 0
Message.Result = 0
case WM_ERASEBKGND
GetClientRect(FHandle,@FClientRect)
FillRect(cast(HDC,Message.WParam),@FClientRect,FBrush)
Message.Result = 0
case WM_CTLCOLORMSGBOX to WM_CTLCOLORSTATIC
dim as HWND hCtrl = cast(HWND,Message.LParam)
dim as PControl Ctrl = cast(PControl,cast(any ptr,GetWindowLong(hCtrl,GetClassLong(hCtrl,GCL_CBWNDEXTRA)-4)))
if Ctrl then
Message.Result = SendMessage(hCtrl,CM_CTLCOLOR,Message.WParam,Message.LParam)
exit sub
end if
case WM_HSCROLL
if IsWindow(cast(HWND,Message.LParam)) then
SendMessage(cast(HWND,Message.LParam),CM_HSCROLL,loword(Message.WParam),hiword(Message.WParam))
if onScroll then onScroll(this,loword(Message.WParam),hiword(Message.WParam))
end if
Message.Result = 0
case WM_VSCROLL
if IsWindow(cast(HWND,Message.LParam)) then
Message.Result = SendMessage(cast(HWND,Message.LParam),CM_VSCROLL,loword(Message.WParam),hiword(Message.WParam))
if onScroll then onScroll(this,loword(Message.WParam),hiword(Message.WParam))
else
Message.Result = 0
end if
case WM_ACTIVATE
select case LoWord(Message.WParam)
case wa_active,wa_clickactive
'if ActiveControl then ActiveControl->SetFocus
if onActivate then onActivate(this)
case wa_inactive
if onDeActivate then onDeActivate(this)
end select
Message.result = 0
case WM_GETDLGCODE
Message.Result = dlgc_wantallkeys
case WM_RBUTTONDOWN :print "r_button_is_down"
if IsMenu(PopupMenu.Handle) then
dim as Point P
P.x = loword(message.lparam)
P.y = hiword(message.lparam)
this.ClientToScreen(P)
Message.Result = TrackPopupMenu(PopupMenu.Handle,tpm_leftalign,P.x,P.y,0,FHandle,0)
end if
Message.Result = 0
case WM_NCLBUTTONDOWN: print "nc button down"
SendCancelMode(this)
Message.Result = 0
case WM_CANCELMODE: print "cancel mode"
if GetCapture = Message.Handle then
ReleaseCapture
SendMessage(Message.Handle,WM_LBUTTONUP,0,&HFFFFFFFF)
end if
message.result = 0
case WM_GETDLGCODE
message.result = dlgc_wantallkeys
case WM_NEXTDLGCTL
'dim as PControl nextCtrl
'nextCtrl = AControl.SelectNext(ActiveControl)
'if nextCtrl then nextCtrl->Set
message.result = 0
case WM_INITMENUPOPUP:print "initpopupmenu"
if not IsIconic(FHandle)then
if hiword(Message.LParam) = 0 then
dim as menuinfo mif
mif.cbsize = sizeof(mif)
mif.fmask = mim_menudata
if GetMenuInfo(cast(hmenu,Message.WParam),@mif) then
if mif.dwmenudata then
if @PopupMenu = cast(any ptr,mif.dwmenudata) then
dim as PPopupMenu DropDownMenu = cast(TPopupMenu ptr,cast(any ptr,mif.dwmenudata))
if DropDownMenu then
if (DropDownMenu->onDropDown<>0) then DropDownMenu->onDropDown(*DropDownMenu)
end if
end if
end if
end if
end if
message.result = 0
end if
end select
DefaultHandler(message)
end sub
sub TWinControl.DefaultHandler(byref message as TMessage)
message.result = DefWindowProc(message.handle,message.msg,message.wparam,message.lparam)
end sub
sub TWinControl.RegisterClass
dim as WNDCLASSEX wcls
wcls.cbsize = sizeof(WNDCLASSEX)
wcls.cbWndExtra += 4
wcls.hInstance = instance
wcls.hbrBackground = cast(hbrush,16)
wcls.hcursor = LoadCursor(0,IDC_ARROW)
wcls.lpfnWndProc = ControlWndProc'@DefWindowProc
wcls.lpszClassName = strptr(ClassName)
RegisterClassEx(@Wcls)
end sub
sub TWinControl.CreateWindow
'CreationData = @this
CreateWindowEx(FExStyle,ClassName,FText,FStyle,FLeft,FTop,FWidth,FHeight,iif(FParent,FParent->FHandle,0),0,instance,0)
end sub
sub TWinControl.DestroyWindow
if IsWindow(FHandle) then
.DestroyWindow(FHandle)
end if
end sub
operator TWinControl.cast as any ptr
return @this
end operator
constructor TWinControl
ClassName = "TWinControl"
FStyle = WS_OVERLAPPEDWINDOW or WS_VISIBLE
RegisterClass
end constructor
destructor TWinControl
end destructor
/' TCustomForm '/
function TCustomForm.WindowProc(hDlg as hwnd,msg as uint,wparam as wparam,lparam as lparam) as lresult
dim as PCustomForm Ctrl
dim as TMessage message
Ctrl = cast(any ptr,GetWindowLong(hDlg,GetClassLong(hDlg,GCL_CBWNDEXTRA)-4))
if Ctrl then
CreationData = 0
Ctrl->FHandle = hDlg
else
Ctrl = CreationData
SetWindowLong(hDlg,GetClassLong(hDlg,GCL_CBWNDEXTRA)-4,cint(Ctrl))
end if
if (Ctrl = 0 and CreationData = 0) then
Ctrl = New TCustomForm
message = type(hDlg,msg,wparam,lparam,0,Ctrl)
SetWindowLong(hDlg,GetClassLong(hDlg,GCL_CBWNDEXTRA)-4,cint(Ctrl))
Ctrl->FHandle = hDlg
Ctrl->ProcessMessages(message)
if Ctrl->OnWndProc then
Ctrl->OnWndProc(message)
end if
return message.result
elseif Ctrl then
message = type(hDlg,msg,wparam,lparam,0,Ctrl)
Ctrl->ProcessMessages(message)
if Ctrl->OnWndProc then
Ctrl->OnWndProc(message)
end if
return message.result
end if
return NULL
end function
sub TCustomForm.ProcessMessages(byref message as TMessage)
select case message.msg
case WM_CREATE: print "**fired oncreate = " & ClassName
Menu.Parent = this
if OnCreate then
OnCreate(this)
end if
message.result = 0
case WM_CLOSE : print "fired onclose = " & ClassName
dim as integer action = 0
if OnClose then
OnClose(this,action)
end if
select case action
case 1
exit sub
case 2
case 3
end select
message.result = 0
case WM_ENTERMENULOOP
SendCancelMode(this)
Message.Result = 0
case else
Message.Result = 0
end select
DefaultHandler(message)
end sub
sub TCustomForm.DefaultHandler(byref message as TMessage)
message.result = DefWindowProc(message.handle,message.msg,message.wparam,message.lparam)
end sub
sub TCustomForm.RegisterClass
dim as WNDCLASSEX wcls
wcls.cbsize = sizeof(WNDCLASSEX)
if GetClassInfoEx(instance,"TWinControl",@wcls) then
wcls.lpfnwndproc = @WindowProc
wcls.lpszClassName = strptr(ClassName)
RegisterClassEx(@Wcls)
end if
end sub
sub TCustomForm.CreateWindow
CreateWindowEx(FExStyle,ClassName,FText,FStyle,FLeft,FTop,FWidth,FHeight,iif(FParent,FParent->FHandle,0),0,instance,0)
end sub
operator TCustomForm.cast as any ptr
return @this
end operator
constructor TCustomForm
ClassName = "TCustomForm"
FWidth = 350
FHeight = 250
FText = "CustomForm"
FStyle = WS_OVERLAPPEDWINDOW or WS_VISIBLE
RegisterClass
end constructor
destructor TCustomForm
end destructor
''''Test''''
#include "Form.bi"
#include "Button.bi"
#include "Edit.bi"
sub _create(sender as TObject)
MessageBox(0,sender.classname,"CREATE",MB_ICONERROR)
end sub
sub _close(sender as TObject,byref action as integer)
if MessageBox(0,sender.classname,"CLOSE",MB_ICONERROR or MB_YESNO ) <> idyes then
action = 1
end if
end sub
sub _wndproc(byref message as TMessage)
'if message.msg < 100 then print sender.classname, message.msg
end sub
sub _click( Sender as TObject)
MessageBox(0,sender.classname,"CLICK",MB_ICONERROR)
end sub
sub _eclick( Sender as TObject)
print sender.classname,"CLICK"
end sub
sub _change( Sender as TObject)
MessageBox(0,sender.classname,"CHANGE",MB_ICONERROR)
end sub
sub _update( Sender as TObject)
MessageBox(0,sender.classname,"UPDATE",MB_ICONERROR)
end sub
dim as TWinControl Wc
Wc.oncreate = @_create
Wc.Parent = 0
dim as TCustomForm cF
cF.oncreate = @_create
cF.onclose = @_close
cF.Parent = Wc
dim as TForm F,F1
F.FormStyle = fsMDIClient
F.oncreate = @_create
F.onclose = @_close
F.Parent = Wc
F1.FormStyle = fsMDIChild
F1.onwndproc = @_wndproc
F1.Parent = F
dim as TButton B
B.Parent = F1
B.onclick = @_click
dim as TEdit E
E.Parent = F1
E.onclick = @_eclick
E.onchange = @_change
E.onupdate = @_update
sub mClick(sender as tobject)
messagebox 0,tmenuitemclass(@sender).caption,"ok",mb_ok
end sub
dim as TMenuItem iFile, iNew, iOpen, iSp, iExit
iFile.Caption = "File"
iFile.OnClick = @mclick
iNew.Caption = "New"
iNew.OnClick = @mclick
iOpen.Caption = "Open"
iOpen.OnClick = @mclick
iSp.Caption = "-"
iExit.Caption = "Exit"
iExit.OnClick = @mclick
iFile.Add iNew
iFile.Add iOpen
iFile.Add iSp
iFile.Add iExit
F.Menu.Add iFile
F1.PopupMenu.Add(iFile)
dim as hwnd wnd = CreateWindowEx(WS_EX_TOOLWINDOW,"TForm","Scrach",WS_OVERLAPPEDWINDOW or WS_VISIBLE,30,30,200,100,Wc.Handle,0,instance,0)
print "WinControl " & @Wc
print "WinControl.handle " & Wc.handle
print "WinControl.oncreate " & Wc.oncreate
print "control*wnd " & Q_Control(wnd)
print "Wnd " & Q_Control(wnd)->Handle'
print "CustomForm " & @cF
print "CustomForm.handle " & cF.Handle
print "CustomForm.onclose " & cF.onclose
print "Form " & @F
print "Form.handle " & F.Handle
print "Form.onclose " & F.onclose
print "Button " & @B
print "Button.handle " & B.Handle
print "Button.onclick " & B.onclick
print "F.style = " & F.FormStyle,"F1.style = " & F1.FormStyle
print "lastError was = " & GetLastError
dim as msg m
while GetMessage(@m,0,0,0) > 0
TranslateMessage(@m)
DispatchMessage(@m)
wend
Code: Select all
#include once "windows.bi"
#include once "win/commctrl.bi"
#define instance GetModuleHandle(NULL)
#define Q_Control(hDlg) cast(PControl,GetWindowLong(hDlg,GetClassLong(hDlg,GCL_CBWNDEXTRA)-4))
common shared as any ptr CreationData
const CM_COMMAND = WM_APP + 100
const CM_CTLCOLOR = WM_APP + 101
const CM_HSCROLL = WM_APP + 102
const CM_VSCROLL = WM_APP + 103
type PMessage as TMessage ptr
type PObject as TObject ptr
type PControl as TControl ptr
type PWinControl as TWinControl ptr
type PCustomForm as TCustomForm ptr
/' TMessage '/
type TMessage '''extends Object
Handle as HWND
Msg as uint
wParam as WPARAM
lParam as LPARAM
Result as LRESULT
Sender as PControl
end type
type TWindowProcEvent as sub(ByRef Message as TMessage)
/' TObject '/
type TObject extends Object
protected:
declare virtual sub DispatchMessage(ByRef Message as TMessage)
public:
ClassName as string
Name as string
OnMessage as TWindowProcEvent
declare sub Free
declare operator cast as string
declare operator cast as any ptr
declare constructor
declare destructor
end type
/' TObject '/
sub TObject.DispatchMessage(ByRef Message as TMessage)
if OnMessage <> 0 then
Message.Sender = this
OnMessage(Message)
end if
end sub
sub TObject.Free
delete @this
end sub
operator TObject.cast as string
return Name
end operator
operator TObject.cast as any ptr
return @this
end operator
constructor TObject
end constructor
destructor TObject
end destructor
type TEvent as sub()
type TNotifyEvent as sub(ByRef Sender as TObject)
type TCloseEvent as sub(ByRef Sender as TObject,ByRef CloseAction as integer)
type TScrollEvent as sub(ByRef Sender as TObject,Code as integer,ByRef ScrollPos as integer)
type TMouseDownEvent as sub(ByRef Sender as TObject,MouseButton as short,x as integer,y as integer,shift as integer)
type TMouseUpEvent as sub(ByRef Sender as TObject,MouseButton as short,x as integer,y as integer,shift as integer)
type TMouseMoveEvent as sub(ByRef Sender as TObject,x as integer,y as integer,shift as integer)
type TMouseWheelEvent as sub(ByRef Sender as TObject,Direction as short,x as integer,y as integer,shift as integer)
type TKeyPressEvent as sub(ByRef Sender as TObject,key as byte)
type TKeyDownEvent as sub(ByRef Sender as TObject,key as word,shift as integer)
type TKeyUpEvent as sub(ByRef Sender as TObject,key as word,shift as integer)
type TTimerEvent as sub(ByRef Sender as TObject,TimerId as integer,TimerProc as any ptr = 0)
enum TControlState
ccsNormal,ccsDesignMode
end enum
enum TControlStyle
ccDblClick,ccsEnabled,ccsOpaque,ccsTransparent
end enum
enum TAlign
alNone,alLeft,alRight,alTop,alBottom,alClient
end enum
enum TCloseAction
caNone,caFree,caHide,caMinimize
end enum
/' TConstraints '/
type TConstraints
MinWidth as integer
MaxWidth as integer
MinHeight as integer
MaxHeight as integer
declare operator Let(ByRef value as TConstraints)
declare operator cast as any ptr
declare constructor(AMinWidth as integer = 0,AMaxWidth as integer = 0,AMinHeight as integer = 0,AMaxHeight as integer = 0)
end type
/' TConstraints '/
operator TConstraints.Let(ByRef value as TConstraints)
MinWidth = value.MinWidth
MaxWidth = value.MaxWidth
MinHeight = value.MinHeight
MaxHeight = value.MaxHeight
end operator
operator TConstraints.cast as any ptr
return @this
end operator
constructor TConstraints(AMinWidth as integer = 0,AMaxWidth as integer = 0,AMinHeight as integer = 0,AMaxHeight as integer = 0)
MinWidth = AMinWidth
MaxWidth = AMaxWidth
MinHeight = AMinHeight
MaxHeight = AMaxHeight
end constructor
Code: Select all
enum TFormStyle
fsNormal = 0
fsMDIChild
fsMDIClient
end enum
type TForm extends TCustomForm
private:
FClientStruct as CLIENTCREATESTRUCT
FClient as hwnd
FFormStyle as TFormStyle
protected:
declare sub ProcessMessages(byref message as TMessage) override
declare sub DefaultHandler(byref message as TMessage)
declare sub RegisterClass
declare sub CreateWindow
public:
declare property FormStyle as integer
declare property FormStyle(value as integer)
declare property Parent as PControl
declare property Parent(value as PControl)
declare operator cast as any ptr
declare constructor
declare destructor
OnClose as TCloseEvent
end type
/' TForm '/
property TForm.FormStyle as integer
return FFormStyle
end property
property TForm.FormStyle(value as integer)
FFormStyle = value
end property
property TForm.Parent as PControl
return FParent
end property
property TForm.Parent(value as PControl)
Base.Parent = value
if *value is TForm then
if cast(TForm ptr,value)->FFormStyle = fsMDIClient then :print "is mdiclient"
if IsWindow(FHandle) then
SetParent(FHandle,iif(value,cast(TForm ptr,value)->FClient,0))
end if
end if
end if
end property
sub TForm.ProcessMessages(byref message as TMessage)
select case message.msg
case WM_CREATE: print "***fired oncreate = " & ClassName
if IsMenu(Menu.Handle) then
Print "Try to set menu ",SetMenu(FHandle,Menu.Handle)
Print "Try to draw menu ",DrawMenuBar(FHandle)
UpdateWindow(FHandle)
end if
if FFormStyle = fsMDIClient then
FClientStruct.hWindowMenu = 0
FClientStruct.idFirstChild = &H00FF
FClient = CreateWindowEx(0,"MDICLIENT","",WS_CHILD OR WS_VISIBLE OR WS_VSCROLL OR WS_HSCROLL OR WS_CLIPSIBLINGS OR WS_CLIPCHILDREN,0,0,0,0,FHandle,cast(hmenu,&hcac),instance,@FClientStruct)
Print FClient
end if
if OnCreate then
OnCreate(this)
end if
message.result = 0
case WM_CLOSE : print "fired onclose = " & ClassName
dim as integer action = 0
if OnClose then
OnClose(this,action)
end if
select case action
case 1
exit sub
case 2
case 3
end select
message.result = 0
case WM_COMMAND :print "send message WM_COMMAND",message.lparam
if message.lparam <> 0 then
SendMessage(cast(hwnd,message.lparam),WM_APP+100,message.wparam,message.lparam)
'DispatchControlMsg(message)
else
if hiword(message.wparam) = 1 then
'DispatchAccelMsg(message)
else
'DispatchMenuMsg(message)
Menu.ProcessMessages(message)
end if
end if
message.result = 0
case WM_PARENTNOTIFY
Print "parent notify " & Loword(message.wparam) & " " & hiword(message.wparam) & " " & message.lparam
print message.sender->classname, message.sender,@this
message.result = 0
case WM_SIZE
'if IsWindow(FClient) then
' if OnResize then OnResize(this)
' message.result = 0
' exit sub
'else
if OnResize then OnResize(this)
message.result = 0
'end if
case WM_INITMENU
if IsIconic(FHandle) = 0 then
dim as menuinfo mif
mif.cbsize = sizeof(mif)
mif.fmask = mim_menudata
if GetMenuInfo(cast(HMENU,Message.WParam),@mif) then
if @Menu = cast(any ptr,mif.dwmenudata) then
with *cast(TMenu ptr,cast(any ptr,mif.dwmenudata))
if .onActivate then .onActivate(*cast(TMenu ptr,cast(any ptr,mif.dwmenudata)))
end with
end if
end if
Message.Result = 0
end if
end select
DefaultHandler(message)
end sub
sub TForm.DefaultHandler(byref message as TMessage)
select case FFormStyle
case fsMDIChild
message.result = DefMDIChildProc(message.handle,message.msg,message.wparam,message.lparam)
case fsMDIClient
message.result = DefFrameProc(message.handle,FClient,message.msg,message.wparam,message.lparam)
case else
message.result = DefWindowProc(message.handle,message.msg,message.wparam,message.lparam)
end select
end sub
sub TForm.RegisterClass
dim as WNDCLASSEX wcls
wcls.cbsize = sizeof(WNDCLASSEX)
if GetClassInfoEx(instance,"TCustomForm",@wcls) then
wcls.style = 8
wcls.lpszClassName = strptr(ClassName)
RegisterClassEx(@Wcls)
end if
end sub
sub TForm.CreateWindow
dim as hwnd ParentWnd =iif(FParent, iif(FFormStyle=fsMDIChild,cast(TForm ptr,FParent)->FClient,FParent->FHandle), 0)
CreateWindowEx(iif(FFormStyle=fsMDIChild,FExStyle or WS_EX_MDICHILD,FExStyle),_
ClassName,FText,FStyle,FLeft,FTop,FWidth,FHeight,_
ParentWnd,_
0,instance,0)
end sub
operator TForm.cast as any ptr
return @this
end operator
constructor TForm
ClassName = "TForm"
FWidth = 250
FHeight = 200
FText = "Form"
FStyle = WS_OVERLAPPEDWINDOW or WS_VISIBLE or WS_CLIPSIBLINGS or WS_CLIPCHILDREN
RegisterClass
end constructor
destructor TForm
end destructor
Code: Select all
type TButton extends TWinControl
private:
protected:
declare virtual sub ProcessMessages(byref message as TMessage)
declare virtual sub DefaultHandler(byref message as TMessage)
declare virtual sub RegisterClass
declare virtual sub CreateWindow
public:
declare operator cast as any ptr
declare constructor
declare destructor
OnClick as TNotifyEvent
end type
/' TButton '/
sub TButton.ProcessMessages(byref message as TMessage)
select case message.msg
case WM_CREATE: print "fired oncreate = " & ClassName
if OnCreate then
OnCreate(this)
end if
message.result = 0
case WM_APP + 100
Print "button fired command " & message.wparam & " " & " " & message.lparam
if hiword(message.wparam) = BN_CLICKED then
if OnClick then
OnClick(this)
end if
end if
message.result = 0
end select
DefaultHandler(message)
end sub
sub TButton.DefaultHandler(byref message as TMessage)
dim as WNDCLASSEX wcls
wcls.cbsize = sizeof(WNDCLASSEX)
if GetClassInfoEx(0,"button",@wcls) then
message.result = CallWindowProc(wcls.lpfnWndProc,message.handle,message.msg,message.wparam,message.lparam)
else
message.result = DefWindowProc(message.handle,message.msg,message.wparam,message.lparam)
end if
end sub
sub TButton.RegisterClass
dim as WNDCLASSEX wcls
wcls.cbsize = sizeof(WNDCLASSEX)
if GetClassInfoEx(0,"button",@wcls) then
wcls.lpfnWndProc = ControlWndProc
wcls.lpszClassName = strptr(ClassName)
wcls.hInstance = instance
wcls.cbWndExtra += 4
Print "Register " & RegisterClassEx(@Wcls)
end if
end sub
sub TButton.CreateWindow
'CreationData = @this
CreateWindowEx(FExStyle,ClassName,FText,FStyle,FLeft,FTop,FWidth,FHeight,iif(FParent,FParent->FHandle,0),0,instance,0)
end sub
operator TButton.cast as any ptr
return @this
end operator
constructor TButton
ClassName = "TButton"
FWidth = 75
FHeight = 25
FText = "Button"
FStyle = WS_CHILD or WS_VISIBLE
RegisterClass
end constructor
destructor TButton
end destructor
Code: Select all
type TEdit extends TWinControl
private:
protected:
declare virtual sub ProcessMessages(byref message as TMessage)
declare virtual sub DefaultHandler(byref message as TMessage)
declare virtual sub RegisterClass
declare virtual sub CreateWindow
public:
declare operator cast as any ptr
declare constructor
declare destructor
OnClick as TNotifyEvent
OnChange as TNotifyEvent
OnUpdate as TNotifyEvent
end type
/' TEdit '/
sub TEdit.ProcessMessages(byref message as TMessage)
select case message.msg
case WM_CREATE: print "fired oncreate = " & ClassName
if OnCreate then
OnCreate(this)
end if
message.result = 0
case WM_APP + 100
Print "edit fired command " & message.wparam & " " & " " & message.lparam
select case message.wparam
case BN_CLICKED
if OnClick then
OnClick(this)
end if
case EN_CHANGE
if OnChange then
OnChange(this)
end if
case EN_UPDATE
if OnUpdate then
OnUpdate(this)
end if
end select
message.result = 0
end select
DefaultHandler(message)
end sub
sub TEdit.DefaultHandler(byref message as TMessage)
dim as WNDCLASSEX wcls
wcls.cbsize = sizeof(WNDCLASSEX)
if GetClassInfoEx(0,"Edit",@wcls) then
message.result = CallWindowProc(wcls.lpfnWndProc,message.handle,message.msg,message.wparam,message.lparam)
else
message.result = DefWindowProc(message.handle,message.msg,message.wparam,message.lparam)
end if
end sub
sub TEdit.RegisterClass
dim as WNDCLASSEX wcls
wcls.cbsize = sizeof(WNDCLASSEX)
if GetClassInfoEx(0,"Edit",@wcls) then
wcls.lpfnWndProc = ControlWndProc
wcls.lpszClassName = strptr(ClassName)
wcls.hInstance = instance
wcls.cbWndExtra += 4
Print "Register " & RegisterClassEx(@Wcls)
end if
end sub
sub TEdit.CreateWindow
'CreationData = @this
CreateWindowEx(FExStyle,ClassName,FText,FStyle,FLeft,FTop,FWidth,FHeight,iif(FParent,FParent->FHandle,0),0,instance,0)
end sub
operator TEdit.cast as any ptr
return @this
end operator
constructor TEdit
ClassName = "TEdit"
FWidth = 121
FHeight = 21
FLeft = 90
FText = "Edit"
FExStyle = WS_EX_CLIENTEDGE
FStyle = WS_CHILD or WS_VISIBLE
RegisterClass
end constructor
destructor TEdit
end destructor
Code: Select all
type PMenu as TMenu ptr
type PMainMenu as TMainMenu ptr
type PPopupMenu as TPopupMenu ptr
type PMenuItem as TMenuItem ptr
#define TMenuItemClass(__Ptr__) *cast(PMenuItem,__Ptr__)
#define TMenuClass(__Ptr__) *cast(PMenu,__Ptr__)
#define TPopupMenuClass(__Ptr__) *cast(PPopupMenu,__Ptr__)
const MIM_BACKGROUND = &H2
const MIM_APPLYTOSUBMENUS = &H80000000
const MIM_MENUDATA = &H00000008
type TMenuItem extends TObject
private:
FInfo as MENUITEMINFO
FCount as integer
FItems as PMenuItem ptr
FCaption as string
FChecked as integer
FRadioItem as integer
FParent as PMenuItem
FEnabled as integer
FVisible as integer
FCommand as integer
FMenuIndex as integer
FImageIndex as integer
FOwnerDraw as integer
protected:
FHandle as HMENU
FMenu as HMENU
FOwner as PObject
public:
Tag as any ptr
declare property Owner as PObject
declare property Owner(value as PObject)
declare property Menu as HMENU
declare property Menu(value as HMENU)
declare property Parent as PMenuItem
declare property Parent(value as PMenuItem)
declare property Command as integer
declare property Command(value as integer)
declare property MenuIndex as integer
declare property MenuIndex(value as integer)
declare property ImageIndex as integer
declare property ImageIndex(value as integer)
declare property Handle as HMENU
declare property Handle(value as HMENU)
declare property Caption as string
declare property Caption(value as string)
declare property Checked as integer
declare property Checked(value as integer)
declare property RadioItem as integer
declare property RadioItem(value as integer)
declare property Enabled as integer
declare property Enabled(value as integer)
declare property Visible as integer
declare property Visible(value As integer)
declare property Count as integer
declare property Count(value as integer)
declare property Item(index as integer) as PMenuItem
declare property Item(index as integer,value as PMenuItem)
declare sub Click
declare sub Add(value as PMenuItem)
declare sub Remove(value as PMenuItem)
declare sub Insert(index as integer,value as PMenuItem)
declare sub Clear
declare sub SetInfo(byref value as MENUITEMINFO)
declare function IndexOf(value as PMenuItem) as integer
declare function Find(value as integer) as PMenuItem
declare operator cast as any ptr
declare constructor
declare destructor
OnClick as TNotifyEvent
end type
type TMenu extends TObject
private:
FCount as integer
FItems as PMenuItem ptr
protected:
FInfo as MENUINFO
FHandle as HMENU
FStyle as integer
FColor as integer
FParentWindow as HWND
FIncSubItems as integer
declare virtual sub ProcessMessages(byref message as TMessage)
public:
Tag as any ptr
declare property ParentWindow as hwnd
declare property ParentWindow(value as hwnd)
declare property Handle as HMENU
declare property Handle(value as HMENU)
declare property Style as integer
declare property Style(value as integer)
declare property ColorizeEntire as integer
declare property ColorizeEntire(value as integer)
declare property Color as integer
declare property Color(value as integer)
declare property Count as integer
declare property Count(value as integer)
declare property Item(index as integer) as PMenuItem
declare property Item(index as integer,value as PMenuItem)
declare sub Add(value as PMenuItem)
declare sub Remove(value as PMenuItem)
declare sub Insert(index as integer,value as PMenuItem)
declare sub Clear
declare function IndexOf(value as PMenuItem) as integer
declare function Find(value as integer) as PMenuItem
declare operator cast as any ptr
declare constructor
declare destructor
OnActivate as TNotifyEvent
end type
type TMainMenu extends TMenu
private:
FParent as PControl
protected:
public:
declare sub ProcessMessages(byref message as TMessage) override
declare property Parent as PControl
declare property Parent(value as PControl)
declare operator cast as any ptr
declare constructor
declare destructor
end type
type TPopupMenu extends TMenu
private:
FWindow as hwnd
protected:
public:
declare property Window as hwnd
declare property Window(value as hwnd)
declare sub Popup(x as integer,y as integer)
declare operator cast as any ptr
declare constructor
declare destructor
OnPopup as TNotifyEvent
OnDropDown as TNotifyEvent
end type
/' Global '/
sub AllocateCommand(value as PMenuItem)
static as integer uniqueId
if value then
if(value->Command <= 0) then
value->Command = uniqueId + 1
uniqueId = value->Command
end if
end if
end sub
sub TraverseItems(Item as TMenuItem)
dim as menuiteminfo mii
mii.cbsize = sizeof(mii)
mii.fMask = MIIM_TYPE
for i as integer = 0 to Item.Count-1
GetMenuItemInfo(Item.Handle,Item.Item(i)->MenuIndex,true,@mii)
mii.fType = iif((mii.fType and MFT_SEPARATOR),MFT_SEPARATOR,MFT_OWNERDRAW)
SetMenuItemInfo(Item.Handle,Item.Item(i)->MenuIndex,true,@mii)
TraverseItems(*Item.Item(i))
next i
end sub
/' TMenuItem '/
sub TMenuItem.SetInfo(byref value as MENUITEMINFO)
if FCaption = "" then
FCaption = chr(0)
end if
value.cbSize = sizeof(value)
value.fMask = iif(Handle,MIIM_SUBMENU,MIIM_ID) or MIIM_TYPE or MIIM_DATA or MIIM_STATE
value.hSubMenu = Handle
value.fType = iif(FCaption = "-",MFT_SEPARATOR,MFT_STRING)
value.fState = iif(FEnabled,MFS_ENABLED,MFS_DISABLED) or iif(FChecked,MFS_CHECKED,MFS_UNCHECKED)
value.wID = iif(Handle,-1,Command)
value.dwItemData = cast(dword,cast(any ptr,@this))
value.dwTypeData = strptr(FCaption)
value.cch = len(FCaption)
end sub
property TMenuItem.MenuIndex as integer
return FMenuIndex
end property
property TMenuItem.MenuIndex(value as integer)
FMenuIndex = value
end property
property TMenuItem.ImageIndex as integer
return FImageIndex
end property
property TMenuItem.ImageIndex(value as integer)
FImageIndex = value
end property
property TMenuItem.Command as integer
return FCommand
end property
property TMenuItem.Command(value as integer)
FCommand = value
end property
property TMenuItem.Handle as HMENU
return FHandle
end property
property TMenuItem.Handle(value as HMENU)
FHandle = value
end property
property TMenuItem.Owner as PObject
return FOwner
end property
property TMenuItem.Owner(value as PObject)
FOwner = value
end property
property TMenuItem.Menu as HMENU
return FMenu
end property
property TMenuItem.Menu(value as HMENU)
FMenu = value
end property
property TMenuItem.Parent as PMenuItem
return FParent
end property
property TMenuItem.Parent(value as PMenuItem)
dim as PMenuItem SaveParent = FParent
FParent = value
if SaveParent then SaveParent->Remove(this)
if FParent then FParent->Add(this)
end property
property TMenuItem.Caption as string
return FCaption
end property
property TMenuItem.Caption(value as string)
FCaption = value
if Parent then
SetMenuItemInfo(Parent->Handle,MenuIndex,true,@FInfo)
else
SetMenuItemInfo(Menu,MenuIndex,true,@FInfo)
end if
end property
property TMenuItem.Checked as integer
return FChecked
end property
property TMenuItem.Checked(value as integer)
dim as integer FCheck(-1 to 1) =>{MF_CHECKED,MF_UNCHECKED,MF_CHECKED}
FChecked = value
if Parent then
if Handle then
CheckMenuItem(Parent->Handle,cint(Handle),MF_POPUP or FCheck(FChecked))
else
CheckMenuItem(Parent->Handle,MenuIndex,MF_BYPOSITION or FCheck(FChecked))
end if
end if
end property
property TMenuItem.RadioItem as integer
Return FRadioItem
end property
property TMenuItem.RadioItem(value as integer)
FRadioItem = value
dim as integer First,Last
if Parent then
First = Parent->Item(0)->MenuIndex
Last = Parent->Item(Parent->Count-1)->MenuIndex
CheckMenuRadioItem(Parent->Handle,First,Last,MenuIndex,MF_BYPOSITION)
end if
end property
property TMenuItem.Enabled as integer
return FEnabled
end property
property TMenuItem.Enabled(value as integer)
dim as integer FEnable(-1 to 1) => {MF_ENABLED,MF_DISABLED or MF_GRAYED,MF_ENABLED}
FEnabled = value
if Parent then
EnableMenuItem(Parent->Handle,MenuIndex,mf_byposition or FEnable(FEnabled))
else
EnableMenuItem(Menu,MenuIndex,mf_byposition or FEnable(FEnabled))
end if
end property
property TMenuItem.Visible as integer
return FVisible
end property
property TMenuItem.Visible(value as integer)
FVisible = value
if FVisible = false then
if Parent then
RemoveMenu(Parent->Handle,MenuIndex,MF_BYPOSITION)
else
RemoveMenu(Menu,MenuIndex,MF_BYPOSITION)
end if
else
if FCaption = "" then
FCaption = chr(0)
end if
FInfo.cbSize = sizeof(FInfo)
FInfo.fMask = iif(Handle,MIIM_SUBMENU,MIIM_ID) or MIIM_TYPE or MIIM_DATA or MIIM_STATE
FInfo.hSubMenu = Handle
FInfo.fType = iif(FCaption = "-",MFT_SEPARATOR,MFT_STRING)
FInfo.fState = iif(FEnabled,MFS_ENABLED,MFS_DISABLED) or iif(FChecked,MFS_CHECKED,MFS_UNCHECKED)
FInfo.wID = iif(Handle,-1,Command)
FInfo.dwItemData = cast(dword,cast(any ptr,@this))
FInfo.dwTypeData = strptr(FCaption)
FInfo.cch = len(FCaption)
if Parent then
InsertMenuItem(Parent->Handle,MenuIndex,true,@FInfo)
else
InsertMenuItem(Menu,MenuIndex,true,@FInfo)
end if
end if
end property
property TMenuItem.Count as integer
return FCount
end property
property TMenuItem.Count(value as integer)
end property
property TMenuItem.Item(index as integer) as PMenuItem
if (index > -1) and (index <FCount) then
return FItems[index]
end if
return NULL
end property
property TMenuItem.Item(index as integer,value as PMenuItem)
end property
sub TMenuItem.Click
if onClick then onClick(this)
end sub
sub TMenuItem.Add(value as PMenuItem)
if IndexOf(value) = -1 then
FCount += 1
FItems = reallocate(FItems,sizeof(PMenuItem)*FCount)
FItems[FCount-1] = value
value->Parent = @this
value->MenuIndex = FCount -1
value->Owner = Owner
value->Menu = Menu
AllocateCommand(value)
if FCount > 0 then
if Handle = 0 then
Handle = CreatePopupMenu
dim as menuinfo mif
mif.cbSize = sizeof(mif)
mif.dwmenudata = cast(dword,cast(any ptr,@this))
mif.fMask = MIM_MENUDATA
.SetMenuInfo(Handle,@mif)
SetInfo(FInfo)
if Parent then
SetMenuItemInfo(Parent->Handle,MenuIndex,True,@FInfo)
end if
end if
end if
value->SetInfo(FInfo)
InsertMenuItem(Handle,FCount-1,true,@FInfo)
end if
end sub
sub TMenuItem.Insert(Index as Integer,value as PMenuItem)
if IndexOf(value) = -1 then
if (Index>-1) and (Index<FCount) then
FCount += 1
FItems = reallocate(FItems,sizeof(PMenuItem)*FCount)
for i as integer = Index+1 to FCount-1
FItems[i] = FItems[i-1]
next i
FItems[Index] = value
FItems[Index]->MenuIndex = Index
FItems[Index]->Parent = @this
FItems[Index]->Owner = Owner
FItems[Index]->Menu = Menu
AllocateCommand(value)
if FCount > 0 then
if Handle = 0 then
Handle = CreatePopupMenu
dim as menuinfo mif
mif.cbSize = sizeof(mif)
mif.dwmenudata = cast(dword,cast(any ptr,@this))
mif.fMask = MIM_MENUDATA
.SetMenuInfo(Handle,@mif)
SetInfo(FInfo)
if Parent then
SetMenuItemInfo(Parent->Handle,MenuIndex,true,@FInfo)
end if
end if
end if
value->SetInfo(FInfo)
InsertMenuItem(Handle,Index,true,@FInfo)
for i as integer = 0 to FCount-1
FItems[i]->MenuIndex = i
next i
end if
end if
end sub
sub TMenuItem.Remove(value as PMenuItem)
dim as integer Index,i
dim as PMenuItem FItem
Index = IndexOf(value)
if Index <> -1 then
for i = Index+1 to FCount-1
FItem = FItems[i]
FItems[i-1] = FItem
next i
FCount -= 1
FItems = reallocate(FItems,FCount*sizeof(PMenuItem))
for i as integer = 0 to FCount-1
FItems[i]->MenuIndex = i
next i
end if
end sub
sub TMenuItem.Clear
for i as integer = Count-1 to 0 step -1
FItems[i] = NULL
next i
FItems = callocate(0)
FCount = 0
end sub
function TMenuItem.IndexOf(value as PMenuItem) as integer
dim as Integer i
for i = 0 to FCount -1
if FItems[i] = value then return i
next i
return -1
end function
function TMenuItem.Find(value as integer) as PMenuItem
dim as PMenuItem FItem
for i as integer = 0 to FCount -1
if Item(i)->Command = value then return Item(i)
FItem = Item(i)->Find(value)
if FItem then if FItem->Command = value then return FItem
next i
return NULL
end function
operator TMenuItem.cast as any ptr
return @this
end operator
constructor TMenuItem
FVisible = 1
FEnabled = 1
FChecked = 0
FImageIndex = -1
end constructor
destructor TMenuItem
if FParent then
FParent->Remove(@this)
end if
if FItems then
delete [] FItems
FItems = callocate(0)
end if
if FHandle then
DestroyMenu(FHandle)
FHandle = 0
end if
end destructor
/' TMenu '/
property TMenu.Handle as HMENU
return FHandle
end property
property TMenu.Handle(value as HMENU)
FHandle = value
end property
property TMenu.ParentWindow as hwnd
return FParentWindow
end property
property TMenu.ParentWindow(value as hwnd)
dim as HWND SaveHandle = FParentWindow
FParentWindow = value
if value <> SaveHandle then
SetClassLong(SaveHandle,gcl_menuname,0)
SetMenu(SaveHandle,0)
end if
if FHandle then
SetMenu(ParentWindow,Handle)
DrawMenuBar(FParentWindow)
end if
end property
property TMenu.Style as integer
return FStyle
end property
property TMenu.Style(value as integer)
FStyle = value
if Handle then
if value then
for i as integer = 0 to FCount-1
TraverseItems(*Item(i))
next i
/'else
for i as integer = 0 to FCount-1
TraverseItems(*Item(i))
next i '/
end if
if IsWindow(FParentWindow) then
SetMenu(FParentWindow,Handle)
DrawMenuBar(FParentWindow)
end if
end if
end property
property TMenu.Color as integer
if handle then
dim as menuinfo mif
mif.cbSize = sizeof(mif)
mif.fMask = MIM_BACKGROUND
if GetMenuInfo(Handle,@mif) then
dim as LOGBRUSH lb
GetObject(mif.hbrBack,sizeof(lb),@lb)
FColor = lb.lbColor
return FColor
end if
end if
return FColor
end property
property TMenu.Color(value as integer)
FColor = value
if Handle then
dim as menuinfo mif
mif.cbSize = sizeof(mif)
GetMenuInfo(Handle,@mif)
if mif.hbrBack then
DeleteObject(mif.hbrBack)
end if
mif.hbrBack = CreateSolidBrush(FColor)
mif.fMask = MIM_BACKGROUND or iif(FIncSubItems,MIM_APPLYTOSUBMENUS,0)
SetMenuInfo(Handle,@mif)
if FParentWindow then
DrawMenuBar(FParentWindow)
RedrawWindow(FParentWindow,0,0,rdw_invalidate or rdw_erase)
UpdateWindow(FParentWindow)
end if
end if
end property
property TMenu.ColorizeEntire as integer
return FIncSubitems
end property
property TMenu.ColorizeEntire(value as integer)
FIncSubitems = value
Color = FColor
end property
property TMenu.Count as integer
return FCount
end property
property TMenu.Count(value as integer)
end property
property TMenu.Item(index as integer) as TMenuItem ptr
if (index>-1) and (index<FCount) then
return FItems[Index]
end if
return NULL
end property
property TMenu.Item(index as integer,value as TMenuItem ptr)
if (index > -1) and (index < FCount) then
FItems[Index] = value
end if
end property
sub TMenu.Add(value as PMenuItem)
dim as MenuItemInfo FInfo
if IndexOf(value) = -1 then
FCount +=1
FItems = reallocate(FItems,sizeof(PMenuItem)*FCount)
FItems[FCount-1] = value
value->Handle = iif(value->Handle,value->Handle,CreatePopupMenu)
value->Parent = NULL
value->MenuIndex = FCount -1
value->Menu = Handle
value->Owner = this
value->SetInfo(FInfo)
InsertMenuItem(Handle,-1,true,@FInfo)
for i as integer = 0 to value->Count-1
value->item(i)->Owner = value->Owner
value->item(i)->Menu = Handle
next i
if IsWindow(FParentWindow) then DrawMenuBar(FParentWindow)
end if
end sub
sub TMenu.Insert(Index as integer,value as PMenuItem)
dim as MenuItemInfo FInfo
if IndexOf(value) = -1 then
if (Index>-1) and (Index<FCount) then
FCount +=1
FItems = reallocate(FItems,sizeof(PMenuItem)*FCount)
for i as integer = Index +1 to FCount-1
FItems[i] = FItems[i-1]
next i
FItems[Index] = value
value->MenuIndex = Index
value->Parent = NULL
value->Handle = iif(value->Handle,value->Handle,CreatePopupMenu)
value->Menu = Handle
value->Owner = this
value->SetInfo(FInfo)
InsertMenuItem(Handle,Index,true,@FInfo)
for i as integer = 0 to FCount-1
FItems[i]->MenuIndex = i
next i
for i as integer = 0 to value->Count-1
value->item(i)->Owner = value->Owner
value->item(i)->Menu = Handle
next i
if IsWindow(FParentWindow) then DrawMenuBar(FParentWindow)
end if
end if
end sub
sub TMenu.Remove(value as PMenuItem)
dim as integer Index,i
dim as PMenuItem FItem
Index = IndexOf(value)
if Index <> -1 then
for i = Index+1 to FCount-1
FItem = FItems[i]
FItems[i-1] = FItem
next i
FCount -= 1
FItems = reallocate(FItems,FCount*sizeof(PMenuItem))
for i as integer = 0 to FCount-1
FItems[i]->MenuIndex = i
next i
if IsWindow(FParentWindow) then DrawMenuBar(FParentWindow)
end if
end sub
function TMenu.IndexOf(value as PMenuItem) as integer
for i as integer = 0 to FCount-1
if FItems[i] = value then return i
next i
return -1
end function
function TMenu.Find(value as integer) as TMenuItem ptr
dim as TMenuItem ptr FItem
for i as integer = 0 to FCount-1
if Item(i)->Command = value then return Item(i)
FItem = Item(i)->Find(value)
if FItem then if FItem->Command = value then return FItem
next i
return NULL
end function
sub TMenu.Clear
if FItems then
delete [] FItems
FItems = callocate(0)
end if
end sub
sub TMenu.ProcessMessages(byref message as TMessage)
Print "menu msg = ",message.msg
end sub
operator TMenu.cast as any ptr
return @this
end operator
constructor TMenu
end constructor
destructor TMenu
Clear
if FInfo.hbrBack then DeleteObject(FInfo.hbrBack)
if FHandle then
DestroyMenu(FHandle)
FHandle = 0
end if
end destructor
/' TMainMenu '/
property TMainMenu.Parent as PControl
return FParent
end property
property TMainMenu.Parent(value as PControl)
FParent = value
if value then
FParentWindow = value->Handle
if not IsMenu(FHandle) then
FHandle = CreateMenu
end if
if IsWindow(FParentWindow) then
SetMenu(FParentWindow,FHandle)
DrawMenuBar(FParentWindow)
end if
end if
end property
sub TMainMenu.ProcessMessages(byref message as TMessage)
Print "**menu msg = ",message.msg,loword(message.wparam)
dim as PMenuItem I = Find(loword(message.wparam))
if I then I->Click
end sub
operator TMainMenu.cast as any ptr
return @this
end operator
constructor TMainMenu
FHandle = CreateMenu :print "MENU CREATED HANDLE = ",FHandle
FIncSubItems = 1
FColor = GetSysColor(color_menu)
FInfo.cbSize = sizeof(FInfo)
if FInfo.hbrBack then DeleteObject(FInfo.hbrBack)
FInfo.hbrBack = CreateSolidBrush(FColor)
FInfo.dwmenudata = cast(dword,cast(any ptr,@this))
FInfo.fMask = MIM_BACKGROUND or iif(FIncSubItems,MIM_APPLYTOSUBMENUS,0) or mim_menudata
SetMenuInfo(FHandle,@FInfo)
end constructor
destructor TMainMenu
end destructor
/' TPopupMenu '/
property TPopupMenu.Window as hwnd
return FWindow
end property
property TPopupMenu.Window(value as hwnd)
FWindow = value
end property
sub TPopupMenu.Popup(x as integer,y as integer)
if FWindow then
TrackPopupMenuEx(FHandle,0,x,y,FWindow,0)
end if
end sub
operator TPopupMenu.cast as any ptr
return @this
end operator
constructor TPopupMenu
FHandle = CreatePopupMenu
FInfo.cbsize = sizeof(FInfo)
FInfo.fmask = MIM_MENUDATA
FInfo.dwmenudata = cast(dword,cast(any ptr,@this))
SetMenuInfo(Handle,@FInfo)
end constructor
destructor TPopupMenu
end destructor
Re: Creating a control's container
at last...
Graphics.bi
test with .90.1 on Windows7..'sbarci' edition. Enjoy!!!! or not.
Graphics.bi
Code: Select all
/' Graphics '/
#include once "Common.bi"
enum TBrushStyle
bsSolid = BS_SOLID
bsClear = BS_NULL
bsHatch = BS_HATCHED
bsPattern = BS_PATTERN
end enum
enum THatchStyle
hsHorizontal = HS_HORIZONTAL
hsVertical = HS_VERTICAL
hsFDiagonal = HS_FDIAGONAL
hsDiagonal = HS_BDIAGONAL
hsCross = HS_CROSS
hsDiagCross = HS_DIAGCROSS
end enum
enum TPenStyle
psSolid = PS_SOLID
psDot = PS_DOT
psDash = PS_DASH
psDashDot = PS_DASHDOT
psDashDotDot = PS_DASHDOTDOT
psInsideFrame = PS_INSIDEFRAME
end enum
enum TPenMode
pmBlack = R2_BLACK
pmCopyPen = R2_COPYPEN
pmMaskNotPen = R2_MASKNOTPEN
pmMaskPen = R2_MASKPEN
pmMaskPenNot = R2_MASKPENNOT
pmMergeNotPen = R2_MERGENOTPEN
pmMergePen = R2_MERGEPEN
pmMergePenNot = R2_MERGEPENNOT
pmNop = R2_NOP
pmNot = R2_NOT
pmNotCopyPen = R2_NOTCOPYPEN
pmNotMaskPen = R2_NOTMASKPEN
pmNotMergePen = R2_NOTMERGEPEN
pmNotXorPen = R2_NOTXORPEN
pmWhite = R2_WHITE
pmXorPen = R2_XORPEN
end enum
enum TDrawingStyle
dsFocus = ILD_FOCUS
dsNormal = ILD_NORMAL
dsSelected = ILD_SELECTED
dsTransparent = ILD_TRANSPARENT
dsBlend = ILD_BLEND
dsBlend25 = ILD_BLEND25
dsBlend50 = ILD_BLEND50
end enum
enum TImageType
itImage = 0
itMask = ILD_MASK
end enum
#ifdef PBITMAP
#undef PBITMAP
#endif
type PPen as TPen ptr
type PBrush as TBrudh ptr
type PIcon as TIcon ptr
type PCursor as TCursor ptr
type PFont as TFont ptr
type PCanvas as TCanvas ptr
type PBitmap as TBitmap ptr
type PGraphic as TGraphic ptr
type TPen extends TObject
private:
FLogPen as LOGPEN
FMode as integer = pmCopyPen
FSize as integer
FStyle as integer
FColor as integer
FHandle as HPEN
protected:
declare sub CreateHandle
declare sub DestroyHandle
public:
declare property Handle as HPEN
declare property Handle(value as HPEN)
declare property Mode as integer
declare property Mode(value as integer)
declare property Style as integer
declare property Style(value as integer)
declare property Size as integer
declare property Size(value as integer)
declare property Color as integer
declare property Color(value as integer)
declare operator let(ByRef Pen as TPen)
declare operator let(hPen as HPEN)
declare operator cast as any ptr
declare constructor
declare destructor
end type
type TBrush extends TObject
private:
FLogBrush as LOGBRUSH
FHatch as integer
FStyle as integer
FColor as integer
FHandle as HBRUSH
protected:
declare sub CreateHandle
declare sub DestroyHandle
public:
declare property Handle as HBRUSH
declare property Handle(value as HBRUSH)
declare property Style as integer
declare property Style(value as integer)
declare property Hatch as integer
declare property Hatch(value as integer)
declare property Color as integer
declare property Color(value as integer)
declare operator let(ByRef Brush as TBrush)
declare operator let(hBrush as HBRUSH)
declare operator cast as any ptr
declare constructor
declare destructor
end type
type TIcon extends TObject
private:
FInfo as ICONINFO
FWidth as integer
FHeight as integer
FHandle as HICON
protected:
FGraphic as PGraphic
declare sub GetInfo
declare virtual sub CreateHandle
declare virtual sub DestroyHandle
public:
declare property Width as integer
declare property Width(value as integer)
declare property Height as integer
declare property Height(value as integer)
declare sub LoadFromFile(File as string)
declare sub SaveToFile(File as string)
declare sub LoadFromResourceName(ResName as string,hInstance as HMODULE = GetModuleHandle(0))
declare sub LoadFromResourceID(ResID as integer,hInstance as HMODULE = GetModuleHandle(0))
declare operator cast as any ptr
declare operator let(value as string)
declare operator let(value as HICON)
declare operator let(ByRef value as TIcon)
declare constructor
declare destructor
Changed as sub(ByRef as TIcon)
end type
type TCursor extends TIcon
private:
FHotSpotX as integer
FHotSpotY as integer
FHandle as HCURSOR
protected:
declare sub CreateHandle
declare sub DestroyHandle
public:
declare property HotSpotX as integer
declare property HotSpotX(value as integer)
declare property HotSpotY as integer
declare property HotSpotY(value as integer)
declare sub LoadFromFile(File as string)
declare sub SaveToFile(File as string)
declare sub LoadFromResourceName(ResName as string,hInstance as HMODULE = GetModuleHandle(0))
declare sub LoadFromResourceID(ResID as integer,hInstance as HMODULE = GetModuleHandle(0))
declare operator cast as any ptr
declare operator let(value as string)
declare operator let(value as HCURSOR)
declare operator let(ByRef value as TCursor)
declare constructor
declare destructor
Changed as sub(ByRef as TCursor)
end type
type TFont extends TObject
private:
FLogFont as LOGFONT
FColor as integer
FSize as integer
FName as string
FCharset as integer
FBold as integer
FItalic as integer
FStrikeout as integer
FUnderline as integer
FWindow as HWND
FHandle as HFONT
protected:
declare sub CreateHandle
declare sub DestroyHandle
public:
declare sub Update
declare property Parent as hwnd
declare property Parent(value as hwnd)
declare property Color as integer
declare property Color(value as integer)
declare property Bold as integer
declare property Bold(value as integer)
declare property Italic as integer
declare property Italic(value as integer)
declare property Underline as integer
declare property Underline(value as integer)
declare property Strikeout as integer
declare property Strikeout(value as integer)
declare property Charset as integer
declare property Charset(value as integer)
declare property Size as integer
declare property Size(value as integer)
declare property Name as string
declare property Name(value as string)
declare operator cast as any ptr
declare operator cast as string
declare operator let(value as HFONT)
declare operator let(ByRef value as TFont)
declare constructor
declare destructor
Changed as sub(ByRef as TFont)
end type
type TBitmap extends TObject
private:
FInfo as BITMAP
FPixelFormat as integer
FWidth as integer
FHeight as integer
FTransparent as integer
FTransparentColor as integer
FHandle as HBITMAP
FDevice as HDC
FGraphic as PGraphic
protected:
declare sub GetInfo
declare sub CreateHandle
declare sub DestroyHandle
public:
Font as TFont
Pen as TPen
Brush as TBrush
CopyMode as integer
Graphic as any ptr
declare property Device as HDC
declare property Device(value as HDC)
declare property Handle as HBITMAP
declare property Handle(value as HBITMAP)
declare property PixelFormat as integer
declare property PixelFormat(value as integer)
declare property Transparency as integer
declare property Transparency(value as integer)
declare property TransparentColor as integer
declare property TransparentColor(value as integer)
declare property Width as integer
declare property Width(value as integer)
declare property Height as integer
declare property Height(value as integer)
declare sub StretchDrawTransparent(Dc as HDC,x as integer,y as integer,cx as integer,cy as integer,Clr as integer = &HFFFFFF)
declare sub DrawTransparent(Dc as HDC,x as integer,y as integer,Clr as integer = &HFFFFFF)
declare sub StretchDraw(Dc as HDC,x as integer,y as integer,cx as integer,cy as integer)
declare sub Draw(Dc as HDC,x as integer,y as integer)
declare sub Copy(x as integer,y as integer,Source as TBitmap)
declare sub CopyRect(R as Rect,Source as TBitmap)
declare sub LoadFromFile(File as string)
declare sub SaveToFile(File as string)
declare sub LoadFromResourceName(ResName as string,hInstance as HMODULE = GetModuleHandle(0))
declare sub LoadFromResourceID(ResID as integer,hInstance as HMODULE = GetModuleHandle(0))
declare operator cast as any ptr
declare operator cast as string
declare operator let(value as string)
declare operator let(value as HBITMAP)
declare operator let(ByRef value as TBitmap)
declare constructor
declare destructor
Changed as sub(ByRef as TBitmap)
end type
type TCanvas extends TObject
private:
FDc as HDC
FFont as HFONT
FBrush as HBRUSH
FPen as HPEN
protected:
FColor as integer
declare sub LockCanvas
declare sub CreateHandle
declare sub DestroyHandle
public:
Control as PControl 'any ptr
Pen as TPen
Brush as TBrush
Font as TFont
declare property Handle as HDC
declare property Handle(value as HDC)
declare sub UnlockCanvas
declare sub MoveTo(x as integer,y as integer)
declare sub LineTo(x as integer,y as integer)
declare sub Line(x as integer,y as integer,x1 as integer,y1 as integer)
declare sub Rectangle(x as integer,y as integer,x1 as integer,y1 as integer)
declare sub Rectangle(R as Rect)
declare sub RoundRect(x as integer,y as integer,x1 as integer,y1 as integer,cx as integer,cy as integer)
declare sub RoundRect(R as Rect,cx as integer,cy as integer)
declare sub Ellipse(x as integer,y as integer,x1 as integer,y1 as integer)
declare sub Ellipse(R as Rect)
declare sub Polygon(Points as Point ptr,Count as integer)
declare sub Pie(x as integer,y as integer,x1 as integer,y1 as integer,nXRadial1 as integer,nYRadial1 as integer,nXRadial2 as integer,nYRadial2 as integer)
declare sub Arc(x as integer,y as integer,x1 as integer,y1 as integer,xStart as integer, yStart as integer,xEnd as integer,yEnd as integer)
declare sub ArcTo(x as integer,y as integer,x1 as integer,y1 as integer,nXRadial1 as integer,nYRadial1 as integer,nXRadial2 as integer,nYRadial2 as integer)
declare sub AngleArc(x as integer,y as integer,Radius as integer,StartAngle as single,SweepAngle as single)
declare sub Chord(x as integer,y as integer,x1 as integer,y1 as integer,nXRadial1 as integer,nYRadial1 as integer,nXRadial2 as integer,nYRadial2 as integer)
declare sub Polyline(Points as Point ptr,Count as integer)
declare sub PolylineTo(Points as Point ptr,Count as integer)
declare sub PolyBeizer(Points as Point ptr,Count as integer)
declare sub PolyBeizerTo(Points as Point ptr,Count as integer)
declare sub SetPixel(x as integer,y as integer,PixelColor as integer)
declare function GetPixel(x as integer,y as integer) as integer
declare sub TextOut(x as integer,y as integer,Text as string,BackClr as integer=-1)
declare sub TextRect(R as Rect,Text as string,Flags as integer=0)
declare sub DrawFocusRect(R as Rect)
declare sub Draw(x as integer,y as integer,ByRef Bitmap as TBitmap)
declare sub DrawTransparent(x as integer,y as integer,ByRef Bitmap as TBitmap)
declare sub StretchDraw(x as integer,y as integer,cx as integer,cy as integer,ByRef Bitmap as TBitmap)
declare sub StretchDrawTransparent(x as integer,y as integer,cx as integer,cy as integer,ByRef Bitmap as TBitmap)
declare sub FillRect(R as Rect)
declare function TextHeight(Text as string) as integer
declare function TextWidth(Text as string) as integer
declare operator let(value as HDC)
declare operator let(ByRef value as TCanvas)
declare operator cast as any ptr
declare constructor
declare destructor
end type
type TImageList extends TObject
private:
FWindow as HWND
FWidth as integer
FHeight as integer
FBKColor as integer
FCount as integer
protected:
FHandle as HIMAGELIST
declare sub CreateHandle
declare sub DestroyHandle
declare sub NotifyControl
public:
AllocBy as integer
ImageType as TImagetype
DrawingStyle as TDrawingStyle
declare property WindowHandle as HWND
declare property WindowHandle(value as HWND)
declare property Width as integer
declare property Width(value as integer)
declare property Height as integer
declare property Height(value as integer)
declare property BkColor as integer
declare property BkColor(value as integer)
declare property Count as integer
declare sub AddIcon(ByRef Icon as TIcon)
declare sub AddBitmap(ByRef Bitmap as TBitmap,ByRef Mask as TBitmap)
declare sub AddCursor(Cursor as TCursor)
declare sub AddMasked(ByRef Bitmap as TBitmap,MaskColor as integer)
declare function GetBitmap(Index as integer) as TBitmap
declare function GetMask(Index as integer) as TBitmap
declare function GetIcon(Index as integer) as TIcon
declare function GetCursor(Index as integer) as TCursor
declare sub Remove(Index as integer)
declare sub DrawEx(Index as integer,DestDC as HDC,X as integer,Y as integer,iWidth as integer,iHeight as integer,FG as integer,BK as integer)
declare sub Draw(Index as integer,DestDC as HDC,X as integer,Y as integer)
declare sub CopyList(ByRef value as TImageList)
declare sub Clear
declare operator let(ByRef value as TImageList)
declare operator let(value as HIMAGELIST)
declare operator cast as any ptr
declare constructor
declare destructor
OnChange as sub(ByRef as TImageList)
end type
type TGraphic extends TObject
private:
FGraphExt as zstring ptr ptr '= {"Icon","Cursor","Bitmap"}
protected:
FPalette as PALETTEENTRY
declare sub RegisterGraphExtension(value as string)
public:
Bitmap as TBitmap
Icon as TIcon
Cursor as TCursor
declare property GraphExtension(index as integer) as string
declare property GraphExtension(index as integer,value as string)
declare operator cast as any ptr
declare operator cast as TBitmap
declare operator cast as TIcon
declare operator cast as TCursor
declare operator let(ByRef value as TGraphic)
declare operator let(ByRef value as TBitmap)
declare operator let(ByRef value as TIcon)
declare operator let(ByRef value as TCursor)
declare constructor
declare destructor
Changed as sub(ByRef as TGraphic)
end type
/' TPen '/
sub TPen.CreateHandle
end sub
sub TPen.DestroyHandle
end sub
property TPen.Handle as HPEN
return FHandle
end property
property TPen.Handle(value as HPEN)
end property
property TPen.Mode as integer
return FMode
end property
property TPen.Mode(value as integer)
end property
property TPen.Style as integer
return FStyle
end property
property TPen.Style(value as integer)
end property
property TPen.Size as integer
end property
property TPen.Size(value as integer)
end property
property TPen.Color as integer
end property
property TPen.Color(value as integer)
end property
operator TPen.let(ByRef Pen as TPen)
end operator
operator TPen.let(hPen as HPEN)
end operator
operator TPen.cast as any ptr
end operator
constructor TPen
end constructor
destructor TPen
end destructor
/' TBrush '/
sub TBrush.CreateHandle
DestroyHandle
FHandle = CreateBrushIndirect(@FLogBrush)
end sub
sub TBrush.DestroyHandle
if FHandle then DeleteObject(FHandle)
end sub
property TBrush.Handle as HBRUSH
return FHandle
end property
property TBrush.Handle(value as HBRUSH)
FHandle = value
if GetObject(FHandle,sizeof(FLogBrush),@FLogBrush) then
CreateHandle
end if
end property
property TBrush.Style as integer
if GetObject(FHandle,sizeof(FLogBrush),@FLogBrush) then
FStyle = FLogBrush.lbStyle
end if
return FStyle
end property
property TBrush.Style(value as integer)
FStyle = value
if GetObject(FHandle,sizeof(FLogBrush),@FLogBrush) then
FLogBrush.lbStyle = FStyle
end if
CreateHandle
end property
property TBrush.Hatch as integer
if GetObject(FHandle,sizeof(FLogBrush),@FLogBrush) then
FHatch = FLogBrush.lbHatch
end if
return FHatch
end property
property TBrush.Hatch(value as integer)
FHatch = value
if GetObject(FHandle,sizeof(FLogBrush),@FLogBrush) then
FLogBrush.lbHatch = FHatch
end if
CreateHandle
end property
property TBrush.Color as integer
if GetObject(FHandle,sizeof(FLogBrush),@FLogBrush) then
FColor = FLogBrush.lbColor
end if
return FColor
end property
property TBrush.Color(value as integer)
FColor = value
if GetObject(FHandle,sizeof(FLogBrush),@FLogBrush) then
FLogBrush.lbColor = FColor
end if
CreateHandle
end property
operator TBrush.let(ByRef Brush as TBrush)
if GetObject(Brush.FHandle,sizeof(FLogBrush),@FLogBrush) then
CreateHandle
end if
end operator
operator TBrush.let(hBrush as HBRUSH)
if GetObject(hBrush,sizeof(FLogBrush),@FLogBrush) then
CreateHandle
end if
end operator
operator TBrush.cast as any ptr
return @this
end operator
constructor TBrush
FLogBrush.lbColor = GetSysColor(COLOR_WINDOW)
FLogBrush.lbStyle = bsSolid
CreateHandle
end constructor
destructor TBrush
DestroyHandle
end destructor
/' TIcon '/
sub TIcon.GetInfo
end sub
sub TIcon.CreateHandle
end sub
sub TIcon.DestroyHandle
end sub
property TIcon.Width as integer
end property
property TIcon.Width(value as integer)
end property
property TIcon.Height as integer
end property
property TIcon.Height(value as integer)
end property
sub TIcon.LoadFromFile(File as string)
end sub
sub TIcon.SaveToFile(File as string)
end sub
sub TIcon.LoadFromResourceName(ResName as string,hInstance as HMODULE = GetModuleHandle(0))
end sub
sub TIcon.LoadFromResourceID(ResID as integer,hInstance as HMODULE = GetModuleHandle(0))
end sub
operator TIcon.cast as any ptr
end operator
operator TIcon.let(value as string)
end operator
operator TIcon.let(value as HICON)
end operator
operator TIcon.let(ByRef value as TIcon)
end operator
constructor TIcon
end constructor
destructor TIcon
end destructor
/' TCursor '/
sub TCursor.CreateHandle
end sub
sub TCursor.DestroyHandle
end sub
property TCursor.HotSpotX as integer
end property
property TCursor.HotSpotX(value as integer)
end property
property TCursor.HotSpotY as integer
end property
property TCursor.HotSpotY(value as integer)
end property
sub TCursor.LoadFromFile(File as string)
end sub
sub TCursor.SaveToFile(File as string)
end sub
sub TCursor.LoadFromResourceName(ResName as string,hInstance as HMODULE = GetModuleHandle(0))
end sub
sub TCursor.LoadFromResourceID(ResID as integer,hInstance as HMODULE = GetModuleHandle(0))
end sub
operator TCursor.cast as any ptr
end operator
operator TCursor.let(value as string)
end operator
operator TCursor.let(value as HCURSOR)
end operator
operator TCursor.let(ByRef value as TCursor)
end operator
constructor TCursor
end constructor
destructor TCursor
end destructor
/' TFont '/
sub TFont.CreateHandle
end sub
sub TFont.DestroyHandle
end sub
sub TFont.Update
end sub
property TFont.Parent as hwnd
end property
property TFont.Parent(value as hwnd)
end property
property TFont.Color as integer
end property
property TFont.Color(value as integer)
end property
property TFont.Bold as integer
end property
property TFont.Bold(value as integer)
end property
property TFont.Italic as integer
end property
property TFont.Italic(value as integer)
end property
property TFont.Underline as integer
end property
property TFont.Underline(value as integer)
end property
property TFont.Strikeout as integer
end property
property TFont.Strikeout(value as integer)
end property
property TFont.Charset as integer
end property
property TFont.Charset(value as integer)
end property
property TFont.Size as integer
end property
property TFont.Size(value as integer)
end property
property TFont.Name as string
end property
property TFont.Name(value as string)
end property
operator TFont.cast as any ptr
end operator
operator TFont.cast as string
end operator
operator TFont.let(value as HFONT)
end operator
operator TFont.let(ByRef value as TFont)
end operator
constructor TFont
end constructor
destructor TFont
end destructor
/' TBitmap '/
sub TBitmap.GetInfo
end sub
sub TBitmap.CreateHandle
end sub
sub TBitmap.DestroyHandle
end sub
property TBitmap.Device as HDC
end property
property TBitmap.Device(value as HDC)
end property
property TBitmap.Handle as HBITMAP
end property
property TBitmap.Handle(value as HBITMAP)
end property
property TBitmap.PixelFormat as integer
end property
property TBitmap.PixelFormat(value as integer)
end property
property TBitmap.Transparency as integer
end property
property TBitmap.Transparency(value as integer)
end property
property TBitmap.TransparentColor as integer
end property
property TBitmap.TransparentColor(value as integer)
end property
property TBitmap.Width as integer
end property
property TBitmap.Width(value as integer)
end property
property TBitmap.Height as integer
end property
property TBitmap.Height(value as integer)
end property
sub TBitmap.StretchDrawTransparent(Dc as HDC,x as integer,y as integer,cx as integer,cy as integer,Clr as integer = &HFFFFFF)
end sub
sub TBitmap.DrawTransparent(Dc as HDC,x as integer,y as integer,Clr as integer = &HFFFFFF)
end sub
sub TBitmap.StretchDraw(Dc as HDC,x as integer,y as integer,cx as integer,cy as integer)
end sub
sub TBitmap.Draw(Dc as HDC,x as integer,y as integer)
end sub
sub TBitmap.Copy(x as integer,y as integer,Source as TBitmap)
end sub
sub TBitmap.CopyRect(R as Rect,Source as TBitmap)
end sub
sub TBitmap.LoadFromFile(File as string)
end sub
sub TBitmap.SaveToFile(File as string)
end sub
sub TBitmap.LoadFromResourceName(ResName as string,hInstance as HMODULE = GetModuleHandle(0))
end sub
sub TBitmap.LoadFromResourceID(ResID as integer,hInstance as HMODULE = GetModuleHandle(0))
end sub
operator TBitmap.cast as any ptr
end operator
operator TBitmap.cast as string
end operator
operator TBitmap.let(value as string)
end operator
operator TBitmap.let(value as HBITMAP)
end operator
operator TBitmap.let(ByRef value as TBitmap)
end operator
constructor TBitmap
end constructor
destructor TBitmap
end destructor
/' TCanvas '/
sub TCanvas.LockCanvas
end sub
sub TCanvas.CreateHandle
end sub
sub TCanvas.DestroyHandle
end sub
property TCanvas.Handle as HDC
end property
property TCanvas.Handle(value as HDC)
end property
sub TCanvas.UnlockCanvas
end sub
sub TCanvas.MoveTo(x as integer,y as integer)
end sub
sub TCanvas.LineTo(x as integer,y as integer)
end sub
sub TCanvas.Line(x as integer,y as integer,x1 as integer,y1 as integer)
end sub
sub TCanvas.Rectangle(x as integer,y as integer,x1 as integer,y1 as integer)
end sub
sub TCanvas.Rectangle(R as Rect)
end sub
sub TCanvas.RoundRect(x as integer,y as integer,x1 as integer,y1 as integer,cx as integer,cy as integer)
end sub
sub TCanvas.RoundRect(R as Rect,cx as integer,cy as integer)
end sub
sub TCanvas.Ellipse(x as integer,y as integer,x1 as integer,y1 as integer)
end sub
sub TCanvas.Ellipse(R as Rect)
end sub
sub TCanvas.Polygon(Points as Point ptr,Count as integer)
end sub
sub TCanvas.Pie(x as integer,y as integer,x1 as integer,y1 as integer,nXRadial1 as integer,nYRadial1 as integer,nXRadial2 as integer,nYRadial2 as integer)
end sub
sub TCanvas.Arc(x as integer,y as integer,x1 as integer,y1 as integer,xStart as integer, yStart as integer,xEnd as integer,yEnd as integer)
end sub
sub TCanvas.ArcTo(x as integer,y as integer,x1 as integer,y1 as integer,nXRadial1 as integer,nYRadial1 as integer,nXRadial2 as integer,nYRadial2 as integer)
end sub
sub TCanvas.AngleArc(x as integer,y as integer,Radius as integer,StartAngle as single,SweepAngle as single)
end sub
sub TCanvas.Chord(x as integer,y as integer,x1 as integer,y1 as integer,nXRadial1 as integer,nYRadial1 as integer,nXRadial2 as integer,nYRadial2 as integer)
end sub
sub TCanvas.Polyline(Points as Point ptr,Count as integer)
end sub
sub TCanvas.PolylineTo(Points as Point ptr,Count as integer)
end sub
sub TCanvas.PolyBeizer(Points as Point ptr,Count as integer)
end sub
sub TCanvas.PolyBeizerTo(Points as Point ptr,Count as integer)
end sub
sub TCanvas.SetPixel(x as integer,y as integer,PixelColor as integer)
end sub
function TCanvas.GetPixel(x as integer,y as integer) as integer
end function
sub TCanvas.TextOut(x as integer,y as integer,Text as string,BackClr as integer=-1)
end sub
sub TCanvas.TextRect(R as Rect,Text as string,Flags as integer=0)
end sub
sub TCanvas.DrawFocusRect(R as Rect)
end sub
sub TCanvas.Draw(x as integer,y as integer,ByRef Bitmap as TBitmap)
end sub
sub TCanvas.DrawTransparent(x as integer,y as integer,ByRef Bitmap as TBitmap)
end sub
sub TCanvas.StretchDraw(x as integer,y as integer,cx as integer,cy as integer,ByRef Bitmap as TBitmap)
end sub
sub TCanvas.StretchDrawTransparent(x as integer,y as integer,cx as integer,cy as integer,ByRef Bitmap as TBitmap)
end sub
sub TCanvas.FillRect(R as Rect)
end sub
function TCanvas.TextHeight(Text as string) as integer
end function
function TCanvas.TextWidth(Text as string) as integer
end function
operator TCanvas.let(value as HDC)
end operator
operator TCanvas.let(ByRef value as TCanvas)
end operator
operator TCanvas.cast as any ptr
end operator
constructor TCanvas
end constructor
destructor TCanvas
end destructor
/' TImageList '/
sub TImageList.CreateHandle
end sub
sub TImageList.DestroyHandle
end sub
sub TImageList.NotifyControl
end sub
property TImageList.WindowHandle as HWND
end property
property TImageList.WindowHandle(value as HWND)
end property
property TImageList.Width as integer
end property
property TImageList.Width(value as integer)
end property
property TImageList.Height as integer
end property
property TImageList.Height(value as integer)
end property
property TImageList.BkColor as integer
end property
property TImageList.BkColor(value as integer)
end property
property TImageList.Count as integer
end property
sub TImageList.AddIcon(ByRef Icon as TIcon)
end sub
sub TImageList.AddBitmap(ByRef Bitmap as TBitmap,ByRef Mask as TBitmap)
end sub
sub TImageList.AddCursor(ByRef Cursor as TCursor)
end sub
sub TImageList.AddMasked(ByRef Bitmap as TBitmap,MaskColor as integer)
end sub
function TImageList.GetBitmap(Index as integer) as TBitmap
end function
function TImageList.GetMask(Index as integer) as TBitmap
end function
function TImageList.GetIcon(Index as integer) as TIcon
end function
function TImageList.GetCursor(Index as integer) as TCursor
end function
sub TImageList.Remove(Index as integer)
end sub
sub TImageList.DrawEx(Index as integer,DestDC as HDC,X as integer,Y as integer,iWidth as integer,iHeight as integer,FG as integer,BK as integer)
end sub
sub TImageList.Draw(Index as integer,DestDC as HDC,X as integer,Y as integer)
end sub
sub TImageList.CopyList(ByRef value as TImageList)
end sub
sub TImageList.Clear
end sub
operator TImageList.let(ByRef value as TImageList)
end operator
operator TImageList.let(value as HIMAGELIST)
end operator
operator TImageList.cast as any ptr
end operator
constructor TImageList
end constructor
destructor TImageList
end destructor
/' TGraphic '/
sub TGraphic.RegisterGraphExtension(value as string)
end sub
property TGraphic.GraphExtension(index as integer) as string
end property
property TGraphic.GraphExtension(index as integer,value as string)
end property
operator TGraphic.cast as any ptr
end operator
operator TGraphic.cast as TBitmap
end operator
operator TGraphic.cast as TIcon
end operator
operator TGraphic.cast as TCursor
end operator
operator TGraphic.let(ByRef value as TGraphic)
end operator
operator TGraphic.let(ByRef value as TBitmap)
end operator
operator TGraphic.let(ByRef value as TIcon)
end operator
operator TGraphic.let(ByRef value as TCursor)
end operator
constructor TGraphic
end constructor
destructor TGraphic
end destructor
Re: Creating a control's container
Merci eodor, je pense que c'est un excellent travail, j'ai moi aussi, depuis mon dernier post, essayé de développer un ensemble de classes pour une mini GUI mais plus simple pour voir ce que ça donne, je pense que ça peut aider malgré son état primitive, tu peux la télécharger par ce lien:
http://www.sendspace.com/file/kb15b2
http://www.sendspace.com/file/kb15b2
Re: Creating a control's container
J'adore votre travail. Il est simple mais efficace. En outre, il est très clair et compréhensible que code. Mon conseil est de continuer. Si je peux aider en quelque sorte, n'hésitez pas à me contacter à nastasa.eodor@gmail.com.OldBasic wrote:Merci eodor, je pense que c'est un excellent travail, j'ai moi aussi, depuis mon dernier post, essayé de développer un ensemble de classes pour une mini GUI mais plus simple pour voir ce que ça donne, je pense que ça peut aider malgré son état primitive, tu peux la télécharger par ce lien:
http://www.sendspace.com/file/kb15b2
P.S.Finalement, désolé pour mon français, mais le français est enseigné à l'école, il ya de nombreuses années...
Re: Creating a control's container
Je ne croix pas que je suis en mesure de réaliser ce travail tout seul, je pense que le développement d'une bibliothèque de composants pour FreeBasic de qualité professionnelle comme la LCL de Lazaus pour FreePascal, est l’affaire d’un groupe dans le cadre d'un projet de longue haleine. Alors si tu compte un jour former un tel groupe pour cette mission, je suis tout a fait disponible a en faire partie. :-)
Pour ton français, je croix, qu’il n’est pas si loin du mien, en tout cas c’est mieux que mon anglais… :-(
Pour ton français, je croix, qu’il n’est pas si loin du mien, en tout cas c’est mieux que mon anglais… :-(
Re: Creating a control's container
Pour la compréhension entre vous deux, c'est peut-être mieux.OldBasic wrote:Pour ton français, je croix, qu’il n’est pas si loin du mien, en tout cas c’est mieux que mon anglais… :-(
Mais pensez à tous les autres utilisateurs qui ne comprennent pas ou peu le français.
Re: Creating a control's container
Vous avez tout à fait raison, j'ai essayé de m'exprimer en anglais mais c'est en postant en français que j'ai pu me faire comprendre, en tout cas c'est mon dernier post en français, c'est promis :-(fxm wrote:Mais pensez à tous les autres utilisateurs qui ne comprennent pas ou peu le français.