Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
fbforms.bi
| Uploader: |  hansholger |
| Datum/Zeit: | 25.03.2014 17:10:07 |
'
#include once "windows.bi"
#Include once "win/commctrl.bi"
'----------------------------------------- Das Menu ------------------------------
Dim Shared acc() AS ACCEL
Type FMenuItem Extends Object
Declare Property vKey As UShort
Declare Property vKey( value As UShort)
Declare Property sKey As String
Declare Property sKey( value As String)
Declare Property ctrKey As Integer
Declare Property ctrKey(ByVal value As Integer)
Declare Property EventSub(ByVal value As Any Ptr)
Declare Property EventSub As Any Ptr
Declare Property MItemID As Integer
Declare Property MItemID(ByVal value As Integer)
Declare Property bmpUnCeck(value As String)
Declare Property bmpCeck(value As String)
Declare Property hbmUnCeck As HBITMAP
Declare Property hbmCeck As HBITMAP
Declare Property Check(ByVal value As Integer)
Declare Property Check As Integer
Declare Property Enabled(ByVal value As Integer)
Declare Property Enabled As Integer
Declare Sub addAccel(ByVal virt As Integer,ByVal vK As UShort , sK As String)
Declare Constructor
Declare Destructor
hMenuBar As HMENU
Private:
m_sKey As String
m_vKey As UShort
m_ctrKey As Integer
m_accel As Integer
m_Check As Integer
m_Enabled As Integer
m_EventSub As Any Ptr
m_MItemID As Integer
m_bmpUnCeck As HBITMAP
m_bmpCeck As HBITMAP
End Type
Constructor FMenuItem
this.m_Check = 0
this.m_vKey = 0
this.m_ctrKey = 0
this.m_EventSub = 0
this.m_bmpUnCeck = 0
this.m_bmpCeck = 0
End Constructor
Destructor FMenuItem
If this.m_bmpUnCeck Then
DeleteObject(this.m_bmpUnCeck)
EndIf
If this.m_bmpCeck Then
DeleteObject(this.m_bmpCeck)
EndIf
End Destructor
Property FMenuItem.hbmUnCeck As HBITMAP
Return this.m_bmpUnCeck
End Property
Property FMenuItem.hbmCeck As HBITMAP
Return this.m_bmpCeck
End Property
Property FMenuItem.sKey As String
Return this.m_sKey
End Property
Property FMenuItem.sKey( value As String)
this.m_sKey = value
End Property
Property FMenuItem.vKey As UShort
Return this.m_vKey
End Property
Property FMenuItem.vKey( value As UShort)
this.m_vKey = value
End Property
Property FMenuItem.ctrKey As Integer
Return this.m_ctrKey
End Property
Property FMenuItem.ctrKey(ByVal value As Integer)
this.m_ctrKey = value
End Property
Property FMenuItem.bmpUnCeck( value As String)
Dim As ZString * MAX_PATH szRes
szRes = value
If this.m_bmpUnCeck Then
DeleteObject(this.m_bmpUnCeck)
EndIf
If InStr(szRes,".") = 0 Then ' Wenn kein Punkt (.) enthalen ist, dann Resource
this.m_bmpUnCeck = LoadBitmap(GetModuleHandle(0) , cast( LPCSTR, @szRes ))
Else ' mit Punkt (.) dann Deteiname
this.m_bmpUnCeck = LoadImage(NULL,@szRes,IMAGE_Bitmap,0,0,LR_DEFAULTCOLOR Or LR_LOADFROMFILE )
End If
If this.m_bmpUnCeck = 0 Then
MessageBox( null, "Fehler - Bitmap ist nicht geladen", "Menu Error", MB_ICONERROR )
EndIf
End Property
Property FMenuItem.bmpCeck( value As String)
Dim As ZString * MAX_PATH szRes
szRes = value
If this.m_bmpCeck Then
DeleteObject(this.m_bmpCeck)
EndIf
If InStr(szRes,".") = 0 Then ' Wenn kein Punkt (.) enthalen ist, dann Resource
this.m_bmpCeck = LoadBitmap(GetModuleHandle(0) , cast( LPCSTR, @szRes ))
Else ' mit Punkt (.) dann Deteiname
this.m_bmpCeck = LoadImage(NULL,@szRes,IMAGE_Bitmap,0,0,LR_DEFAULTCOLOR Or LR_LOADFROMFILE )
End If
If this.m_bmpCeck = 0 Then
MessageBox( null, "Fehler - Bitmap ist nicht geladen", "Menu Error", MB_ICONERROR )
EndIf
End Property
Property FMenuItem.Check(ByVal value As Integer)
this.m_Check = IIf(value, MFS_CHECKED, MFS_UNCHECKED )
If this.hMenuBar Then
Dim As MENUITEMINFO mi
Dim retval As Integer
mi.cbSize = SizeOf(mi)
mi.fMask = MIIM_CHECKMARKS Or MIIM_STATE
mi.hbmpChecked = this.m_bmpCeck
mi.hbmpUnchecked = this.m_bmpUnCeck
mi.fState = this.m_Check
retval = SetMenuItemInfo(this.hMenuBar,this.MItemID,FALSE,@mi)
End If
End Property
Property FMenuItem.Check As Integer
Return this.m_Check
End Property
Property FMenuItem.Enabled(ByVal value As Integer)
this.m_Enabled = value
If this.hMenuBar Then
Dim As MENUITEMINFO mi
Dim retval As Integer
mi.cbSize = SizeOf(mi)
mi.fMask = MIIM_STATE
mi.fState = IIf(value, MFS_ENABLED, MFS_DISABLED)
retval = SetMenuItemInfo(this.hMenuBar,this.MItemID,FALSE,@mi)
End If
End Property
Property FMenuItem.Enabled As Integer
Return this.m_Enabled
End Property
Property FMenuItem.EventSub(ByVal value As Any Ptr)
this.m_EventSub = value
End Property
Property FMenuItem.EventSub As Any Ptr
Return this.m_EventSub
End Property
Property FMenuItem.MItemID As Integer
Return this.m_MItemID
End Property
Property FMenuItem.MItemID(ByVal value As Integer)
this.m_MItemID = value
End Property
Sub FMenuItem.addAccel(ByVal virt As Integer,ByVal vK As UShort , sK As String)
this.ctrKey = virt
this.vKey = vK
this.sKey = sK
End Sub
'--------------------------------------------------------------------
' Das Menu
'--------------------------------------------------------------------
Type FMenu Extends Object
public:
Declare Sub Create(ByVal hParent As HWND)
Declare Sub CreateSubMenu(sName As String )
Declare Sub AddItem(oItem As FMenuItem Ptr,sText As String)
Declare Sub Seperator()
Declare Constructor
Declare Destructor
Declare Property Handle As HMENU
Declare Property Parent As HWND
Declare Sub FMenuProc(ByVal wID As Integer)
Private:
m_accel As Integer
m_Curpos As Integer
m_Newpos As Integer
m_Handle As HMENU
m_Parent As HWND
m_ItemID As Integer
End Type
Constructor FMenu
this.m_Handle = 0
this.m_Parent = 0
this.m_NewPos = 0
this.m_Curpos = 0
this.m_ItemID = 1024
this.m_accel = -1
End Constructor
Destructor FMenu
DestroyMenu(this.m_Handle)
End Destructor
Property FMenu.Handle As HMENU
Return this.m_Handle
End Property
Property FMenu.Parent As HWND
Return this.m_Parent
End Property
Sub FMenu.Create(ByVal hParent As HWND)
this.m_Parent = hParent
this.m_Handle = CreateMenu()
SetMenu(hParent,this.m_Handle)
End Sub
Sub FMenu.CreateSubMenu(sName As String )
Dim As ZString * 128 szText
Dim As Integer er
Dim As MENUITEMINFO mi
this.m_Curpos = this.m_NewPos
szText = sName
mi.cbSize = SizeOf(mi)
mi.fMask = MIIM_TYPE Or MIIM_SUBMENU
mi.fType = MFT_STRING
mi.hSubMenu = CreatePopupMenu()
mi.dwTypeData = @szText
mi.cch = Len(szText)
If InsertMenuItem(this.m_Handle,this.m_NewPos,TRUE,@mi) = 0 Then
er = GetLastError
MessageBox(0," Fehler SubMenu - Error Nr. = "+Str$(er),"info",MB_OK)
EndIf
this.m_NewPos = this.m_Curpos + 1
End Sub
Sub FMenu.AddItem(oItem As FMenuItem Ptr,sText As String)
Dim As ZString * 128 szText
Dim As MENUITEMINFO mi
Dim As HMENU hsubMenu
Dim As string vK = ""
oItem->hMenuBar = this.Handle
hsubMenu = GetSubMenu(this.m_Handle,this.m_Curpos)
If oItem->vKey > 0 Then
this.m_accel = this.m_accel + 1
ReDim Preserve acc(this.m_accel)
acc(this.m_accel).fVirt = oItem->ctrKey Or FVIRTKEY
acc(this.m_accel).key = oItem->vKey
acc(this.m_accel).cmd = this.m_ItemID
If oItem->ctrKey = FSHIFT Then
vK = "Shift+"
sText = sText + Chr(9) + vK + oItem->sKey
ElseIf oItem->ctrKey = FCONTROL Then
vK = "Ctrl+"
sText = sText + Chr(9) + vK + oItem->sKey
ElseIf oItem->ctrKey = FALT Then
vK = "Alt+"
sText = sText + Chr(9) + vK + oItem->sKey
ElseIf oItem->ctrKey = 0 Then
sText = sText + Chr(9) + oItem->sKey
EndIf
EndIf
oItem->MItemID = this.m_ItemID
szText = sText
mi.cbSize = SizeOf(mi)
mi.fMask = MIIM_SUBMENU Or MIIM_TYPE Or MIIM_DATA Or MIIM_ID Or MIIM_CHECKMARKS
mi.fType = MFT_STRING
mi.hSubMenu = 0
mi.hbmpChecked = oItem->hbmCeck
mi.hbmpUnchecked = oItem->hbmUnCeck
mi.wID = this.m_ItemID
mi.dwItemData = CInt(oItem->EventSub)
mi.dwTypeData = @szText
mi.cch = Len(szText)
InsertMenuItem(hsubMenu,this.m_ItemID,FALSE,@mi)
this.m_ItemID = this.m_ItemID + 1
End Sub
Sub FMenu.Seperator()
Dim As MENUITEMINFO mi
Dim As HMENU hsubMenu
hsubMenu = GetSubMenu(this.Handle,this.m_Curpos)
mi.cbSize = SizeOf(mi)
mi.fMask = MIIM_SUBMENU Or MIIM_TYPE
mi.fType = MFT_SEPARATOR
mi.hSubMenu = 0
mi.wID = 0
mi.dwItemData = 0
mi.dwTypeData = 0
mi.cch = 0
InsertMenuItem(hsubMenu,-1,FALSE,@mi)
End Sub
Sub FMenu.FMenuProc(ByVal wID As Integer)
Dim onClick As Sub()
Dim As MENUITEMINFO mi
mi.cbSize = SizeOf(mi)
mi.fMask = MIIM_DATA Or MIIM_ID
GetMenuItemInfo(this.m_Handle,wID,FALSE,@mi)
If mi.dwItemData Then
onClick = Cast(Any Ptr,mi.dwItemData)
onClick()
EndIf
End Sub
'
'###################################### End Menu ##############################
'----------------------------------------------------------------------------------------------------------
' Form
'----------------------------------------------------------------------------------------------------------
Type FForm Extends Object
Public:
Declare Property Left() As Integer ' Get Left
Declare Property Left( ByVal value As Integer ) ' Set Left
Declare Property Top() As Integer ' Get Top
Declare Property Top( ByVal value As Integer ) ' Set Top
Declare Property Width() As Integer ' Get Width
Declare Property Width( ByVal value As Integer ) ' Set Width
Declare Property Height() As Integer ' Get Height
Declare Property Height( ByVal value As Integer ) ' Set Height
Declare Property ClientHeight() As Integer ' Get ClientHeight
Declare Property ClientWidth() As Integer ' Get ClientWidth
Declare Property Style() As UInteger ' Get Style
Declare Property Style(ByVal value As UInteger) ' Set Style
Declare Property ExStyle() As UInteger ' Get ExStyle
Declare Property ExStyle(ByVal value As UInteger) ' Set ExStyle
Declare Property Caption as string ' Get Caption
Declare Property Caption(value as string) ' Set Caption
Declare Property Visible as Integer ' Get Visible
Declare Property Visible( ByVal value as Integer) ' Set Visible
Declare Property Enabled as Integer ' Get Enabled
Declare Property Enabled( ByVal value as Integer) ' Set Enabled
Declare Property Color() As UInteger ' Get HintergrundColor
Declare Property Color( ByVal value As UInteger ) ' Set HintergrundColor
Declare Property Handle() As HWND ' Get Handle
Declare Property Handle( ByVal value As HWND ) ' Set Handle
Declare Property BorderIcon(value as Integer)
Declare Property Border(value as Integer)
Declare Property Icon( sIcon As String)
Declare Sub Create(sCaption As String,ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Declare Sub Center
Declare Sub Show
Declare Sub FormClose
Declare Sub Invalidate
Declare Sub Repaint
Declare Constructor
Declare Destructor
As FMenu menu
' Events
onShow As Sub(ByVal w As UInteger)
onSize As Sub(ByVal w As Integer, ByVal h As Integer,ByVal flag As Integer)
onPaint As Sub(ByVal hDC As HDC)
onLbuttondown As Sub(ByVal x As Integer,ByVal y As Integer,ByVal flag As Integer)
onLbuttonup As Sub(ByVal x As Integer,ByVal y As Integer,ByVal flag As Integer)
onRbuttondown As Sub(ByVal x As Integer,ByVal y As Integer,ByVal flag As Integer)
onMousemove As Sub(ByVal x As Integer,ByVal y As Integer,ByVal flag As Integer)
onCommand As Sub(ByVal notify As Integer,ByVal ID As Integer,ByVal ctl As LPARAM )
onClose As Sub()
onKeyDown As Sub(nKey AS Integer,lKeyStatus As Integer)
onKeyChar As Sub(nKey AS Integer,lKeyStatus As Integer)
onKeyUp As Sub(nKey AS Integer,lKeyStatus As Integer)
Private:
Declare Static Function FormWinProc(hCtrl As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
As Integer b_Left = 0
As Integer b_Top = 0
As Integer b_Width = 0
As Integer b_Height = 0
As HWND b_Handle = 0
As String b_Caption = ""
As UInteger b_ExStyle = 0
As UInteger b_Style = 0
As Integer b_Visible = SW_SHOWNORMAL
As Integer b_Enabled = TRUE
As UInteger b_Color = &HFFFFFF ' Hintergrund weiss
As UInteger b_Border = 0
As Integer b_Center = 0
As String b_Icon = ""
End Type
Property FForm.Left() As Integer
Return this.b_Left
End Property
Property FForm.Left( ByVal value As Integer )
If this.b_Handle Then
this.b_Left = value
MoveWindow(b_Handle,b_Left,b_Top,b_Width,b_Height ,TRUE)
End If
End Property
Property FForm.Top() As Integer
Return this.b_Top
End Property
Property FForm.Top( ByVal value As Integer )
If this.b_Handle Then
this.b_Top = value
MoveWindow(b_Handle,b_Left,b_Top,b_Width,b_Height ,TRUE)
End If
End Property
Property FForm.Width() As Integer
Return this.b_Width
End Property
Property FForm.Width( ByVal value As Integer )
If this.b_Handle Then
this.b_Width = value
MoveWindow(b_Handle,b_Left,b_Top,b_Width,b_Height ,TRUE)
End If
End Property
Property FForm.Height() As Integer
Return this.b_Height
End Property
Property FForm.Height( ByVal value As Integer )
If this.b_Handle Then
this.b_Height = value
MoveWindow(b_Handle,b_Left,b_Top,b_Width,b_Height ,TRUE)
End If
End Property
Property FForm.ClientHeight() As Integer
Dim As RECT rc
If this.b_Handle Then
GetClientRect(this.Handle,@rc)
Return rc.bottom
End If
End Property
Property FForm.ClientWidth() As Integer
Dim As RECT rc
If this.b_Handle Then
GetClientRect(this.Handle,@rc)
Return rc.right
End If
End Property
Property FForm.Handle() As HWND ' Get Handle
Return this.b_Handle
End Property
Property FForm.Handle(ByVal Value As HWND) ' Set Handle
this.b_Handle = Value
End Property
Property FForm.Caption as string ' Get Caption
Return this.b_Caption
End Property
Property FForm.Caption(value as string) ' Set Caption
If this.b_Handle Then
this.b_Caption = value
SetWindowText(b_Handle,value)
Repaint
End If
end Property
Property FForm.Style() As UInteger ' Get Style
Return this.b_Style
end Property
Property FForm.Style(ByVal value As UInteger) ' Set Style
this.b_Style = value
end Property
Property FForm.ExStyle() As UInteger ' Get ExStyle
Return this.b_ExStyle
end Property
Property FForm.ExStyle(ByVal value As UInteger) ' Set ExStyle
this.b_ExStyle = value
end Property
Property FForm.Enabled as Integer
Return this.b_Enabled
End Property
Property FForm.Enabled(ByVal value as Integer) ' value = True : Enabled
this.b_Enabled = IIf(value,TRUE,FALSE)
If this.b_Handle Then
EnableWindow(this.b_Handle,this.b_Enabled)
End If
End Property
Property FForm.Visible as Integer
Return this.b_Visible
End Property
Property FForm.Visible(ByVal value as Integer) ' value = 0 : SW_HIDE ; 1 : SW_SHOW
this.b_Visible = value
If this.b_Handle Then
ShowWindow(this.b_Handle,IIf(value,SW_SHOW,SW_HIDE))
End If
End Property
Property FForm.Color() As UInteger ' Get HintergrundColor
Return this.b_Color
End Property
Property FForm.Color( ByVal value As UInteger ) ' Set Hintergrund Color bei Text
If this.b_Handle Then
this.b_Color = value
Repaint
End If
end Property
Property FForm.Icon( sIcon As String)
this.b_Icon = sIcon
End Property
Property FForm.BorderIcon(value as Integer)
Dim styl As UInteger
If this.Handle Then
styl = GetWindowLong(this.handle,GWL_STYLE)
If value = 1 Then
styl = styl And (Not WS_MAXIMIZEBOX)
ElseIf value = 2 Then
styl = styl And (Not WS_MINIMIZEBOX)
ElseIf value = 3 Then
styl = styl And (Not WS_MAXIMIZEBOX)
styl = styl And (Not WS_MINIMIZEBOX)
EndIf
SetWindowLong(this.handle,GWL_STYLE,styl)
EndIf
End Property
Property FForm.Border(value as Integer)
If this.Handle Then
If value = 1 Then
this.style = WS_VISIBLE Or WS_OVERLAPPEDWINDOW
ElseIf value = 2 Then
this.style = WS_VISIBLE Or WS_DLGFRAME Or WS_SYSMENU Or WS_CAPTION
ElseIf value = 3 Then
this.style = WS_VISIBLE Or WS_POPUPWINDOW Or WS_CAPTION
this.ExStyle = WS_EX_TOOLWINDOW
SetWindowLong(this.handle,GWL_EXSTYLE,this.ExStyle)
ElseIf value = 4 Then
this.style = WS_VISIBLE Or WS_POPUP
this.ExStyle = 0
SetWindowLong(this.handle,GWL_EXSTYLE,this.ExStyle)
EndIf
SetWindowLong(this.handle,GWL_STYLE,this.style)
Repaint
EndIf
End Property
Sub FForm.Center
If this.Handle Then
Dim As Integer SreenX = GetSystemMetrics(SM_CXSCREEN)
Dim As Integer SreenY = GetSystemMetrics(SM_CYSCREEN)
this.Left = (SreenX - this.Width) / 2
this.Top = (SreenY - this.Height) / 2
MoveWindow(this.Handle,this.Left,this.Top,this.Width,this.Height ,TRUE)
End if
End Sub
Sub FForm.Invalidate
If this.b_Handle Then
InvalidateRect(this.b_Handle,0,TRUE)
EndIf
End Sub
Sub FForm.Repaint
If this.b_Handle Then
RedrawWindow(this.b_Handle,0,0,RDW_ERASE Or RDW_INVALIDATE Or RDW_FRAME)
EndIf
End Sub
'---------------------------------------- Win Proc ------------------------------------------------
Function FForm.FormWinProc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Dim as FForm ptr Form = cast(FForm ptr,GetWindowLong(hWnd,GWL_USERDATA))
Dim As Integer lKeyDat = 0
Select case uMsg
Case WM_GETDLGCODE
Function = DLGC_WANTALLKEYS
Exit Function
Case WM_SHOWWINDOW
If Form Then
If Form->onShow then Form->onShow(wParam)
End If
Function = 0
Exit Function
'------------------------- onSize
Case WM_SIZE
If Form Then
If Form->onSize then Form->onSize(LOWORD(lParam),HIWORD(lParam),wParam)
End If
Function = 0
Exit Function
'------------------------- onPaint
Case WM_PAINT
dim pnt as PAINTSTRUCT
dim hDC as HDC
Dim rc As RECT
Dim hBr As HBRUSH
hDC = BeginPaint( hWnd, @pnt )
GetClientRect(hWnd,@rc)
If Form Then
SetBkColor(hDC,Form->Color)
hBr = CreateSolidBrush(Form->Color)
FillRect(hDC,@rc,hBr)
DeleteObject(hBr)
'Event Sub
If Form->onPaint then Form->onPaint(hDC)
End If
EndPaint( hWnd, @pnt )
Function = 0
Exit Function
'-------------------------
Case WM_LBUTTONDOWN
If Form Then
If Form->onLbuttondown then Form->onLbuttondown(LOWORD(lParam),HIWORD(lParam),wParam)
End If
Function = 0
Exit Function
'-------------------------
Case WM_LBUTTONUP
If Form Then
If Form->onLbuttonup then Form->onLbuttonup(LOWORD(lParam),HIWORD(lParam),wParam)
End If
Function = 0
Exit Function
'-------------------------
Case WM_MOUSEMOVE
If Form Then
If Form->onMousemove then Form->onMousemove(LOWORD(lParam),HIWORD(lParam),wParam)
End If
Function = 0
Exit Function
'-------------------------
Case WM_RBUTTONDOWN
If Form Then
If Form->onRbuttondown then Form->onRbuttondown(LOWORD(lParam),HIWORD(lParam),wParam)
End If
Function = 0
Exit Function
'-------------------------
Case WM_KEYDOWN
If Form Then
If Form->onKeyDown then
If GetKeyState(VK_SHIFT) < -126 Then
lKeyDat = VK_SHIFT '&H10
ElseIf GetKeyState(VK_CONTROL) < -126 Then
lKeyDat = VK_CONTROL '&H11
ElseIf GetKeyState(VK_MENU) < -126 Then
lKeyDat = VK_MENU '&H12
End If
Form->onKeyDown(wParam,lKeyDat)
EndIf
End If
Function = 0
Exit Function
'-------------------------
Case WM_CHAR
If Form Then
If Form->onKeyChar then
If GetKeyState(VK_SHIFT) < -126 Then
lKeyDat = VK_SHIFT '&H10
ElseIf GetKeyState(VK_CONTROL) < -126 Then
lKeyDat = VK_CONTROL '&H11
ElseIf GetKeyState(VK_MENU) < -126 Then
lKeyDat = VK_MENU '&H12
End If
Form->onKeyChar(wParam,lKeyDat)
EndIf
End If
Function = 0
Exit Function
Case WM_KEYUP
If Form Then
If Form->onKeyUp then
If GetKeyState(VK_SHIFT) < -126 Then
lKeyDat = VK_SHIFT '&H10
ElseIf GetKeyState(VK_CONTROL) < -126 Then
lKeyDat = VK_CONTROL '&H11
ElseIf GetKeyState(VK_MENU) < -126 Then
lKeyDat = VK_MENU '&H12
End If
Form->onKeyUp(wParam,lKeyDat)
EndIf
End If
Function = 0
Exit Function
'-------------------------
Case WM_CLOSE
If Form Then
If Form->onClose then Form->onClose()
DestroyWindow(hWnd)
End if
Function = 0
Exit Function
'-------------------------
case WM_DESTROY
PostQuitMessage(0)
Function = 0
Exit Function
'-------------------------
Case WM_COMMAND
If (lParam = 0) And ( HIWORD(wParam) = 0) Then ' Menu
Form->menu.FMenuProc(LOWORD(wParam))
Exit Function
EndIf
If (lParam = 0) And ( HIWORD(wParam) = 1) Then ' Accelerator
Form->menu.FMenuProc(LOWORD(wParam))
Exit Function
EndIf
If Form Then
If Form->onCommand then Form->onCommand(HIWORD(wParam),LoWord(wParam), lParam)
End if
Function = 0
Exit Function
End Select
function = DefWindowProc( hWnd, uMsg, wParam, lParam )
end Function
Sub FForm.Create(sCaption As String, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Dim wcls as WNDCLASS
Dim As ZString * 128 szClass
Dim rc As RECT
szClass = "FB_FORM"
If 0 = GetClassInfo(GetModuleHandle(0),@szClass,@wcls) Then
with wcls
.style = CS_HREDRAW or CS_VREDRAW
.lpfnWndProc = @FForm.FormWinProc
.cbClsExtra = 0
.cbWndExtra = 0
.hInstance = GetModuleHandle(0)
.hIcon = LoadIcon( NULL,IDI_APPLICATION )
.hCursor = LoadCursor( NULL, IDC_ARROW )
.hbrBackground = GetStockObject(WHITE_BRUSH)
.lpszMenuName = NULL
.lpszClassName = @szClass
end with
if( RegisterClass( @wcls ) = FALSE ) then
MessageBox( null, "Fehler - Class ist nicht registriert", "Error", MB_ICONERROR )
exit Sub
end if
End If
this.Handle = CreateWindowEx( this.Exstyle, @szClass, sCaption, this.style, x, y, w, h , _
NULL, NULL, GetModuleHandle(0), NULL )
If this.Handle Then
this.Left = x
this.Top = y
this.Width = w
this.Height = h
this.Caption = sCaption
SetWindowLong(this.Handle,GWL_USERDATA,CInt(@This)) ' Zeiger auf FForm
Else
MessageBox( null, "Fehler - CreateWindow FForm", "Error", MB_ICONERROR )
End If
End Sub
Sub FForm.Show
Dim wMsg as MSG
Dim hAcc As HACCEL
Dim szFile As ZString * 128
Dim hIcon As HICON
Dim nAcc As Integer
If Len(this.b_Icon) > 2 Then
szFile = this.b_Icon '
If InStr(szFile,".") Then
hIcon = LoadImage(NULL,@szFile,IMAGE_ICON,0,0,LR_DEFAULTCOLOR Or LR_LOADFROMFILE )
Else
hIcon = LoadIcon(GetModuleHandle(0),cast( LPCSTR, @szFile))
EndIf
If hIcon Then
SetClassLong(this.Handle,GCL_HICON,CInt(hIcon))
Else
MessageBox(0,"ICON nicht gefunden","Fehler",MB_ICONERROR)
EndIf
End If
ShowWindow( this.Handle,SW_SHOW )
repaint
If GetMenu(this.Handle) Then
DrawMenuBar(this.Handle)
EndIf
nAcc = UBOUND(acc) + 1
If nAcc > 0 Then
hAcc = CreateAcceleratorTable(@acc(0),nAcc)
End If
while( GetMessage( @wMsg, NULL, 0, 0 ) <> FALSE )
If TranslateAccelerator(this.Handle, hAcc, @wMsg) = 0 Then
If (IsWindow(this.Handle) = 0) OR (IsDialogMessage(this.Handle,@wMsg)= 0 )Then
TranslateMessage( @wMsg )
DispatchMessage( @wMsg )
End If
End if
Wend
If hAcc Then
DestroyAcceleratorTable(hAcc)
End If
End Sub
Sub FForm.FormClose
If this.Handle Then
PostMessage( this.Handle, WM_CLOSE, 0, 0 )
End If
End Sub
Constructor FForm
this.Color = &HFFFFFF
this.Handle = 0
this.ExStyle = WS_EX_CONTROLPARENT
this.Style = WS_VISIBLE Or WS_OVERLAPPEDWINDOW
end Constructor
Destructor FForm
this.Handle = 0
end Destructor
'############################################# Ende Form-Class ###########################################
'----------------------------------------------------------------------------------------------------------
' DialogBox
'----------------------------------------------------------------------------------------------------------
Type FDialogBox Extends Object
public:
Declare Property ExStyle() As UInteger ' Get ExStyle
Declare Property ExStyle(ByVal value As UInteger) ' Set ExStyle
Declare Property Caption as string ' Get Caption
Declare Property Caption(value as string) ' Set Caption
Declare Property Color as UInteger
Declare Property Color(value as UInteger)
Declare Property Handle() As HWND ' Get Handle
Declare Property Center(ByVal value As Integer)
Declare Function Create(ByVal hParent As HWND,sCaption As String,ByVal w As Integer,ByVal h As Integer ) As Integer
Declare Sub Close(ByVal retVal As Integer)
Declare Constructor
Declare Destructor
' Events
OnInitdialog As Sub(ByVal hWind As HWND)
onShow as Sub(ByVal flag As Integer)
onSize As Sub(ByVal w As Integer, ByVal h As Integer,ByVal flag As Integer)
onPaint As Sub(ByVal hDC As HDC)
onLbuttondown As Sub(ByVal x As Integer,ByVal y As Integer,ByVal flag As Integer)
onLbuttonup As Sub(ByVal x As Integer,ByVal y As Integer,ByVal flag As Integer)
onMousemove As Sub(ByVal x As Integer,ByVal y As Integer,ByVal flag As Integer)
onKeyDown As Sub(ByVal nVirtKey As Integer,ByVal lKeyDat As Integer)
onKeyChar As Sub(ByVal nVirtKey As Integer,ByVal lKeyDat As Integer)
onKeyUp As Sub(ByVal nVirtKey As Integer,ByVal lKeyDat As Integer)
onCommand As Sub(ByVal notify As Integer,ByVal ID As Integer,ByVal ctl As LPARAM)
onClose As Sub()
Private:
Declare Static Function DlgWinProc(hCtrl As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
As Integer d_Left = 0
As Integer d_Top = 0
As Integer d_Width = 0
As Integer d_Height = 0
As HWND d_Handle = 0
As String d_Caption = "Dialog"
As UInteger d_Style = 0
As UInteger d_Exstyle = 0
As UInteger d_Color = &HFFFFFF
As Integer d_Center = 1
As HWND d_Parent = 0
End Type
Property FDialogBox.ExStyle() As UInteger ' Get ExStyle
Return this.d_Exstyle
end Property
Property FDialogBox.ExStyle(ByVal value As UInteger) ' Set ExStyle
this.d_Exstyle = value
end Property
Property FDialogBox.Color as UInteger
Return this.d_Color
End Property
Property FDialogBox.Color(value as UInteger)
this.d_Color = value
End Property
Property FDialogBox.Handle() As HWND ' Get Handle
Return this.d_Handle
End Property
Property FDialogBox.Caption as string ' Get Caption
Return this.d_Caption
End Property
Property FDialogBox.Caption(value as string) ' Set Caption
If this.d_Handle Then
this.d_Caption = value
SetWindowText(d_Handle,value)
ShowWindow( d_Handle, SW_HIDE) ' alle Änderungen nach Create werden
ShowWindow( d_Handle, SW_SHOW) ' hier neu gezeichnet
End If
End Property
Property FDialogBox.Center(ByVal value As Integer)
d_Center = value
End Property
Function FDialogBox.DlgWinProc(hWnd As HWND, uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Dim As FDialogBox Ptr Dialog = Cast(FDialogBox Ptr,GetWindowLong(hWnd,GWL_USERDATA))
Dim hBr As HBRUSH
Dim As Integer lKeyDat = 0
Select case uMsg
Case WM_INITDIALOG
Dialog = Cast(FDialogBox Ptr,lParam)
SetWindowLong(hWnd,GWL_USERDATA,CInt(Dialog))
Dialog->d_Handle = hWnd
SetWindowText(hWnd,Dialog->d_caption)
MoveWindow(hWnd,Dialog->d_Left,Dialog->d_Top,Dialog->d_Width,Dialog->d_Height,TRUE)
If Dialog->OnInitdialog Then Dialog->OnInitdialog(hWnd)
Function = 0
Exit Function
'------------------------- onShow
Case WM_SHOWWINDOW
If Dialog Then
If Dialog->onShow then Dialog->onShow(wParam)
End If
Function = 0
Exit Function
'------------------------- onSize
Case WM_SIZE
If Dialog Then
If Dialog->onSize then Dialog->onSize(LOWORD(lParam),HIWORD(lParam),wParam)
End If
Function = 0
Exit Function
'------------------------- onPaint
Case WM_PAINT
dim pnt as PAINTSTRUCT
dim hDC as HDC
hDC = BeginPaint( hWnd, @pnt )
If Dialog Then
If Dialog->onPaint then Dialog->onPaint(hDC)
End If
EndPaint( hWnd, @pnt )
Function = 0
Exit Function
'------------------------- Hintergrundfarbe dieser Dialog
Case WM_CTLCOLORDLG
If hBr Then
DeleteObject(hBr)
EndIf
hBr = CreateSolidBrush(Dialog->d_Color)
Return Cast(LRESULT, hBr)
'------------------------- Hintergrundfarbe Controls
Case WM_LBUTTONDOWN
If Dialog Then
If Dialog->onLbuttondown then Dialog->onLbuttondown(LOWORD(lParam),HIWORD(lParam),wParam)
End If
Function = 0
Exit Function
'-------------------------
Case WM_LBUTTONUP
If Dialog Then
If Dialog->onLbuttonup then Dialog->onLbuttonup(LOWORD(lParam),HIWORD(lParam),wParam)
End If
Function = 0
Exit Function
'-------------------------
Case WM_MOUSEMOVE
If Dialog Then
If Dialog->onMousemove then Dialog->onMousemove(LOWORD(lParam),HIWORD(lParam),wParam)
End If
Function = 0
Exit Function
'-------------------------
Case WM_KEYDOWN
If Dialog Then
If Dialog->onKeyDown then
If GetKeyState(VK_SHIFT) < -126 Then
lKeyDat = VK_SHIFT '&H10
ElseIf GetKeyState(VK_CONTROL) < -126 Then
lKeyDat = VK_CONTROL '&H11
ElseIf GetKeyState(VK_MENU) < -126 Then
lKeyDat = VK_MENU '&H12
End If
Dialog->onKeyDown(wParam,lKeyDat)
EndIf
End If
Function = 0
Exit Function
'-------------------------
Case WM_CHAR
If Dialog Then
If Dialog->onKeyChar then
If GetKeyState(VK_SHIFT) < -126 Then
lKeyDat = VK_SHIFT '&H10
ElseIf GetKeyState(VK_CONTROL) < -126 Then
lKeyDat = VK_CONTROL '&H11
ElseIf GetKeyState(VK_MENU) < -126 Then
lKeyDat = VK_MENU '&H12
End If
Dialog->onKeyChar(wParam,lKeyDat)
EndIf
End If
Function = 0
Exit Function
'-------------------------
Case WM_KEYUP
If Dialog Then
If Dialog->onKeyUp then
If GetKeyState(VK_SHIFT) < -126 Then
lKeyDat = VK_SHIFT '&H10
ElseIf GetKeyState(VK_CONTROL) < -126 Then
lKeyDat = VK_CONTROL '&H11
ElseIf GetKeyState(VK_MENU) < -126 Then
lKeyDat = VK_MENU '&H12
End If
Dialog->onKeyUp(wParam,lKeyDat)
EndIf
End If
Function = 0
Exit Function
'-------------------------
Case WM_COMMAND
If Dialog Then
If Dialog->onCommand then Dialog->onCommand(HIWORD(wParam),LoWord(wParam), lParam)
End If
Exit Function
'-------------------------
case WM_CLOSE
If Dialog then
If Dialog->onClose then Dialog->onClose()
End If
If hBr Then
DeleteObject(hBr)
EndIf
DestroyWindow(hWnd)
Function = 0
Exit Function
End Select
end Function
Function FDialogBox.Create(ByVal hParent As HWND, sCaption As String,ByVal w As Integer,ByVal h As Integer ) As Integer
Dim As RECT rc
Dim as DLGTEMPLATE Ptr lpdt
this.d_Parent = hParent
If hParent Then
GetWindowRect(hParent,@rc)
this.d_Left = (rc.right - w) / 2
this.d_Top = (rc.bottom - h) / 2
Else
Dim As Integer SreenX = GetSystemMetrics(SM_CXSCREEN)
Dim As Integer SreenY = GetSystemMetrics(SM_CYSCREEN)
this.d_Left = (SreenX - w) / 2
this.d_Top = (SreenY - h) / 2
EndIf
this.d_Width = w
this.d_Height = h
this.d_Caption = sCaption
lpdt = Allocate(SizeOf(DLGTEMPLATE))
lpdt->style = this.d_Style
lpdt->dwExtendedStyle = this.d_Exstyle
lpdt->cdit = 0 'number of controls
lpdt->x = this.d_Left
lpdt->y = this.d_Top
lpdt->cx = this.d_Width
lpdt->cy = this.d_Height
Function = DialogBoxIndirectParam(GetModuleHandle(0), lpdt , hParent , @FDialogBox.DlgWinProc, CInt(@This) )
DEALLOCATE lpdt
End Function
Sub FDialogBox.Close(ByVal retVal As Integer)
If d_Handle Then
EndDialog(d_Handle,retVal)
End If
End Sub
Constructor FDialogBox
d_Handle = 0
d_Exstyle = WS_EX_CONTROLPARENT
d_Style = WS_DLGFRAME OR WS_BORDER OR WS_SYSMENU OR WS_CAPTION Or WS_VISIBLE Or DS_SETFONT
end Constructor
Destructor FDialogBox
d_Handle = 0
end Destructor