Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Controls
| Uploader: |  hansholger |
| Datum/Zeit: | 31.03.2014 13:53:31 |
#Include Once "win\Richedit.bi"
Dim Shared InitCommon As Integer = 0
'-----------------------------------------------------------------------------------
' Control
'-----------------------------------------------------------------------------------
Type Control Extends Object
Public:
Declare Constructor
Declare Destructor
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 Caption as string ' Get Caption
Declare Property Caption(value as string) ' Set Caption
Declare Property Font() As HFONT ' Get FontHandle
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 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 TextColor() As UInteger ' Get TextColor
Declare Property TextColor( ByVal value As UInteger ) ' Set TextColor
Declare Property Color() As UInteger ' Get HintergrundColor
Declare Property Color( ByVal value As UInteger ) ' Set HintergrundColor
Declare Property Handle() As HWND ' Get Handle Control
Declare Property Handle( ByVal value As HWND ) ' Set Handle Control
Declare Property Parent() As HWND ' Get Handle
Declare Property Parent( ByVal value As HWND ) ' Set Handle
Declare Property CtHandle() As HWND ' Get Container Handle
Declare Property CtHandle( ByVal value As HWND ) ' Set Container Handle
Declare Property Tip( ByVal value As String ) ' Set ToolTip
' Methods
Declare Sub Invalidate
Declare Sub Focus
Declare Sub Repaint
Declare Sub setFont(Face As String,ByVal size As Integer,ByVal bold As Integer,ByVal italic As Integer,ByVal underlin As Integer)
Declare VIRTUAL Function CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Declare Static Function DispMsg(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Private:
Declare Sub DisplayToolTip
As HWND b_hwndTT
As String b_tooltip = ""
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 HWND b_Parent = 0
As HWND b_Cthandle = 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_TextColor = 0 ' Vordergrund(Text) Schwarz
As UInteger b_Color = &HDCDCDC ' Hintergrund hellgrau
As HFONT b_hFont
End Type
Destructor Control
' wird bei allen Objekten aufgerufen
Dim As ZString * 128 szClass
Dim wcls as WNDCLASS
szClass = "FB_CONTROL"
If GetClassInfo(GetModuleHandle(0),@szClass,@wcls) <> 0 Then
UnregisterClass(@szClass,GetModuleHandle(0))
End if
If this.b_hFont Then
DeleteObject(this.b_hFont)
EndIf
End Destructor
Constructor Control
Dim wcls as WNDCLASS
Dim As ZString * 128 szClass
szClass = "FB_CONTROL"
' Class für die Conainer der Controls
If GetClassInfo(GetModuleHandle(0),@szClass,@wcls) = 0 Then
with wcls
.style = CS_HREDRAW or CS_VREDRAW
.lpfnWndProc = @DispMsg
.cbClsExtra = 0
.cbWndExtra = 0
.hInstance = GetModuleHandle(0)
.hIcon = NULL
.hCursor = LoadCursor(NULL, IDC_ARROW )
.hbrBackground = GetStockObject(WHITE_BRUSH)
.lpszMenuName = NULL
.lpszClassName = @szClass
end with
if( RegisterClass( @wcls ) = FALSE ) then
MessageBox( null, "Fehler - FB_CONTROL Class ist nicht registriert", "Error", MB_ICONERROR )
end if
End If
this.b_Handle = 0
this.b_Cthandle = 0
this.ExStyle = 0
this.Style = WS_VISIBLE Or WS_CHILD
this.b_Visible = SW_SHOWNORMAL
this.b_Enabled = TRUE
this.b_TextColor = 0
this.b_Color = &HDCDCDC
this.b_hFont = GetStockObject(SYSTEM_FONT)
end Constructor
Property Control.Font() As HFONT
Return this.b_hFont
End Property
Property Control.Left() As Integer
Return this.b_Left
End Property
Property Control.Left( ByVal value As Integer )
this.b_Left = value
If this.b_Cthandle Then
MoveWindow(this.b_Cthandle,this.b_Left,this.b_Top,this.b_Width,this.b_Height ,TRUE)
Else
MoveWindow(this.b_Handle,this.b_Left,this.b_Top,this.b_Width,this.b_Height ,TRUE)
End If
End Property
Property Control.Top() As Integer
Return this.b_Top
End Property
Property Control.Top( ByVal value As Integer )
this.b_Top = value
If this.b_Cthandle Then
MoveWindow(this.b_Cthandle,this.b_Left,this.b_Top,this.b_Width,this.b_Height ,TRUE)
Else
MoveWindow(this.b_Handle,this.b_Left,this.b_Top,this.b_Width,this.b_Height ,TRUE)
End If
End Property
Property Control.Width() As Integer
Return this.b_Width
End Property
Property Control.Width( ByVal value As Integer )
this.b_Width = value
If this.b_Cthandle Then
MoveWindow(this.b_Cthandle,this.b_Left,this.b_Top,this.b_Width,this.b_Height ,TRUE)
Else
MoveWindow(this.b_Handle,this.b_Left,this.b_Top,this.b_Width,this.b_Height ,TRUE)
End If
End Property
Property Control.Height() As Integer
Return this.b_Height
End Property
Property Control.Height( ByVal value As Integer )
this.b_Height = value
If this.b_Cthandle Then
MoveWindow(this.b_Cthandle,this.b_Left,this.b_Top,this.b_Width,this.b_Height ,TRUE)
Else
MoveWindow(this.b_Handle,this.b_Left,this.b_Top,this.b_Width,this.b_Height ,TRUE)
End If
End Property
Property Control.ClientHeight() As Integer
If this.b_Handle Then
Dim rc As RECT
GetClientRect(this.b_Handle,@rc)
Return rc.bottom
EndIf
End Property
Property Control.ClientWidth() As Integer
If this.b_Handle Then
Dim rc As RECT
GetClientRect(this.b_Handle,@rc)
Return rc.right
EndIf
End Property
Property Control.Handle() As HWND ' Get Handle
Return this.b_Handle
End Property
Property Control.Handle(ByVal Value As HWND) ' Set Handle
this.b_Handle = Value
End Property
Property Control.CtHandle() As HWND ' Get Container-Handle
Return this.b_Cthandle
End Property
Property Control.CtHandle(ByVal Value As HWND) ' Set Container-Handle
this.b_Cthandle = Value
End Property
Property Control.Parent() As HWND ' Get Handle
Return this.b_Parent
End Property
Property Control.Parent(ByVal Value As HWND) ' Set Handle
this.b_Parent = Value
End Property
Property Control.Caption as string ' Get Caption
Return this.b_Caption
End Property
Property Control.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 Control.Style() As UInteger ' Get Style
Return this.b_Style
end Property
Property Control.Style(ByVal value As UInteger) ' Set Style
this.b_Style = value
End Property
Property Control.ExStyle() As UInteger ' Get ExStyle
Return this.b_ExStyle
end Property
Property Control.ExStyle(ByVal value As UInteger) ' Set ExStyle
this.b_ExStyle = value
end Property
Property Control.Enabled as Integer
Return this.b_Enabled
End Property
Property Control.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 Control.Visible as Integer
Return this.b_Visible
End Property
Property Control.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 Control.TextColor() As UInteger ' Get TextColor
Return this.b_TextColor
end Property
Property Control.TextColor( ByVal value As UInteger ) ' Set TextColor
If this.b_Handle Then
this.b_TextColor = value
Repaint
End If
end Property
Property Control.Color() As UInteger ' Get HintergrundColor
Return this.b_Color
End Property
Property Control.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 Control.Tip( ByVal value As String )
this.b_tooltip = value
If (Len(this.b_tooltip) > 0) And (this.Handle > 0) Then
DisplayToolTip
EndIf
End Property
Sub Control.DisplayToolTip
If InitCommon = 0 Then
InitCommonControls
InitCommon = 1
EndIf
Dim AS TOOLINFO ti
Dim szTip As ZString * 64
If Len(this.b_tooltip) = 0 Then Exit Sub
szTip = this.b_tooltip
this.b_hwndTT = CreateWindow(TOOLTIPS_CLASS, NULL, TTS_ALWAYSTIP, _
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
NULL, NULL, GetModuleHandle(0), NULL)
If this.b_hwndTT Then
ti.cbSize=sizeof(TOOLINFO)
ti.uFlags=TTF_SUBCLASS
If this.Handle Then
ti.hwnd=this.Handle
End If
ti.hinst=GetModuleHandle(0)
ti.lpszText=@szTip
GetClientRect(this.Handle, @ti.rect)
SendMessage(this.b_hwndTT, TTM_ADDTOOL, 0, CAST(LPARAM, @ti))
End If
End Sub
Function Control.CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Function = DefWindowProc(hWnd ,uMsg ,wParam , lParam )
End Function
Function Control.DispMsg(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Dim obj As Control Ptr = Cast(Control Ptr,GetWindowLong(hWnd,GWL_USERDATA)) ' Zeiger auf Klasse die hWnd sendet
If obj Then
Function = obj->CtrlMsgFunc(hWnd ,uMsg ,wParam , lParam )
Else
Function = DefWindowProc(hWnd ,uMsg ,wParam , lParam )
EndIf
End Function
Sub Control.Focus
If this.b_Handle Then
SetFocus(this.b_Handle)
EndIf
End Sub
Sub Control.Invalidate
If this.b_Handle Then
InvalidateRect(this.b_Handle,0,TRUE)
EndIf
End Sub
Sub Control.Repaint
If this.b_Handle Then
RedrawWindow(this.b_Handle,0,0,RDW_ERASE Or RDW_INVALIDATE Or RDW_FRAME Or RDW_ALLCHILDREN)
EndIf
End Sub
Sub Control.setFont(Face As String,ByVal size As Integer,ByVal bold As Integer,ByVal italic As Integer,ByVal underlin As Integer)
Dim lgFont AS LOGFONT
lgFont.lfFaceName = Face
lgFont.lfHeight = -MulDiv(size, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72)
lgFont.lfWeight = IIf(bold,800,400)
lgFont.lfItalic = IIf(italic,1,0)
lgFont.lfStrikeOut = 0
lgFont.lfUnderline = IIf(underlin,1,0)
If this.b_hFont Then
DeleteObject(this.b_hFont)
EndIf
this.b_hFont = (CreateFontIndirect(@lgFont))
SendMessage(this.Handle,WM_SETFONT,Cast(Uinteger, this.b_hFont),TRUE)
End Sub
' ###### Ende Basis #######
'---------------------------------------------------------------------------------------------------------
'Panel
'---------------------------------------------------------------------------------------------------------
Type FPanel Extends Control
public:
Declare Property TextAlign(ByVal value as Integer)
Declare Property TextAlign as Integer
Declare Property Border(ByVal value as Integer)
Declare Property Border As Integer
Declare Sub BKBmp( value as String)
Declare Sub Create(ByVal hParent As HWND,ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Declare Constructor
Declare Destructor
' Events
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)
onRbuttondown As Sub(ByVal x As Integer,ByVal y As Integer,ByVal flag As Integer)
onPaint As Sub(ByVal dc As HDC)
Declare Function CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Private:
As Integer b_TextAlign = 1
As Integer b_Border = 0
As HBITMAP b_Bmp = 0
End Type
Constructor FPanel
this.Handle = 0
this.ExStyle = WS_EX_CONTROLPARENT
this.Style = WS_CHILD Or WS_VISIBLE
End Constructor
Destructor FPanel ' OK
If this.b_Bmp Then
DeleteObject(this.b_Bmp)
this.b_Bmp = 0
EndIf
this.Handle = 0
End Destructor
Property FPanel.TextAlign As Integer
Return this.b_TextAlign
End Property
Property FPanel.TextAlign(value as Integer)
If this.Handle Then
Select Case value
Case 0 ' links einzeilig
b_TextAlign = 0
Case 1 ' mitte einzeilig
b_TextAlign = 1
Case 2 ' rechts einzeilig
b_TextAlign = 2
Case 3 ' links mehrzeilig
b_TextAlign = 3
Case 4 ' mitte mehrzeilig
b_TextAlign = 4
Case 5 ' rechts mehrzeilig
b_TextAlign = 5
End Select
EndIf
End Property
Property FPanel.Border As Integer
Return this.b_Border
End Property
Property FPanel.Border(value as Integer)
If this.Handle Then
Select Case value
Case 0 ' ohne default
b_Border = 0
Case 1 ' sunken
b_Border = 1
Case 2 ' raised
b_Border = 2
Case 3 ' rahmen
b_Border = 3
End Select
EndIf
End Property
Sub FPanel.BKBmp( value as String)
Dim As HINSTANCE hInst
Dim As ZString * 128 szRes
If this.Handle Then
hInst = GetModuleHandle(0)
szRes = value
If InStr(szRes,".") = 0 Then ' Wenn kein Punkt (.) enthalen ist, dann Resource
this.b_Bmp = LoadBitmap(hInst , cast( LPCSTR, @szRes ))
If this.b_Bmp = 0 Then
MessageBox( null, "Fehler - fBitmap ist nicht geladen", "Error", MB_ICONERROR )
EndIf
Else ' mit Punkt (.) dann Deteiname
this.b_Bmp = LoadImage(NULL,@szRes,IMAGE_Bitmap,0,0,LR_DEFAULTCOLOR Or LR_LOADFROMFILE )
If this.b_Bmp = 0 Then
MessageBox( null, "Fehler - fBitmap ist nicht geladen", "Error", MB_ICONERROR )
EndIf
End if
End If
End Sub
Function FPanel.CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Function = 0
Dim As HDC hDc,dc
Dim As RECT rc
Dim As HBRUSH hBr
Dim As UInteger drStyle
Dim As Integer lKeyDat = 0
Dim As BITMAP bm
Select case uMsg
Case WM_PAINT
dim pnt as PAINTSTRUCT
hDC = BeginPaint( hWnd, @pnt )
GetClientRect(hWnd,@rc)
If this.b_Bmp = 0 Then
'Hintergrund Color ------------------
SetBkColor(hDC,this.Color)
hBr = CreateSolidBrush(this.Color)
FillRect(hDC,@rc,hBr)
DeleteObject(hBr)
Else
'Hintergrund Bild ------------------
dc = CreateCompatibleDC(hDC)
SelectObject(dc,this.b_Bmp)
GetObject(this.b_Bmp,SizeOf(bm),@bm)
StretchBlt(hDC,rc.left,rc.top,rc.right,rc.bottom,dc,0,0,bm.bmWidth,bm.bmHeight,SRCCOPY)
DeleteDC(dc)
End If
'Rahmen ------------------------------
If this.b_Border = 1 Then
DrawEdge(hDC,@rc, EDGE_SUNKEN , BF_RECT )
ElseIf this.b_Border = 2 Then
DrawEdge(hDC,@rc, EDGE_RAISED , BF_RECT )
ElseIf this.b_Border = 3 Then
DrawEdge(hDC,@rc, EDGE_BUMP , BF_RECT )
End If
'Text --------------------------------
If Len(this.Caption) > 0 Then
rc.left = rc.left + 2
rc.Top = rc.Top + 2
rc.right = rc.right - 2
rc.bottom = rc.bottom - 2
SetBkMode(hDc, TRANSPARENT)
SetTextColor(hDC,this.TextColor)
DeleteObject(SelectObject(hDc,this.Font))
Select Case this.b_TextAlign
Case 0
drStyle = DT_SINGLELINE or DT_LEFT or DT_VCENTER
Case 1
drStyle = DT_SINGLELINE or DT_CENTER or DT_VCENTER
Case 2
drStyle = DT_SINGLELINE or DT_RIGHT or DT_VCENTER
Case 3
drStyle = DT_EDITCONTROL or DT_LEFT or DT_VCENTER Or DT_WORDBREAK
Case 4
drStyle = DT_EDITCONTROL or DT_CENTER or DT_VCENTER Or DT_WORDBREAK
Case 5
drStyle = DT_EDITCONTROL or DT_RIGHT or DT_VCENTER Or DT_WORDBREAK
End Select
DrawText(hDC,this.Caption, -1, @rc, drStyle )
End If
If this.onPaint Then
onPaint(hDc)
EndIf
EndPaint( hWnd, @pnt )
Function = 0
Exit Function
'-------------------------
Case WM_RBUTTONDOWN
If this.onRbuttondown Then
onRbuttondown(LOWORD(lParam),HIWORD(lParam),wParam)
End If
Function = 0
Exit Function
'-------------------------
Case WM_LBUTTONDOWN
If this.onLbuttondown Then
onLbuttondown(LOWORD(lParam),HIWORD(lParam),wParam)
End If
Function = 0
Exit Function
'-------------------------
Case WM_LBUTTONUP
If this.onLbuttonup Then
onLbuttonup(LOWORD(lParam),HIWORD(lParam),wParam)
End If
Function = 0
Exit Function
'-------------------------
Case WM_MOUSEMOVE
If this.onMousemove Then
onMousemove(LOWORD(lParam),HIWORD(lParam),wParam)
End If
Function = 0
Exit Function
'-------------------------
End Select
Function = DefWindowProc(hWnd,uMsg,wParam,lParam)
end Function
Sub FPanel.Create(ByVal hParent As HWND ,ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Dim As ZString * 32 szClass
Dim As HINSTANCE hInst
this.Parent = hParent
szClass = "FB_CONTROL"
hInst = GetModuleHandle(0)
this.Handle = CreateWindowEx( this.ExStyle , @szClass , "" , this.Style , x, y, w , h , _
this.Parent , NULL, hInst , NULL )
SetWindowLong(this.Handle ,GWL_USERDATA,CInt(@This)) ' Zeiger diese Instanz
If this.Handle Then
this.Left = x
this.Top = y
this.Width = w
this.Height = h
this.Caption = ""
Else
MessageBox(0,"Fehler - Create Panel","Fehler",MB_ICONERROR)
Exit Sub
End If
End Sub
'---------------------------------------------------------------------------------------------------------
'Button Pushbutton
'---------------------------------------------------------------------------------------------------------
Type FButton Extends Control
public:
Declare Sub Create(ByVal hParent As HWND, Capt As String,ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Declare Constructor
Declare Destructor
' Events
onClick As Sub()
Declare Function CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
End Type
Constructor FButton
this.Handle = 0
this.ExStyle = 0
this.Style = WS_CHILD Or WS_VISIBLE Or BS_PUSHBUTTON Or BS_OWNERDRAW Or WS_TABSTOP
End Constructor
Destructor FButton ' OK
this.Handle = 0
End Destructor
Function FButton.CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Function = 0
Select case uMsg
Case WM_ENABLE
this.Enabled = wParam
Exit Function
Case WM_SETFONT,WM_SETTEXT
If this.Handle Then
Function = SendMessage(this.Handle,uMsg,wParam,lParam)
End If
Exit Function
Case WM_SIZE
If this.Handle Then
MoveWindow(this.Handle,0,0,LOWORD(lParam),HiWord(lParam),TRUE)
End If
Exit Function
Case WM_COMMAND
If IsChild( hWnd, Cast(HANDLE, lParam)) Then
If this.onClick Then
onClick()
End If
Function = 0
Exit Function
EndIf
Case WM_DRAWITEM
Dim As LPDRAWITEMSTRUCT lpdis = Cast(Any Ptr, lParam)
Dim As HANDLE hCtrl = lpdis->hwndItem
If IsChild(hWnd,hCtrl) Then
Dim hBr As HBRUSH
SetBkColor(lpdis->hDC,this.Color)
hBr = CreateSolidBrush(this.Color)
FillRect(lpdis->hDC,@lpdis->rcItem,hBr)
DeleteObject(hBr)
if lpdis->itemState and ODS_SELECTED Then
DrawEdge(lpdis->hDC,@lpdis->rcItem, EDGE_SUNKEN ,BF_RECT)
Else
DrawEdge(lpdis->hDC,@lpdis->rcItem, EDGE_RAISED , BF_RECT )
End If
SetBkMode(lpdis->hDC,TRANSPARENT)
If this.Enabled = True Then
SetTextColor(lpdis->hDC,this.TextColor)
Else
SetTextColor(lpdis->hDC,&H808080)
End If
DrawText( lpdis->hDC,this.Caption, -1, @lpdis->rcItem, DT_SINGLELINE or DT_CENTER or DT_VCENTER )
'
'-------------------------
lpdis->rcItem.Left=lpdis->rcItem.Left + 3
lpdis->rcItem.Top = lpdis->rcItem.Top + 3
lpdis->rcItem.Right = lpdis->rcItem.Right - 3
lpdis->rcItem.Bottom=lpdis->rcItem.Bottom - 3
If lpdis->itemState and ODS_FOCUS Then
DrawFocusRect(lpdis->hDC,@lpdis->rcItem)
EndIf
Function = TRUE
Exit Function
End If
End Select
Function = DefWindowProc(hWnd,uMsg,wParam,lParam)
end Function
Sub FButton.Create(ByVal hParent As HWND, Capt As String,ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Dim As ZString * 32 szClass
Dim As HINSTANCE hInst
szClass = "FB_CONTROL"
hInst = GetModuleHandle(0)
this.CtHandle = CreateWindowEx( WS_EX_CONTROLPARENT , @szClass , "", WS_VISIBLE Or WS_CHILD , x, y, w , h , _
hParent , NULL, hInst , NULL )
SetWindowLong(this.CtHandle ,GWL_USERDATA,CInt(@This)) ' Zeiger diese Instanz
If this.CtHandle Then
this.Left = x
this.Top = y
this.Width = w
this.Height = h
this.Parent = hParent
Else
MessageBox(0,"Fehler - Create Button","Fehler",MB_ICONERROR)
Exit Sub
End If
this.Handle = CreateWindowEx( NULL , "BUTTON" , Capt, this.Style , 0, 0, w, h , this.CtHandle , NULL, hInst , NULL )
If this.Handle = 0 Then
MessageBox(0,"Fehler - Create Button","Fehler",MB_ICONERROR)
EndIf
this.Caption = Capt
End Sub
'---------------------------------------------------------------------------------------------------------
'Button Checkbox
'---------------------------------------------------------------------------------------------------------
Type FCheckbox Extends Control
public:
Declare Property Check As Integer
Declare Property Check(ByVal value As Integer)
Declare Sub Create(ByVal hParent As HWND, Capt As String,ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Declare Constructor
Declare Destructor
' Events
onClick As Sub()
Declare Function CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Private:
As Integer b_Check = 0
As HBRUSH b_Brush = 0
End Type
Constructor FCheckbox
this.Handle = 0
this.ExStyle = 0
this.b_Check = 0
this.Style = WS_CHILD Or WS_VISIBLE Or BS_AUTOCHECKBOX Or WS_TABSTOP
end Constructor
Destructor FCheckbox
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
this.Handle = 0
End Destructor
Property FCheckbox.Check As Integer
If this.Handle Then
this.b_Check = SendMessage(this.Handle,BM_GETCHECK,0,0)
Return this.b_Check
End If
End Property
Property FCheckbox.Check(ByVal value As Integer)
If this.Handle Then
SendMessage(this.Handle,BM_SETCHECK ,IIf(value,BST_CHECKED,BST_UNCHECKED) ,0)
this.b_Check = IIf(value,BST_CHECKED,BST_UNCHECKED)
EndIf
End Property
Function FCheckbox.CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Function = 0
Static As BOOL flEnable = TRUE
Select Case uMsg
Case WM_ENABLE
flEnable = wParam
Exit Function
Case WM_SETFONT,WM_SETTEXT
If this.Handle Then
Function = SendMessage(this.Handle,uMsg,wParam,lParam)
End If
Exit Function
Case WM_SIZE
If this.Handle Then
MoveWindow(this.Handle,0,0,LOWORD(lParam),HiWord(lParam),TRUE)
End If
Exit Function
Case WM_COMMAND
If IsChild( hWnd, Cast(HANDLE, lParam)) Then
If this.onClick Then
onClick()
End If
Function = 0
Exit Function
EndIf
Case WM_CTLCOLORSTATIC
If IsChild(hWnd,Cast(HANDLE, lParam)) Then
If flEnable Then
SetTextColor(Cast(HDC, wParam),this.TextColor)
Else
SetTextColor(Cast(HDC, wParam),&HA0A0A0)
End If
SetBkMode(Cast(HDC, wParam),TRANSPARENT)
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
this.b_Brush = CreateSolidBrush(this.Color)
Function = Cast(LRESULT,this.b_Brush)
End If
Exit Function
End Select
Function = DefWindowProc(hWnd,uMsg,wParam,lParam)
end Function
Sub FCheckbox.Create(ByVal hParent As HWND, Capt As String,ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Dim As ZString * 32 szClass
Dim As HINSTANCE hInst
szClass = "FB_CONTROL"
hInst = GetModuleHandle(0)
this.CtHandle = CreateWindowEx( WS_EX_CONTROLPARENT , @szClass , "", WS_VISIBLE Or WS_CHILD , x, y, w , h , _
hParent , NULL, hInst , NULL )
SetWindowLong(this.CtHandle ,GWL_USERDATA,CInt(@This)) ' Zeiger diese Instanz
If this.CtHandle Then
this.Left = x
this.Top = y
this.Width = w
this.Height = h
this.Parent = hParent
Else
MessageBox(0,"Fehler - Create Button","Fehler",MB_ICONERROR)
Exit Sub
End If
this.Handle = CreateWindowEx( NULL , "BUTTON" , Capt, this.Style , 0, 0, w, h , this.CtHandle , NULL, hInst , NULL )
If this.Handle = 0 Then
MessageBox(0,"Fehler - Create Button","Fehler",MB_ICONERROR)
EndIf
this.Caption = Capt
End Sub
'---------------------------------------------------------------------------------------------------------
'Button RadioButton
'---------------------------------------------------------------------------------------------------------
Type FRadioBtn Extends Control
public:
Declare Property Check As Integer
Declare Property Check(ByVal value As Integer)
Declare Property BtnLike(ByVal value As Integer)
Declare Property BtnLike As Integer
Declare Sub BmpBtn(bm As String)
Declare Sub Create(ByVal hParent As HWND, Capt As String,ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Declare Constructor
Declare Destructor
' Events
onClick As Sub()
Declare Function CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Private:
As HBITMAP b_BMP = 0
As HBRUSH b_Brush = 0
As Integer b_Check = 0
As Integer b_BtnLike = 0
End Type
Constructor FRadioBtn
this.Handle = 0
this.ExStyle = 0
this.b_Check = 0
this.Style = WS_CHILD Or WS_VISIBLE Or BS_RADIOBUTTON Or WS_TABSTOP
end Constructor
Destructor FRadioBtn
If this.b_BMP Then
DeleteObject(this.b_BMP)
EndIf
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
this.Handle = 0
End Destructor
Property FRadioBtn.BtnLike As Integer
Return this.b_BtnLike
End Property
Property FRadioBtn.BtnLike(ByVal value As Integer)
If this.Handle Then
If value = 0 Then
this.b_BtnLike = FALSE
this.Style = WS_CHILD Or WS_VISIBLE Or BS_RADIOBUTTON Or WS_TABSTOP
Else
this.b_BtnLike = TRUE
this.Style = WS_CHILD Or WS_VISIBLE Or BS_RADIOBUTTON Or WS_TABSTOP Or BS_PUSHLIKE
EndIf
SetWindowLong(this.Handle,GWL_STYLE,this.style)
Repaint
EndIf
End Property
Sub FRadioBtn.BmpBtn(bm As String)
Dim As HINSTANCE hInst
Dim As ZString * 128 szRes
Dim As BITMAP bm2
Dim As UInteger tStyle
If this.Handle Then
hInst = GetModuleHandle(0)
szRes = bm
If InStr(szRes,".") = 0 Then ' Wenn kein Punkt (.) enthalen ist, dann Resource
this.b_BMP = LoadBitmap(hInst , cast( LPCSTR, @szRes ))
If this.b_BMP = 0 Then
MessageBox( null, "Fehler - fBitmap ist nicht geladen", "Error", MB_ICONERROR )
Exit Sub
EndIf
Else ' mit Punkt (.) dann Deteiname
this.b_BMP = LoadImage(NULL,@szRes,IMAGE_Bitmap,0,0,LR_DEFAULTCOLOR Or LR_LOADFROMFILE )
If this.b_BMP = 0 Then
MessageBox( null, "Fehler - fBitmap ist nicht geladen", "Error", MB_ICONERROR )
Exit Sub
EndIf
End If
'GetObject(this.b_BMP,SizeOf(bm2),@bm2)
'this.Width = bm2.bmWidth +2
'this.Height = bm2.bmHeight +2
tStyle = this.Style Or BS_BITMAP
this.Style = tStyle
SetWindowLong(this.Handle,GWL_STYLE,this.style)
SendMessage(this.Handle,BM_SETIMAGE,IMAGE_BITMAP,Cast(LPARAM,this.b_BMP))
Repaint
SendMessage(this.Handle,BM_SETIMAGE,IMAGE_BITMAP,Cast(LPARAM,this.b_BMP))
EndIf
End Sub
Property FRadioBtn.Check As Integer
If this.Handle Then
this.b_Check = SendMessage(this.Handle,BM_GETCHECK,0,0)
Return this.b_Check
End If
End Property
Property FRadioBtn.Check(ByVal value As Integer)
If this.Handle Then
SendMessage(this.Handle,BM_SETCHECK ,IIf(value,BST_CHECKED,BST_UNCHECKED) ,0)
this.b_Check = IIf(value,BST_CHECKED,BST_UNCHECKED)
EndIf
End Property
Function FRadioBtn.CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Function = 0
Static As BOOL flEnable = TRUE
Select Case uMsg
Case WM_ENABLE
flEnable = wParam
Exit Function
Case WM_SETFONT,WM_SETTEXT
If this.Handle Then
Function = SendMessage(this.Handle,uMsg,wParam,lParam)
End If
Exit Function
Case WM_SIZE
If this.Handle Then
MoveWindow(this.Handle,0,0,LOWORD(lParam),HiWord(lParam),TRUE)
End If
Exit Function
Case WM_COMMAND
If IsChild( hWnd, Cast(HANDLE, lParam)) Then
If this.onClick Then
onClick()
End If
Function = 0
Exit Function
EndIf
Case WM_CTLCOLORSTATIC
If IsChild(hWnd,Cast(HANDLE, lParam)) Then
If flEnable Then
SetTextColor(Cast(HDC, wParam),this.TextColor)
Else
SetTextColor(Cast(HDC, wParam),&HA0A0A0)
End If
SetBkMode(Cast(HDC, wParam),TRANSPARENT)
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
this.b_Brush = CreateSolidBrush(this.Color)
Function = Cast(LRESULT,this.b_Brush)
End If
Exit Function
End Select
Function = DefWindowProc(hWnd,uMsg,wParam,lParam)
end Function
Sub FRadioBtn.Create(ByVal hParent As HWND, Capt As String,ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Dim As ZString * 32 szClass
Dim As HINSTANCE hInst
szClass = "FB_CONTROL"
hInst = GetModuleHandle(0)
this.CtHandle = CreateWindowEx( WS_EX_CONTROLPARENT , @szClass , "", WS_VISIBLE Or WS_CHILD , x, y, w , h , _
hParent , NULL, hInst , NULL )
SetWindowLong(this.CtHandle ,GWL_USERDATA,CInt(@This)) ' Zeiger diese Instanz
If this.CtHandle Then
this.Left = x
this.Top = y
this.Width = w
this.Height = h
this.Parent = hParent
Else
MessageBox(0,"Fehler - Create Button","Fehler",MB_ICONERROR)
Exit Sub
End If
this.Handle = CreateWindowEx( NULL , "BUTTON" , Capt, this.Style , 0, 0, w, h , this.CtHandle , NULL, hInst , NULL )
If this.Handle = 0 Then
MessageBox(0,"Fehler - Create Button","Fehler",MB_ICONERROR)
EndIf
this.Caption = Capt
End Sub
'---------------------------------------------------------------------------------------------------------
'Static Controls - Bitmap
'---------------------------------------------------------------------------------------------------------
Type FBmpLabel Extends Control
public:
Declare Property Border As Integer
Declare Property Border(ByVal value As Integer)
Declare Sub Create(ByVal hParent As HWND, bmp As String,ByVal x As Integer,ByVal y As Integer)
Declare Constructor
Declare Destructor
Private:
As HBITMAP b_BMP = 0
As Integer b_Border = 0
End Type
Constructor FBmpLabel
this.Handle = 0
this.ExStyle = WS_EX_STATICEDGE
this.Style = WS_CHILD Or WS_VISIBLE Or SS_BITMAP
End Constructor
Destructor FBmpLabel
If this.b_BMP Then
DeleteObject(this.b_BMP)
EndIf
this.Handle = 0
End Destructor
Property FBmpLabel.Border As Integer
Return this.b_Border
End Property
Property FBmpLabel.Border(ByVal value As Integer)
If this.Handle Then
Select Case value
Case 0
this.b_Border = 0
this.Style = WS_CHILD Or WS_VISIBLE Or SS_BITMAP ' ohne
this.ExStyle = 0
Case 1
this.b_Border = 1
this.Style = WS_CHILD Or WS_VISIBLE Or SS_BITMAP Or WS_BORDER ' Rahmen
this.ExStyle = 0
Case 2
this.b_Border = 2
this.Style = WS_CHILD Or WS_VISIBLE Or SS_BITMAP Or SS_SUNKEN ' Sunken
this.ExStyle = WS_EX_STATICEDGE
End Select
SetWindowLong(this.handle,GWL_STYLE,this.style)
SetWindowLong(this.handle,GWL_EXSTYLE,this.Exstyle)
Repaint
EndIf
End Property
Sub FBmpLabel.Create(ByVal hParent As HWND, Bmp As String,ByVal x As Integer,ByVal y As Integer)
Dim As HINSTANCE hInst
Dim As ZString * 128 szRes
Dim As BITMAP bm
hInst = GetModuleHandle(0)
szRes = Bmp
If InStr(szRes,".") = 0 Then ' Wenn kein Punkt (.) enthalen ist, dann Resource
this.b_BMP = LoadBitmap(hInst , cast( LPCSTR, @szRes ))
If this.b_BMP = 0 Then
MessageBox( null, "Fehler - fBitmap ist nicht geladen", "Error", MB_ICONERROR )
Exit sub
EndIf
Else ' mit Punkt (.) dann Deteiname
this.b_BMP = LoadImage(NULL,@szRes,IMAGE_Bitmap,0,0,LR_DEFAULTCOLOR Or LR_LOADFROMFILE )
If this.b_BMP = 0 Then
MessageBox( null, "Fehler - fBitmap ist nicht geladen", "Error", MB_ICONERROR )
Exit sub
EndIf
End If
GetObject(this.b_BMP,SizeOf(bm),@bm)
this.Width = bm.bmWidth
this.Height = bm.bmHeight
this.Handle = CreateWindowEx( this.Exstyle , "STATIC" , "", this.style , x, y, this.Width, this.Height , _ '
hParent , NULL, hInst , NULL )
If this.Handle Then
SendMessage(this.Handle,STM_SETIMAGE,IMAGE_BITMAP,Cast(LPARAM,this.b_BMP))
this.Left = x
this.Top = y
this.Parent = hParent
Else
MessageBox( null, "Fehler - Bitmap ist nicht geladen", "Error", MB_ICONERROR )
End If
End Sub
'---------------------------------------------------------------------------------------------------------
' Listbox
'---------------------------------------------------------------------------------------------------------
Type FListbox Extends Control
public:
Declare Property GetSelString As String
Declare Property GetSelItem As Integer
Declare Property GetItemCount As Integer
Declare Property Border(ByVal value As Integer)
Declare Sub Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Declare Sub SelItem(ByVal value As Integer)
Declare Sub AddString(value As String)
Declare Sub Clear
Declare Sub DelString(ByVal item As Integer)
Declare Constructor
Declare Destructor
DECLARE FUNCTION CtrlMsgFunc(hWnd AS HWND,uMsg AS UINT,wParam AS wParam,lParam AS lParam) AS LRESULT
' Events
onDblClick As SUB( ByVal item As UInteger,szItem As ZString)
onSelChange As Sub(ByVal item As UInteger,szItem As ZString)
Private:
As HBRUSH b_Brush = 0
End Type
Constructor FListbox
this.Handle = 0
this.ExStyle = WS_EX_CLIENTEDGE
this.Style = WS_CHILD Or WS_VISIBLE Or LBS_HASSTRINGS Or WS_TABSTOP Or LBS_NOINTEGRALHEIGHT Or LBS_NOTIFY Or WS_VSCROLL
end Constructor
Destructor FListbox
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
this.Handle = 0
End Destructor
Property FListbox.GetSelString As String
If this.Handle Then
Dim item As Integer
Dim szItem As ZString * MAX_PATH
item = SendMessage(this.Handle,LB_GETCURSEL,0,0)
If item <> LB_ERR Then
SendMessage(this.Handle,LB_GETTEXT,item,CInt(@szItem))
Return szItem
Else
szItem = ""
Return szItem
EndIf
End If
End Property
Property FListbox.GetSelItem As Integer
If this.Handle Then
return SendMessage(this.Handle,LB_GETCURSEL,0,0)
End If
End Property
Property FListbox.GetItemCount As Integer
If this.Handle Then
return SendMessage(this.Handle,LB_GETCOUNT,0,0)
End If
End Property
Property FListbox.Border(ByVal value As Integer)
If this.Handle Then
Select Case value
Case 0 ' Ohne
this.Style = WS_CHILD Or WS_VISIBLE Or LBS_HASSTRINGS Or WS_TABSTOP Or LBS_NOINTEGRALHEIGHT Or LBS_NOTIFY Or WS_VSCROLL
this.ExStyle = 0
Case 1 ' Sunken
this.Style = WS_CHILD Or WS_VISIBLE Or LBS_HASSTRINGS Or WS_TABSTOP Or LBS_NOINTEGRALHEIGHT Or LBS_NOTIFY Or WS_VSCROLL
this.ExStyle = WS_EX_CLIENTEDGE
Case 2 ' Border
this.Style = WS_CHILD Or WS_VISIBLE Or LBS_HASSTRINGS Or WS_TABSTOP Or LBS_NOINTEGRALHEIGHT Or LBS_NOTIFY Or WS_VSCROLL Or WS_BORDER
this.ExStyle = 0
End Select
SetWindowLong(this.Handle,GWL_STYLE,this.Style)
SetWindowLong(this.Handle,GWL_EXSTYLE,this.ExStyle)
SetWindowPos(this.Handle,0,0,0,this.Width,this.Height,SWP_DRAWFRAME Or SWP_FRAMECHANGED)
EndIf
End Property
Sub FListbox.AddString(value As String)
If this.Handle Then
Dim sItem As ZString * 128
sItem = value
SendMessage(this.Handle,LB_ADDSTRING,0,CInt(@sItem))
EndIf
End Sub
Sub FListbox.SelItem(ByVal value As Integer)
If this.Handle Then
SendMessage(this.Handle,LB_SETCURSEL ,value, 0 )
SetFocus(this.Handle)
EndIf
End Sub
Sub FListbox.Clear
If this.Handle Then
SendMessage(this.Handle, LB_RESETCONTENT ,0,0)
EndIf
End Sub
Sub FListbox.DelString(ByVal item As Integer)
If this.Handle Then
SendMessage(this.Handle, LB_DELETESTRING ,item,0)
EndIf
End Sub
Function FListbox.CtrlMsgFunc(hWnd AS HWND,uMsg AS UINT,wParam AS wParam,lParam AS lParam) AS LRESULT
Dim As UInteger item
Dim szItem As ZString * MAX_PATH
Select case uMsg
CASE WM_ENABLE
this.Enabled = wParam
EXIT FUNCTION
Case WM_SETFONT,WM_SETTEXT
IF this.Handle THEN
FUNCTION = SendMessage(this.Handle,uMsg,wParam,lParam)
END IF
EXIT FUNCTION
Case WM_SIZE
IF this.Handle THEN
MoveWindow(this.Handle,0,0,LOWORD(lParam),HiWord(lParam),TRUE)
END IF
EXIT FUNCTION
Case WM_CTLCOLORLISTBOX
SetBkColor(Cast(HDC, wParam),this.Color)
SetTextColor(Cast(HDC, wParam),this.TextColor)
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
this.b_Brush = CreateSolidBrush(this.Color)
Function = Cast(LRESULT,this.b_Brush )
Exit Function
Case WM_COMMAND
If HiWord(wParam) = LBN_DBLCLK Then
If this.onDblClick Then
item = SendMessage(this.Handle,LB_GETCURSEL,0,0)
If item <> LB_ERR Then
SendMessage(this.Handle,LB_GETTEXT,item,CInt(@szItem))
EndIf
onDblClick(item,szItem)
End If
SetFocus(this.Handle)
Function = 0
Exit Function
End If
If HiWord(wParam) = LBN_SELCHANGE Then
If this.onSelChange Then
item = SendMessage(this.Handle,LB_GETCURSEL,0,0)
If item <> LB_ERR Then
SendMessage(this.Handle,LB_GETTEXT, item,CInt(@szItem))
EndIf
onSelChange(item,szItem)
EndIf
Function = 0
Exit Function
End If
End Select
FUNCTION = DefWindowProc(hWnd,uMsg,wParam,lParam)
end Function
Sub FListbox.Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Dim AS ZString * 32 szClass
DIM AS HINSTANCE hInst
szClass = "FB_CONTROL"
hInst = GetModuleHandle(0)
this.CtHandle = CreateWindowEx( WS_EX_CONTROLPARENT , @szClass , "", WS_VISIBLE OR WS_CHILD , x, y, w , h , _
hParent , NULL, hInst , NULL )
SetWindowLong(this.CtHandle ,GWL_USERDATA,CINT(@This)) ' Zeiger diese Instanz
IF this.CtHandle THEN
this.Left = x
this.Top = y
this.Width = w
this.Height = h
this.Parent = hParent
ELSE
MessageBox(0,"Fehler - Create LISTBOX","Fehler",MB_ICONERROR)
EXIT SUB
END IF
this.Handle = CreateWindowEx( this.ExStyle ,"LISTBOX" ,NULL, this.Style , 0, 0, w, h , this.CtHandle , NULL, hInst , NULL )
IF this.Handle = 0 THEN
MessageBox(0,"Fehler - Create LISTBOX","Fehler",MB_ICONERROR)
EndIf
End Sub
'---------------------------------------------------------------------------------------------------------
' Combobox
'---------------------------------------------------------------------------------------------------------
Type FComboBox Extends Control
public:
Declare Property GetSelString As String
Declare Property GetSelItem As Integer
Declare Property GetItemCount As Integer
DECLARE FUNCTION CtrlMsgFunc(hWnd AS HWND,uMsg AS UINT,wParam AS wParam,lParam AS lParam) AS LRESULT
Declare Sub Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Declare Sub SelItem(ByVal value As Integer)
Declare Sub SelStrItem( value As String)
Declare Sub AddString(value As String)
Declare Sub Clear
Declare Sub DelString(ByVal item As Integer)
Declare Constructor
Declare Destructor
' Events
onSelChange As Sub(ByVal item As UInteger, szItem As ZString)
Private:
As HWND b_Parent = 0
As HBRUSH b_Brush = 0
End Type
Constructor FComboBox
this.Handle = 0
this.ExStyle = WS_EX_CLIENTEDGE
this.Style = WS_CHILD Or WS_VISIBLE Or CBS_SORT Or WS_TABSTOP Or CBS_DROPDOWNLIST Or CBS_NOINTEGRALHEIGHT Or WS_VSCROLL
end Constructor
Destructor FComboBox
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
this.Handle = 0
end Destructor
Property FComboBox.GetSelString As String
If this.Handle Then
Dim item As Integer
Dim szItem As ZString * MAX_PATH
item = SendMessage(this.Handle,CB_GETCURSEL,0,0)
If item <> LB_ERR Then
SendMessage(this.Handle,CB_GETLBTEXT,item,CInt(@szItem))
Return szItem
Else
szItem = ""
Return szItem
EndIf
End If
End Property
Property FComboBox.GetSelItem As Integer
If this.Handle Then
return SendMessage(this.Handle,CB_GETCURSEL,0,0)
End If
End Property
Property FComboBox.GetItemCount As Integer
If this.Handle Then
return SendMessage(this.Handle,CB_GETCOUNT,0,0)
End If
End Property
Sub FComboBox.AddString(value As String)
If this.Handle Then
Dim sItem As ZString * 128
sItem = value
SendMessage(this.Handle,CB_ADDSTRING,0,CInt(@sItem))
SendMessage(this.Handle,CB_SETCURSEL,0,0)
EndIf
End Sub
Sub FComboBox.SelItem(ByVal value As Integer)
If this.Handle Then
SendMessage(this.Handle,CB_SETCURSEL ,value, 0 )
SetFocus(this.Handle)
EndIf
End Sub
Sub FComboBox.Clear
If this.Handle Then
SendMessage(this.Handle, CB_RESETCONTENT ,0,0)
EndIf
End Sub
Sub FComboBox.DelString(ByVal item As Integer)
If this.Handle Then
SendMessage(this.Handle, CB_DELETESTRING ,item,0)
EndIf
End Sub
Sub FComboBox.SelStrItem( value As String)
Dim szFind As ZString * 32
Dim As Integer retVal
szFind = value
If this.Handle Then
retVal = SendMessage(this.Handle, CB_FINDSTRING ,-1,Cast(WPARAM, @szFind))
If retVal <> CB_ERR Then
SendMessage(this.Handle,CB_SETCURSEL ,retVal, 0 )
EndIf
EndIf
End Sub
Function FComboBox.CtrlMsgFunc(hWnd AS HWND,uMsg AS UINT,wParam AS wParam,lParam AS lParam) AS LRESULT
Dim As UInteger item
Dim szItem As ZString * MAX_PATH
Select case uMsg
CASE WM_ENABLE
this.Enabled = wParam
EXIT FUNCTION
Case WM_SETFONT,WM_SETTEXT
IF this.Handle THEN
FUNCTION = SendMessage(this.Handle,uMsg,wParam,lParam)
END IF
EXIT FUNCTION
Case WM_SIZE
IF this.Handle THEN
MoveWindow(this.Handle,0,0,LOWORD(lParam),HiWord(lParam),TRUE)
END IF
EXIT Function
Case WM_ERASEBKGND
Dim As RECT rc
GetClientRect(hWnd,@rc)
FillRect(Cast(HDC,wParam),@rc,GetStockObject(NULL_BRUSH))
Function = TRUE
Exit Function
Case WM_CTLCOLOREDIT
SetBkColor(Cast(HDC, wParam),this.Color)
SetTextColor(Cast(HDC, wParam),this.TextColor)
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
this.b_Brush = CreateSolidBrush(this.Color)
Function = Cast(LRESULT,this.b_Brush )
Exit Function
Case WM_CTLCOLORLISTBOX
SetBkColor(Cast(HDC, wParam),this.Color)
SetTextColor(Cast(HDC, wParam),this.TextColor)
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
this.b_Brush = CreateSolidBrush(this.Color)
Function = Cast(LRESULT,this.b_Brush )
Exit Function
Case WM_COMMAND
If HiWord(wParam) = CBN_SELCHANGE Then
If this.onSelChange Then
item = SendMessage(this.Handle,CB_GETCURSEL,0,0)
If item <> LB_ERR Then
SendMessage(this.Handle,CB_GETLBTEXT,item,CInt(@szItem))
EndIf
onSelChange(item,szItem)
SetFocus(this.Handle)
EndIf
Function = 0
Exit Function
End If
End Select
function = DefWindowProc( hWnd, uMsg, wParam, lParam)
end Function
Sub FComboBox.Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Dim AS ZString * 32 szClass
DIM AS HINSTANCE hInst
szClass = "FB_CONTROL"
hInst = GetModuleHandle(0)
this.CtHandle = CreateWindowEx( WS_EX_CONTROLPARENT , @szClass , "", WS_VISIBLE OR WS_CHILD , x, y, w , h , _
hParent , NULL, hInst , NULL )
SetWindowLong(this.CtHandle ,GWL_USERDATA,CINT(@This)) ' Zeiger diese Instanz
IF this.CtHandle THEN
this.Left = x
this.Top = y
this.Width = w
this.Height = h
this.Parent = hParent
ELSE
MessageBox(0,"Fehler - Create COMBOBOX","Fehler",MB_ICONERROR)
EXIT SUB
END IF
this.Handle = CreateWindowEx( this.ExStyle ,"COMBOBOX" ,NULL, this.Style , 0, 0, w, h , this.CtHandle , NULL, hInst , NULL )
IF this.Handle = 0 THEN
MessageBox(0,"Fehler - Create COMBOBOX","Fehler",MB_ICONERROR)
EndIf
End Sub
'---------------------------------------------------------------------------------------------------------
' Edit
'---------------------------------------------------------------------------------------------------------
Type FEdit Extends Control
public:
Declare Property Border(ByVal value As Integer)
Declare Property TextLen As Integer
Declare Property Number(ByVal value As Integer)
Declare Property Password(ByVal value As Integer)
Declare Property Text As String
Declare Property Text(sText As String )
Declare Constructor
Declare Destructor
Declare Sub Clear
Declare Sub Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer)
DECLARE FUNCTION CtrlMsgFunc(hWnd AS HWND,uMsg AS UINT,wParam AS wParam,lParam AS lParam) AS LRESULT
' Events
onChange As SUB()
onUpdate As Sub()
OnKeyDown As Sub(nKey AS Integer,lKeyStatus As Integer)
OnSetFocus As Sub(ByVal hWnd As HWND)
Private:
DECLARE static FUNCTION EditSubClassFunc(hWnd AS HWND,uMsg AS UINT,wParam AS wParam,lParam AS lParam) AS LRESULT
As String b_Text = ""
As HBRUSH b_Brush = 0
As UInteger b_oldProc = 0
End Type
Constructor FEdit
this.Handle = 0
this.Handle = 0
this.Color = &HFFFFFF
this.ExStyle = WS_EX_CLIENTEDGE
this.Style = WS_CHILD Or WS_TABSTOP Or ES_AUTOHSCROLL
end Constructor
Destructor FEdit
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
If this.Handle Then
SetWindowLong(this.Handle, GWL_WNDPROC, this.b_oldProc)
this.Handle = 0
End If
this.Handle = 0
this.Handle = 0
end Destructor
Property FEdit.Password(ByVal value As Integer)
If this.Handle Then
If value = 0 Then
SendMessage(this.Handle,EM_SETPASSWORDCHAR,0,0)
Else
SendMessage(this.Handle,EM_SETPASSWORDCHAR,Cast(WPARAM,Asc("*")) ,0)
EndIf
Repaint
EndIf
End Property
Property FEdit.Border(ByVal Value As Integer)
If this.Handle Then
Select Case value
Case 0 ' Ohne
this.Style = WS_CHILD Or WS_TABSTOP Or ES_AUTOHSCROLL Or WS_VISIBLE
this.ExStyle = 0
Case 1 ' Sunken
this.Style = WS_CHILD Or WS_TABSTOP Or ES_AUTOHSCROLL Or WS_VISIBLE
this.ExStyle = WS_EX_CLIENTEDGE
Case 2 ' Border
this.Style = WS_CHILD Or WS_TABSTOP Or ES_AUTOHSCROLL or WS_BORDER Or WS_VISIBLE
this.ExStyle = 0
End Select
SetWindowLong(this.Handle,GWL_STYLE,this.Style)
SetWindowLong(this.Handle,GWL_EXSTYLE,this.ExStyle)
SetWindowPos(this.Handle,0,0,0,this.Width,this.Height,SWP_DRAWFRAME Or SWP_FRAMECHANGED)
EndIf
End Property
Property FEdit.Number(ByVal value As Integer)
If this.Handle Then
Dim Styl As UInteger
Styl = GetWindowLong(this.Handle,GWL_STYLE)
If value = 0 Then
this.Style = Styl And (Not ES_NUMBER)
Else
SendMessage(this.Handle, WM_CLEAR, 0, 0)
this.Style = Styl or ES_NUMBER
EndIf
SetWindowLong(this.Handle, GWL_STYLE, this.Style)
EndIf
End Property
Property FEdit.TextLen As Integer
If this.Handle Then
Return GetWindowTextLength(this.Handle)
EndIf
End Property
Property FEdit.Text As String
If this.Handle Then
Dim As Integer maxCount,i
maxCount = GetWindowTextLength(this.Handle)
this.b_Text = String(maxCount+2,Chr(0))
i = GetWindowText(this.Handle , StrPtr(this.b_Text) , maxCount+1 )
Return this.b_Text
EndIf
End Property
Property FEdit.Text(sText As String )
If this.Handle Then
this.b_Text = sText
SetWindowText(this.Handle ,sText)
EndIf
End Property
Sub FEdit.Clear
If this.Handle Then
SendMessage(this.Handle, WM_CLEAR, 0, 0)
EndIf
End Sub
Function FEdit.EditSubClassFunc(hWnd AS HWND,uMsg AS UINT,wParam AS wParam,lParam AS lParam) AS LRESULT
Function = 0
Dim As Integer lKeyDat = 0
Dim as FEdit ptr Edit = cast(FEdit Ptr,GetWindowLong(hWnd,GWL_USERDATA)) ' Zeiger auf diese Klasse
If Edit = 0 Then
function = DefWindowProc( hWnd, uMsg, wParam, lParam)
Exit Function
EndIf
Select case uMsg
Case WM_SETFOCUS
If Edit->OnSetFocus Then Edit->OnSetFocus(hWnd)
function = CallWindowProc( Cast(Any Ptr,Edit->b_oldProc), hWnd, uMsg, wParam, lParam)
Exit Function
Case WM_GETDLGCODE
Function = DLGC_WANTALLKEYS
Exit Function
Case WM_KEYDOWN
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
If Edit->OnKeyDown Then Edit->OnKeyDown(wParam,lKeyDat)
SetFocus(hWnd)
function = CallWindowProc( Cast(Any Ptr,Edit->b_oldProc), hWnd, uMsg, wParam, lParam)
Exit Function
End Select
function = CallWindowProc( Cast(Any Ptr,Edit->b_oldProc), hWnd, uMsg, wParam, lParam)
End Function
Function FEdit.CtrlMsgFunc(hWnd AS HWND,uMsg AS UINT,wParam AS wParam,lParam AS lParam) AS LRESULT
SELECT CASE uMsg
CASE WM_ENABLE
this.Enabled = wParam
EXIT FUNCTION
CASE WM_SETFONT,WM_SETTEXT
IF this.Handle THEN
FUNCTION = SendMessage(this.Handle,uMsg,wParam,lParam)
END IF
EXIT FUNCTION
CASE WM_SIZE
IF this.Handle THEN
MoveWindow(this.Handle,0,0,LOWORD(lParam),HiWord(lParam),TRUE)
END IF
EXIT FUNCTION
Case WM_CTLCOLOREDIT
SetBkColor(Cast(HDC, wParam),this.Color)
SetTextColor(Cast(HDC, wParam),this.TextColor )
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
this.b_Brush = CreateSolidBrush(this.Color)
Function = Cast(LRESULT,this.b_Brush )
Exit Function
Case WM_COMMAND
If HiWord(wParam) = EN_CHANGE Then
If this.onChange Then onChange()
Function = 0
Exit Function
End If
If HiWord(wParam) = EN_UPDATE Then
If this.onUpdate Then onUpdate()
Function = 0
Exit Function
End If
End Select
function = DefWindowProc( hWnd, uMsg, wParam, lParam)
end Function
Sub FEdit.Create(ByVal hParent As HWND,ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
DIM AS ZString * 32 szClass
DIM AS HINSTANCE hInst
szClass = "FB_CONTROL"
hInst = GetModuleHandle(0)
this.CtHandle = CreateWindowEx( WS_EX_CONTROLPARENT , @szClass , "", WS_VISIBLE OR WS_CHILD , x, y, w , h , _
hParent , NULL, hInst , NULL )
SetWindowLong(this.CtHandle ,GWL_USERDATA,CINT(@This)) ' Zeiger diese Instanz
IF this.CtHandle THEN
this.Left = x
this.Top = y
this.Width = w
this.Height = h
this.Parent = hParent
ELSE
MessageBox(0,"Fehler - Create EDIT","Fehler",MB_ICONERROR)
EXIT SUB
END IF
this.Handle = CreateWindowEx( this.ExStyle ,"EDIT" , "" , this.Style , 0, 0, w, h , this.CtHandle , NULL, hInst , NULL )
IF this.Handle = 0 THEN
MessageBox(0,"Fehler - Create EDIT","Fehler",MB_ICONERROR)
Exit Sub
EndIf
this.b_oldProc = SetWindowLong( this.Handle, GWL_WNDPROC, CInt(@FEdit.EditSubClassFunc))
SetWindowLong(this.Handle ,GWL_USERDATA,CINT(@This)) ' Zeiger diese Instanz
ShowWindow(this.Handle,SW_SHOW)
End Sub
'------------------------------------------------------------------------------------------
' Font erstellen-ändert - In RichEdit
'------------------------------------------------------------------------------------------
Type FFont Extends Object
Public:
Declare Property FaceName() As String
Declare Property FaceName( face As String )
Declare Property Size( ByVal x As Integer )
Declare Property Size() As Integer
Declare Property Bold( ByVal x As Integer )
Declare Property Bold() As Integer
Declare Property Italic( ByVal x As Integer )
Declare Property Italic() As Integer
Declare Property Underline( ByVal x As Integer )
Declare Property Underline() As Integer
Declare Property StrikeOut( ByVal x As Integer )
Declare Property StrikeOut() As Integer
Declare Property FontHandle() As HFONT
Declare Constructor
Declare DESTRUCTOR
Private:
f_FaceName As ZString * 32
f_Size As Integer
f_Bold As Integer
f_Italic As Integer
f_StrikeOut As Integer
f_Underline As Integer
f_Handle As HFONT
End Type
Constructor FFont
this.f_Handle = GetStockObject(SYSTEM_FONT)
this.f_FaceName = "System"
this.f_Size = 10
this.f_Bold = 0
this.f_Italic = 0
this.f_StrikeOut = 0
this.f_Underline = 0
End Constructor
Destructor FFont ' OK
DeleteObject(this.f_Handle)
End Destructor
Property FFont.FontHandle() As HFONT
Dim lgFont AS LOGFONT
lgFont.lfFaceName = this.f_FaceName
lgFont.lfHeight = -MulDiv(this.f_Size, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72)
lgFont.lfWeight = IIf(this.f_Bold,800,400)
lgFont.lfItalic = IIf(this.f_Italic,1,0)
lgFont.lfStrikeOut = IIf(this.f_StrikeOut,1,0)
lgFont.lfUnderline = IIf(this.f_Underline,1,0)
If this.f_Handle Then
DeleteObject(this.f_Handle)
EndIf
this.f_Handle = (CreateFontIndirect(@lgFont))
Return this.f_Handle
End Property
Property FFont.FaceName As String
Dim s As String
s =this.f_FaceName
Return s
End Property
Property FFont.FaceName( face As String )
this.f_FaceName = face
End Property
Property FFont.Size( ByVal x As Integer )
this.f_Size = x
End Property
Property FFont.Size As Integer
Return this.f_Size
End Property
Property FFont.Bold( ByVal x As Integer )
this.f_Bold = x
End Property
Property FFont.Bold As Integer
Return this.f_Bold
End Property
Property FFont.Italic( ByVal x As Integer )
this.f_Italic = x
End Property
Property FFont.Italic As Integer
Return this.f_Italic
End Property
Property FFont.Underline( ByVal x As Integer )
this.f_Underline = x
End Property
Property FFont.Underline As Integer
Return this.f_Underline
End Property
Property FFont.StrikeOut( ByVal x As Integer )
this.f_StrikeOut = x
End Property
Property FFont.StrikeOut As Integer
Return this.f_StrikeOut
End Property
'---------------------------------------------------------------------------------------------------------
' RichEdit
'---------------------------------------------------------------------------------------------------------
Type FRichEdit Extends Control
public:
Declare Property PlainText(ByVal value As Integer)
Declare Property PlainText As Integer
Declare Property Paraleft(ByVal value As Integer)
Declare Property Paraleft As Integer
Declare Property Pararight(ByVal value As Integer)
Declare Property Pararight As Integer
Declare Property Paracenter(ByVal value As Integer)
Declare Property Paracenter As Integer
Declare Property Modifid As Integer
Declare Property SelText As String
Declare Property SelStart As Integer
Declare Property SelLen As Integer
Declare Property BKColor(ByVal value As UInteger)
Declare Property BKColor As UInteger
Declare Property ReadOnly As Integer
Declare Property ReadOnly(ByVal value As Integer)
Declare Property LMargin(ByVal value As Integer)
Declare Property LMargin As Integer
Declare Property AutoHScroll(ByVal value As Integer)
Declare Property AutoVScroll(ByVal value As Integer)
Declare Property ScrollBars(ByVal value As Integer)
Declare Property Border(ByVal value As Integer)
Declare Property TextLen As Integer
Declare Property Text As String
Declare Property Text(sText As String )
Declare Constructor
Declare Destructor
Declare Sub Clear
Declare Sub GlobalFontStyle()
Declare Sub SelFontStyle()
Declare Sub GetFontStyle()
Declare Sub SelParaStyle()
Declare Sub GetParaStyle()
Declare Sub SaveFile(filename As String)
Declare Sub LoadFile(filename As String)
Declare Sub Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer)
DECLARE FUNCTION CtrlMsgFunc(hWnd AS HWND,uMsg AS UINT,wParam AS wParam,lParam AS lParam) AS LRESULT
As FFont font
' Events
onChange As SUB()
onSelChange As SUB()
OnKeyUp As Sub(nKey AS Integer,lKeyStatus As Integer)
OnKeyDown As Sub(nKey AS Integer,lKeyStatus As Integer)
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)
onRbuttondown As Sub(ByVal x As Integer,ByVal y As Integer,ByVal flag As Integer)
Private:
DECLARE static FUNCTION EditSubClassFunc(hWnd AS HWND,uMsg AS UINT,wParam AS wParam,lParam AS lParam) AS LRESULT
DECLARE static Function DatenIn(BYVAL dwCookie As UInteger ,BYVAL lpBuff AS BYTE PTR, BYVAL cb AS INTEGER, BYVAL pcb AS INTEGER PTR) AS UInteger
DECLARE static Function DatenOut(BYVAL dwCookie AS UInteger,BYVAL lpBuff AS BYTE PTR, BYVAL cb AS INTEGER, BYVAL pcb AS INTEGER PTR) AS UInteger
As String b_Text = ""
As HBRUSH b_Brush = 0
As UInteger b_oldProc = 0
As HANDLE b_RichLib = 0
As Integer b_ReadOnly = 0
As Integer b_lmargin = 0
As Integer b_Scroll = 0
As UInteger b_bkColor = &HFFFFFF
As Integer b_Modifid = 0
As Integer b_paraleft = 1
As Integer b_pararight = 0
As Integer b_paracenter= 0
As Integer b_plaintext = 0
End Type
Constructor FRichEdit
this.b_RichLib = LoadLibrary("RICHED32.DLL")
this.Handle = 0
this.Handle = 0
this.Color = &HFFFFFF
this.ExStyle = WS_EX_CLIENTEDGE
this.Style = WS_CHILD OR WS_VISIBLE OR ES_MULTILINE Or ES_WANTRETURN OR WS_VSCROLL Or WS_HSCROLL OR _
ES_AUTOVSCROLL Or ES_NOHIDESEL OR ES_DISABLENOSCROLL
end Constructor
Destructor FRichEdit 'OK
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
if this.b_RichLib Then
FreeLibrary(this.b_RichLib)
EndIf
If this.Handle Then
SetWindowLong(this.Handle, GWL_WNDPROC, this.b_oldProc)
End If
this.Handle = 0
End Destructor
Property FRichEdit.PlainText(ByVal value As Integer)
b_plaintext = value
End Property
Property FRichEdit.PlainText As Integer
Return b_plaintext
End Property
Property FRichEdit.Paraleft(ByVal value As Integer)
b_paraleft = value
If value <> 0 Then
b_pararight = 0
b_paracenter = 0
EndIf
End Property
Property FRichEdit.Paraleft As Integer
Return b_paraleft
End Property
Property FRichEdit.Pararight(ByVal value As Integer)
b_pararight = value
If value <> 0 Then
b_paraleft = 0
b_paracenter = 0
EndIf
End Property
Property FRichEdit.Pararight As Integer
Return b_pararight
End Property
Property FRichEdit.Paracenter(ByVal value As Integer)
b_paracenter = value
If value <> 0 Then
b_paraleft = 0
b_pararight = 0
EndIf
End Property
Property FRichEdit.Paracenter As Integer
Return b_paracenter
End Property
Property FRichEdit.AutoHScroll(ByVal value As Integer)
Dim style As UInteger
If this.Handle Then
style = GetWindowLong(this.Handle,GWL_STYLE)
If value Then
style = style Or ES_AUTOHSCROLL
Else
style = style And(not ES_AUTOHSCROLL)
End If
SetWindowLong(this.Handle,GWL_STYLE,style)
SetWindowPos(this.Handle,0,0,0,this.Width,this.Height,SWP_DRAWFRAME Or SWP_FRAMECHANGED)
EndIf
End Property
Property FRichEdit.AutoVScroll(ByVal value As Integer)
Dim style As UInteger
If this.Handle Then
style = GetWindowLong(this.Handle,GWL_STYLE)
If value Then
style = style Or ES_AUTOVSCROLL
Else
style = style And(not ES_AUTOVSCROLL)
End If
SetWindowLong(this.Handle,GWL_STYLE,style)
SetWindowPos(this.Handle,0,0,0,this.Width,this.Height,SWP_DRAWFRAME Or SWP_FRAMECHANGED)
EndIf
End Property
Property FRichEdit.Modifid As Integer
Return this.b_Modifid
End Property
Property FRichEdit.SelText As String
Dim As CHARRANGE cr
Dim iLen As Integer
Dim sTmp As String
If this.Handle Then
SendMessage(this.Handle,EM_EXGETSEL,0,Cast(WPARAM,@cr))
If cr.cpMin = cr.cpMax Then
sTmp =""
Return sTmp
EndIf
If (cr.cpMin = 0) And (cr.cpMax = -1) Then
iLen = GetWindowTextLength(this.Handle)
sTmp = String(iLen + 2,Chr(0))
SendMessage(this.Handle,EM_GETSELTEXT,0,Cast(WPARAM,StrPtr(sTmp)))
Return sTmp
EndIf
iLen = cr.cpMax - cr.cpMin
sTmp = String(iLen + 2,Chr(0))
SendMessage(this.Handle,EM_GETSELTEXT,0,Cast(WPARAM,StrPtr(sTmp)))
Return sTmp
EndIf
End Property
Property FRichEdit.SelStart As Integer
Dim As CHARRANGE cr
Dim As Integer iRet
If this.Handle Then
SendMessage(this.Handle,EM_EXGETSEL,0,Cast(WPARAM,@cr))
iRet = cr.cpMin
Return iRet
EndIf
End Property
Property FRichEdit.SelLen As Integer
Dim As CHARRANGE cr
Dim As Integer iRet
If this.Handle Then
SendMessage(this.Handle,EM_EXGETSEL,0,Cast(WPARAM,@cr))
If cr.cpMin = cr.cpMax Then
Return 0
EndIf
If (cr.cpMin = 0) And (cr.cpMax = -1) Then
Return GetWindowTextLength(this.Handle)
EndIf
iRet = cr.cpMax - cr.cpMin
Return iRet
EndIf
End Property
Property FRichEdit.BKColor As UInteger
Return this.b_bkColor
End Property
Property FRichEdit.BKColor(ByVal value As UInteger)
If this.Handle Then
this.b_bkColor = value
SendMessage(this.Handle,EM_SETBKGNDCOLOR,0,value)
this.repaint
EndIf
End Property
Property FRichEdit.Border(ByVal Value As Integer)
Dim Styl As UInteger
If this.Handle Then
Styl = GetWindowLong(this.Handle,GWL_STYLE)
Select Case value
Case 0 ' Ohne
If Styl And WS_BORDER Then
this.Style = Styl And (Not WS_BORDER)
EndIf
this.ExStyle = 0
Case 1 ' Sunken
If Styl And WS_BORDER Then
this.Style = Styl And (Not WS_BORDER)
EndIf
this.ExStyle = WS_EX_CLIENTEDGE
Case 2 ' Border
this.Style = Styl or WS_BORDER
this.ExStyle = 0
End Select
SetWindowLong(this.Handle,GWL_STYLE,this.Style)
SetWindowLong(this.Handle,GWL_EXSTYLE,this.ExStyle)
SetWindowPos(this.Handle,0,0,0,this.Width,this.Height,SWP_DRAWFRAME Or SWP_FRAMECHANGED)
EndIf
End Property
Property FRichEdit.LMargin(ByVal value As Integer)
Dim As RECT rc
If this.Handle Then
this.b_lmargin = value
SendMessage(this.Handle,EM_GETRECT , 0 , Cast(WPARAM,@rc))
rc.left = rc.left + value
SendMessage(this.Handle,EM_SETRECT , 0 , Cast(WPARAM,@rc))
End If
End Property
Property FRichEdit.LMargin As Integer
Dim As RECT rc
If this.Handle Then
SendMessage(this.Handle,EM_GETRECT , 0 ,Cast(WPARAM,@rc))
Return rc.left
End If
End Property
Property FRichEdit.ReadOnly As Integer
If this.Handle Then
Return this.b_ReadOnly
End If
End Property
Property FRichEdit.ReadOnly(ByVal value As Integer)
If this.Handle Then
If value = 0 Then
this.b_ReadOnly = 0
SendMessage(this.Handle, EM_SETREADONLY,FALSE,0)
Else
this.b_ReadOnly = 1
SendMessage(this.Handle, EM_SETREADONLY,TRUE,0)
EndIf
End If
End Property
Property FRichEdit.ScrollBars(ByVal value As Integer)
Dim style As UInteger
If this.Handle Then
this.b_Scroll = value
style = GetWindowLong(this.Handle,GWL_STYLE)
If this.b_Scroll Then
style = style Or WS_HSCROLL Or WS_VSCROLL
Else
style = style And(not WS_HSCROLL)
style = style And(not WS_VSCROLL)
End If
SetWindowLong(this.Handle,GWL_STYLE,style)
SetWindowPos(this.Handle,0,0,0,this.Width,this.Height,SWP_DRAWFRAME Or SWP_FRAMECHANGED)
EndIf
End Property
Property FRichEdit.TextLen As Integer
If this.Handle Then
Return GetWindowTextLength(this.Handle)
EndIf
End Property
Property FRichEdit.Text As String
If this.Handle Then
Dim As Integer maxCount,i
maxCount = GetWindowTextLength(this.Handle)
this.b_Text = String(maxCount+2,Chr(0))
i = GetWindowText(this.Handle , StrPtr(this.b_Text) , maxCount+1 )
Return this.b_Text
EndIf
End Property
Property FRichEdit.Text(sText As String )
If this.Handle Then
this.b_Text = sText
SetWindowText(this.Handle ,sText)
EndIf
End Property
Sub FRichEdit.Clear
If this.Handle Then
Dim As CHARRANGE cr
cr.cpMin = 0
cr.cpMax = -1
SendMessage(this.Handle,EM_EXSETSEL,0,Cast(WPARAM,@cr))
SendMessage(this.Handle, WM_CLEAR, 0, 0)
EndIf
End Sub
Sub FRichEdit.SelParaStyle()
Dim pf AS PARAFORMAT
pf.cbSize = SizeOf(pf)
pf.dwMask = PFM_ALIGNMENT
If this.b_paraleft = TRUE Then
pf.wAlignment= PFA_LEFT
SendMessage(this.Handle,EM_SETPARAFORMAT,0,Cast(WPARAM, (@pf)))
Exit Sub
ElseIf this.b_paracenter = TRUE Then
pf.wAlignment= PFA_CENTER
SendMessage(this.Handle,EM_SETPARAFORMAT,0,Cast(WPARAM, (@pf)))
Exit Sub
ElseIf this.b_pararight = TRUE Then
pf.wAlignment= PFA_RIGHT
SendMessage(this.Handle,EM_SETPARAFORMAT,0,Cast(WPARAM, (@pf)))
Exit Sub
Else
pf.wAlignment= PFA_LEFT
SendMessage(this.Handle,EM_SETPARAFORMAT,0,Cast(WPARAM, (@pf)))
End If
End Sub
Sub FRichEdit.GetParaStyle()
Dim pf AS PARAFORMAT
pf.cbSize = SizeOf(pf)
pf.dwMask = PFM_ALIGNMENT
IF SendMessage(this.Handle,EM_GETPARAFORMAT,0,Cast(WPARAM, @pf)) = 0 THEN
MessageBox(0, " GetParaFormat - Fehler","Fehler",MB_ICONERROR)
EXIT SUB
END IF
' links
IF pf.wAlignment = PFA_LEFT THEN
this.b_paraleft = TRUE
this.b_paracenter = FALSE
this.b_pararight = FALSE
END IF
'mitte
IF pf.wAlignment = PFA_CENTER THEN
this.b_paraleft = FALSE
this.b_paracenter = TRUE
this.b_pararight = FALSE
END IF
' rechts
IF pf.wAlignment = PFA_RIGHT THEN
this.b_paraleft = FALSE
this.b_paracenter = FALSE
this.b_pararight = TRUE
END If
End Sub
Sub FRichEdit.SelFontStyle()
Dim AS CHARFORMAT cf
Dim As uInteger retVal
cf.cbSize = SizeOf(cf)
cf.dwMask = CFM_COLOR OR CFM_FACE OR CFM_SIZE OR CFM_BOLD OR CFM_ITALIC OR CFM_UNDERLINE Or CFM_STRIKEOUT
cf.szFaceName = this.font.FaceName
cf.yHeight = Abs(this.font.Size * 20)
cf.crTextColor = this.TextColor
retVal = 0
If this.font.Bold Then retVal = retVal Or CFE_BOLD
If this.font.Italic Then retVal = retVal Or CFE_ITALIC
If this.font.Underline Then retVal = retVal Or CFE_UNDERLINE
If this.font.StrikeOut Then retVal = retVal Or CFE_STRIKEOUT
cf.dwEffects = retVal
retVal=SendMessage(this.Handle,EM_SETCHARFORMAT,SCF_SELECTION ,Cast(WPARAM, @cf))
If retVal = 0 Then
MessageBox(0, " SetChar All - Fehler " + Hex(cf.dwMask),"Fehler",MB_ICONERROR)
End If
End Sub
Sub FRichEdit.GetFontStyle()
Dim cf AS CHARFORMAT
cf.cbSize = SizeOf(cf)
cf.dwMask = CFM_COLOR OR CFM_FACE OR CFM_SIZE OR CFM_BOLD OR CFM_ITALIC OR CFM_UNDERLINE Or CFM_STRIKEOUT
IF SendMessage(this.Handle,EM_GETCHARFORMAT,SCF_SELECTION,Cast(WPARAM, @cf)) = 0 Then
MessageBox(0, " GetChar All - Fehler " + Hex(cf.dwMask),"Fehler",MB_ICONERROR)
END IF
this.font.FaceName = cf.szFaceName
this.font.Size = ABS(cf.yHeight/20)' Die Schrifthöhe wird in Twips zurück gegeben !
this.TextColor = cf.crTextColor
this.font.Bold = cf.dwEffects AND CFE_BOLD
this.font.Italic = cf.dwEffects AND CFE_ITALIC
this.font.Underline = cf.dwEffects AND CFE_UNDERLINE
this.font.Strikeout = cf.dwEffects AND CFM_STRIKEOUT
End Sub
Sub FRichEdit.GlobalFontStyle()
Dim AS CHARFORMAT cf
Dim As Integer retVal
cf.cbSize = SizeOf(cf)
cf.dwMask = CFM_COLOR OR CFM_FACE OR CFM_SIZE
cf.szFaceName = this.font.FaceName
cf.yHeight = -MulDiv(this.font.Size, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72)
cf.crTextColor = this.TextColor
cf.dwEffects = 0
SendMessage(this.Handle,WM_SETFONT,Cast(Uinteger, this.font.FontHandle),TRUE)
retVal=SendMessage(this.Handle,EM_SETCHARFORMAT,SCF_DEFAULT,Cast(WPARAM, @cf))
If retVal = 0 Then
MessageBox(0, " SetChar All - Fehler " + Hex(cf.dwMask),"Fehler",MB_ICONERROR)
End If
End Sub
'----------------------- RTF-Datei-Load Callback Function --------------------
FUNCTION FRichEdit.DatenIn(BYVAL dwCookie AS UInteger,BYVAL lpBuff AS BYTE PTR, _
BYVAL cb AS INTEGER, BYVAL pcb AS INTEGER PTR) AS UInteger
Dim nResult AS UInteger
nResult =ReadFile( Cast(Any Ptr, dwCookie), lpBuff, cb, pcb, BYVAL NULL)
IF nResult = 0 THEN
FUNCTION=TRUE
EXIT FUNCTION
END IF
FUNCTION = FALSE
END Function
'----------------------- RTF-Datei-Save Callback Function ---------------------
FUNCTION FRichEdit.DatenOut(BYVAL dwCookie AS UInteger,BYVAL lpBuff AS BYTE PTR, _
BYVAL cb AS INTEGER, BYVAL pcb AS INTEGER PTR) AS UInteger
Dim nResult AS UInteger
nResult =WriteFile(Cast(Any Ptr, dwCookie),lpBuff, cb, pcb, BYVAL NULL)
IF nResult = 0 THEN
FUNCTION=TRUE
EXIT FUNCTION
END IF
FUNCTION = FALSE
END FUNCTION
'--------------------------------- Datei Laden -------------------------------
SUB FRichEdit.LoadFile(filename As String)
DIM hFile AS HANDLE
Dim es AS EDITSTREAM
Dim lpStream AS EDITSTREAM Ptr
IF LEN(filename)>4 Then
hFile = CreateFile(StrPtr(filename) ,GENERIC_READ, 0 , 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
es.dwCookie = Cast(UInteger, hFile)
es.pfnCallback = Cast(EDITSTREAMCALLBACK, @DatenIn)
lpStream = @es
IF this.PlainText = FALSE Then
SendMessage(this.Handle,EM_STREAMIN,SF_RTF,Cast(WPARAM, lpStream))
ELSE
SendMessage(this.Handle,EM_STREAMIN,SF_TEXT,Cast(WPARAM, lpStream))
END If
CloseHandle(hFile)
END IF
END SUB
'---------------------------------------------------------------------------------------
SUB FRichEdit.SaveFile(filename As String)
DIM hFile AS HANDLE
Dim es AS EDITSTREAM
Dim lpStream AS EDITSTREAM PTR
IF LEN(filename)>4 THEN
hFile = CreateFile(StrPtr(filename),GENERIC_WRITE, 0, 0 , CREATE_ALWAYS,FILE_ATTRIBUTE_NORMAL , 0)
es.dwCookie = Cast(UInteger, hFile)
es.pfnCallback = Cast(EDITSTREAMCALLBACK, @DatenOut)
lpStream = @es
IF this.PlainText = FALSE Then
SendMessage(this.Handle,EM_STREAMIN,SF_RTF,Cast(WPARAM, lpStream))
ELSE
SendMessage(this.Handle,EM_STREAMIN,SF_TEXT,Cast(WPARAM, lpStream))
END If
CloseHandle(hFile)
END IF
END Sub
Function FRichEdit.EditSubClassFunc(hWnd AS HWND,uMsg AS UINT,wParam AS wParam,lParam AS lParam) AS LRESULT
Function = 0
Dim As Integer lKeyDat = 0
Dim as FRichEdit ptr Edit = cast(FRichEdit Ptr,GetWindowLong(hWnd,GWL_USERDATA)) ' Zeiger auf diese Klasse
If Edit = 0 Then
function = DefWindowProc( hWnd, uMsg, wParam, lParam)
Exit Function
EndIf
Select case uMsg
Case WM_GETDLGCODE
Function = DLGC_WANTALLKEYS
Exit Function
'-------------------------
Case WM_RBUTTONDOWN
If Edit->onRbuttondown Then
Edit->onRbuttondown(LOWORD(lParam),HIWORD(lParam),wParam)
End If
function = CallWindowProc( Cast(Any Ptr,Edit->b_oldProc), hWnd, uMsg, wParam, lParam)
Exit Function
'-------------------------
Case WM_LBUTTONDOWN
If Edit->onLbuttondown Then
Edit->onLbuttondown(LOWORD(lParam),HIWORD(lParam),wParam)
End If
function = CallWindowProc( Cast(Any Ptr,Edit->b_oldProc), hWnd, uMsg, wParam, lParam)
Exit Function
'-------------------------
Case WM_LBUTTONUP
If Edit->onLbuttonup Then
Edit->onLbuttonup(LOWORD(lParam),HIWORD(lParam),wParam)
End If
function = CallWindowProc( Cast(Any Ptr,Edit->b_oldProc), hWnd, uMsg, wParam, lParam)
Exit Function
'-------------------------
Case WM_MOUSEMOVE
If Edit->onMousemove Then
Edit->onMousemove(LOWORD(lParam),HIWORD(lParam),wParam)
End If
function = CallWindowProc( Cast(Any Ptr,Edit->b_oldProc), hWnd, uMsg, wParam, lParam)
Exit Function
'-------------------------
Case WM_KEYDOWN
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
If Edit->OnKeyDown Then Edit->OnKeyDown(wParam,lKeyDat)
SetFocus(hWnd)
function = CallWindowProc( Cast(Any Ptr,Edit->b_oldProc), hWnd, uMsg, wParam, lParam)
Exit Function
Case WM_KEYUP
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
If Edit->OnKeyUp Then Edit->OnKeyUp(wParam,lKeyDat)
SetFocus(hWnd)
function = CallWindowProc( Cast(Any Ptr,Edit->b_oldProc), hWnd, uMsg, wParam, lParam)
Exit Function
End Select
function = CallWindowProc( Cast(Any Ptr,Edit->b_oldProc), hWnd, uMsg, wParam, lParam)
End Function
Function FRichEdit.CtrlMsgFunc(hWnd AS HWND,uMsg AS UINT,wParam AS wParam,lParam AS lParam) AS LRESULT
SELECT CASE uMsg
CASE WM_ENABLE
this.Enabled = wParam
EXIT FUNCTION
CASE WM_SETFONT,WM_SETTEXT
IF this.Handle THEN
FUNCTION = SendMessage(this.Handle,uMsg,wParam,lParam)
END IF
EXIT FUNCTION
CASE WM_SIZE
IF this.Handle THEN
MoveWindow(this.Handle,0,0,LOWORD(lParam),HiWord(lParam),TRUE)
END IF
EXIT FUNCTION
Case WM_NOTIFY
Dim As NMHDR Ptr lpNMH = Cast(Any Ptr, lParam)
IF lpNMH->code = EN_SELCHANGE THEN '
GetParaStyle
GetFontStyle
If this.onSelChange Then
this.onSelChange()
EndIf
SetFocus(this.Handle)
Function = 0
Exit Function
END If
Case WM_COMMAND
If HiWord(wParam) = EN_CHANGE Then
If this.onChange Then onChange()
Function = 0
Exit Function
End If
If HiWord(wParam) = EN_UPDATE Then
this.b_Modifid = TRUE
Function = 0
Exit Function
End If
End Select
function = DefWindowProc( hWnd, uMsg, wParam, lParam)
end Function
Sub FRichEdit.Create(ByVal hParent As HWND,ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
DIM AS ZString * 32 szClass
DIM AS HINSTANCE hInst
szClass = "FB_CONTROL"
hInst = GetModuleHandle(0)
this.CtHandle = CreateWindowEx( WS_EX_CONTROLPARENT , @szClass , "", WS_VISIBLE OR WS_CHILD , x, y, w , h , _
hParent , NULL, hInst , NULL )
SetWindowLong(this.CtHandle ,GWL_USERDATA,CINT(@This)) ' Zeiger diese Instanz
IF this.CtHandle THEN
this.Left = x
this.Top = y
this.Width = w
this.Height = h
this.Parent = hParent
ELSE
MessageBox(0,"Fehler - Create EDIT","Fehler",MB_ICONERROR)
EXIT SUB
END IF
this.Handle = CreateWindowEx( this.ExStyle ,"RICHEDIT" , "" , this.Style , 0, 0, w, h , this.CtHandle , NULL, hInst , NULL )
IF this.Handle = 0 THEN
MessageBox(0,"Fehler - Create EDIT","Fehler",MB_ICONERROR)
Exit Sub
EndIf
this.b_oldProc = SetWindowLong( this.Handle, GWL_WNDPROC, CInt(@FRichEdit.EditSubClassFunc))
SetWindowLong(this.Handle ,GWL_USERDATA,CINT(@This)) ' Zeiger diese Instanz
ShowWindow(this.Handle,SW_SHOW)
SendMessage(this.Handle,EM_SETEVENTMASK,0,Cast( WPARAM,ENM_SELCHANGE))
End Sub
'---------------------------------------------------------------------------------------
' Horiz. Scollbar
'---------------------------------------------------------------------------------------
Type FHScrollBar Extends Control
public:
Declare Property position (ByVal value As Integer)
Declare Property position As Integer
Declare Sub Range(ByVal min As Integer, ByVal max As Integer)
Declare Sub Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Declare Constructor
Declare Destructor
' Events
onChange As SUB(ByVal nPos As Integer )
Declare Function CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Private:
As Integer b_RangeMin = 0
As Integer b_RangeMax = 0
End Type
Constructor FHScrollBar
this.Handle = 0
this.ExStyle = 0
this.Style = WS_CHILD or SBS_HORZ Or WS_VISIBLE
end Constructor
Destructor FHScrollBar
this.Handle = 0
End Destructor
Property FHScrollBar.position (ByVal value As Integer)
If this.Handle Then
If (value >= this.b_RangeMin) And (value <= this.b_RangeMax) Then
SendMessage(this.Handle,SBM_SETPOS ,value,TRUE)
End If
End If
End Property
Property FHScrollBar.position As Integer
If this.Handle Then
Return SendMessage(this.Handle,SBM_GETPOS ,0,0)
End If
End Property
Sub FHScrollBar.Range(ByVal min As Integer, ByVal max As Integer)
If this.Handle Then
this.b_RangeMin = min
this.b_RangeMax = max
SetScrollRange(this.Handle,SB_CTL,min,max,TRUE)
EndIf
End Sub
Function FHScrollbar.CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Function = 0
Dim As HBRUSH hBr
Dim As Integer nPos
Select case uMsg
Case WM_ENABLE
this.Enabled = wParam
Exit Function
Case WM_SIZE
If this.Handle Then
MoveWindow(this.Handle,0,0,LOWORD(lParam),HiWord(lParam),TRUE)
End If
Exit Function
Case WM_CTLCOLORSCROLLBAR
If hBr Then
DeleteObject(hBr)
EndIf
hBr = CreateSolidBrush(this.Color)
Function = Cast(LRESULT, hBr )
Exit Function
Case WM_HSCROLL
Select Case LoWord(wParam)
Case SB_THUMBTRACK
nPos = HIWORD(wParam)
SetScrollPos(this.Handle,SB_CTL,nPos,TRUE)
If this.onChange Then onChange(nPos)
Case SB_THUMBPOSITION
nPos = HIWORD(wParam)
SetScrollPos(this.Handle,SB_CTL,nPos,TRUE)
If this.onChange Then onChange(nPos)
Case SB_BOTTOM
nPos = this.b_RangeMax
SetScrollPos(this.Handle,SB_CTL,nPos,TRUE)
If this.onChange Then onChange(nPos)
Case SB_LINEDOWN
nPos = GetScrollPos(this.Handle,SB_CTL)
If nPos < this.b_RangeMax Then
nPos = nPos + Int((this.b_RangeMax - this.b_RangeMin) / this.b_RangeMax)
SetScrollPos(this.Handle,SB_CTL,nPos,TRUE)
End If
If this.onChange Then onChange(nPos)
Case SB_LINEUP
nPos = GetScrollPos(this.Handle,SB_CTL)
If nPos > this.b_RangeMin Then
nPos = nPos - Int((this.b_RangeMax - this.b_RangeMin) / this.b_RangeMax)
SetScrollPos(this.Handle,SB_CTL,nPos,TRUE)
End If
If this.onChange Then onChange(nPos)
Case SB_TOP
nPos = this.b_RangeMin
SetScrollPos(this.Handle,SB_CTL,nPos,TRUE)
If this.onChange Then onChange(nPos)
End Select
SetFocus(this.Handle)
Function = 0
Exit Function
Case WM_VSCROLL
Select Case LoWord(wParam)
Case SB_THUMBTRACK
nPos = HIWORD(wParam)
SetScrollPos(this.Handle,SB_CTL,nPos,TRUE)
If this.onChange Then onChange(nPos)
Case SB_THUMBPOSITION
nPos = HIWORD(wParam)
SetScrollPos(this.Handle,SB_CTL,nPos,TRUE)
If this.onChange Then onChange(nPos)
Case SB_BOTTOM
nPos = this.b_RangeMax
SetScrollPos(this.Handle,SB_CTL,nPos,TRUE)
If this.onChange Then onChange(nPos)
Case SB_LINEDOWN
nPos = GetScrollPos(this.Handle,SB_CTL)
If nPos < this.b_RangeMax Then
nPos = nPos + Int((this.b_RangeMax - this.b_RangeMin) / this.b_RangeMax)
SetScrollPos(this.Handle,SB_CTL,nPos,TRUE)
End If
If this.onChange Then onChange(nPos)
Case SB_LINEUP
nPos = GetScrollPos(this.Handle,SB_CTL)
If nPos > this.b_RangeMin Then
nPos = nPos - Int((this.b_RangeMax - this.b_RangeMin) / this.b_RangeMax)
SetScrollPos(this.Handle,SB_CTL,nPos,TRUE)
End If
If this.onChange Then onChange(nPos)
Case SB_TOP
nPos = this.b_RangeMin
SetScrollPos(this.Handle,SB_CTL,nPos,TRUE)
If this.onChange Then onChange(nPos)
End Select
SetFocus(this.Handle)
Function = 0
Exit Function
End Select
Function = DefWindowProc(hWnd,uMsg,wParam,lParam)
end Function
'
Sub FHScrollbar.Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Dim As ZString * 32 szClass
Dim As HINSTANCE hInst
szClass = "FB_CONTROL"
hInst = GetModuleHandle(0)
this.CtHandle = CreateWindowEx( WS_EX_CONTROLPARENT , @szClass , "", WS_VISIBLE Or WS_CHILD , x, y, w , h , _
hParent , NULL, hInst , NULL )
SetWindowLong(this.CtHandle ,GWL_USERDATA,CInt(@This)) ' Zeiger diese Instanz
If this.CtHandle Then
this.Left = x
this.Top = y
this.Width = w
this.Height = h
this.Parent = hParent
Else
MessageBox(0,"Fehler - Create Button","Fehler",MB_ICONERROR)
Exit Sub
End If
this.Handle = CreateWindowEx( NULL , "SCROLLBAR" , "", this.Style , 0, 0, w, h , this.CtHandle , NULL, hInst , NULL )
If this.Handle = 0 Then
MessageBox(0,"Fehler - Create Button","Fehler",MB_ICONERROR)
EndIf
End Sub
'---------------------------------------------------------------------------------------
' Vert. Scollbar
'---------------------------------------------------------------------------------------
Type FVScrollBar Extends FHScrollBar
Declare Constructor
End Type
Constructor FVScrollBar
this.Exstyle = 0
this.style = WS_CHILD or SBS_VERT Or WS_VISIBLE
this.Handle = 0
End Constructor
'------------------------------------------------------------
' Hilfs Class für Mouseverwaltung
'------------------------------------------------------------
Type MTrackEvents Extends Object
public:
Declare Sub myMouseMove(ByVal hWind As HWND)
Declare Sub myReset
Declare Constructor
private:
As BOOL m_bMouseTracking
End Type
Constructor MTrackEvents
m_bMouseTracking = FALSE
End Constructor
Sub MTrackEvents.myMouseMove(ByVal hWind As HWND)
if m_bMouseTracking = FALSE Then
Dim as TRACKMOUSEEVENT tme
tme.cbSize = sizeof(tme)
tme.hwndTrack = hWind
tme.dwFlags = TME_HOVER OR TME_LEAVE
tme.dwHoverTime = HOVER_DEFAULT
TrackMouseEvent(@tme)
m_bMouseTracking = TRUE
End If
End Sub
Sub MTrackEvents.myReset
m_bMouseTracking = FALSE
End Sub
'--------------------------------------------------------------------------------------
' FToolBtn
'--------------------------------------------------------------------------------------
Type FToolBtn Extends Control
public:
Declare Property Border(Byval value as Integer)
Declare Property Border as Integer
Declare Property BorderColor(Byval value as UInteger)
Declare Property BorderColor as UInteger
Declare Property Down(Byval value as Integer)
Declare Property Down as Integer
Declare Property TextPos(Byval value as Integer)
Declare Property TextPos as Integer
Declare Property Focused(Byval value as Integer) ' Zeichnet Focusrect ja/nein
Declare Property Focused as Integer
Declare Sub Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer)
Declare Sub Image( value as String)
Declare Constructor
Declare Destructor
As MTrackEvents tEvents
' Events
onClick As Sub
onRbuttondown As Sub
Declare Function CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Private:
b_Bitmap As HBITMAP
b_TextPos As Integer
b_bmWidth As Integer
b_bmHeight As Integer
b_Down As Integer
b_Focused As Integer
b_Border As Integer
b_ColBorder As UInteger
End Type
Constructor FToolBtn
this.b_Bitmap = 0
this.b_bmWidth = 0
this.b_bmHeight = 0
this.Handle = 0
this.ExStyle = 0
this.Style = WS_CHILD Or WS_VISIBLE Or WS_TABSTOP
this.b_Down = FALSE
this.b_Focused = FALSE
this.b_TextPos = TRUE
this.b_Border = FALSE
this.b_ColBorder = 0
End Constructor
Destructor FToolBtn ' OK
If this.b_Bitmap Then
DeleteObject(this.b_Bitmap)
EndIf
this.Handle = 0
End Destructor
Property FToolBtn.BorderColor(Byval value as UInteger)
this.b_ColBorder = value
End Property
Property FToolBtn.BorderColor as UInteger
Return this.b_ColBorder
End Property
Property FToolBtn.Border(Byval value as Integer)
this.b_Border = IIf(value,TRUE,FALSE)
End Property
Property FToolBtn.Border as Integer
Return this.b_Border
End Property
Property FToolBtn.TextPos(Byval value as Integer)
this.b_TextPos = value
End Property
Property FToolBtn.TextPos as Integer
Return this.b_TextPos
End Property
Property FToolBtn.Down(Byval value as Integer)
this.b_Down = IIf(value,TRUE,FALSE)
Invalidate
End Property
Property FToolBtn.Down as Integer
Return this.b_Down
End Property
Property FToolBtn.Focused(Byval value as Integer)
this.b_Focused = IIf(value,TRUE,FALSE)
End Property
Property FToolBtn.Focused as Integer
Return this.b_Focused
End Property
Sub FToolBtn.Image( value as String)
If Len(value) > 1 Then
Dim As BITMAP bm
Dim As ZString * 128 szRes
szRes = value
If InStr(szRes,".") = 0 Then ' Wenn kein Punkt (.) enthalen ist, dann Resource
this.b_Bitmap = LoadBitmap(GetModuleHandle(0) , cast( LPCSTR, @szRes ))
If this.b_Bitmap = 0 Then
MessageBox( null, "Fehler - Bitmap ist nicht geladen", "Error Menu", MB_ICONERROR )
EndIf
Else ' mit Punkt (.) dann Deteiname
this.b_Bitmap = LoadImage(NULL,@szRes,IMAGE_Bitmap,0,0,LR_DEFAULTCOLOR Or LR_LOADFROMFILE )
If this.b_Bitmap = 0 Then
MessageBox( null, "Fehler - Bitmap ist nicht geladen", "Menu Error", MB_ICONERROR )
EndIf
End If
GetObject(this.b_Bitmap,SizeOf(bm),@bm)
this.b_bmWidth = bm.bmWidth
this.b_bmHeight = bm.bmHeight
EndIf
End Sub
Function FToolBtn.CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Function = 0
Dim As HDC hDC,tmpdc
Dim As RECT rc,bmpRC
Dim As HBRUSH hBr
Select case uMsg
Case WM_SETFOCUS
Invalidate
Exit Function
'-------------------------
Case WM_KILLFOCUS
Invalidate
Exit Function
'-------------------------
Case WM_PAINT
dim pnt as PAINTSTRUCT
Dim As Integer x,y
hDC = BeginPaint( hWnd, @pnt )
GetClientRect(hWnd,@rc)
'Hintergrund -------------------------
SetBkColor(hDC,this.Color)
hBr = CreateSolidBrush(this.Color)
FillRect(hDC,@rc,hBr)
DeleteObject(hBr)
If this.b_Border Then
hBr = CreateSolidBrush(this.b_ColBorder)
FrameRect(hDC,@rc,hBr)
DeleteObject(hBr)
EndIf
'
If this.b_Down = TRUE Then
DrawEdge(hDC,@rc, EDGE_SUNKEN , BF_RECT )
EndIf
If (this.b_Bitmap<>0) And (Len(this.Caption) = 0) Then ' Nur Bild
x = Int((this.Width - this.b_bmWidth)/2)
y = Int((this.Height - this.b_bmHeight)/2)
tmpdc = CreateCompatibleDC(hDC)
SelectObject(tmpdc,this.b_Bitmap)
BitBlt(hDC,x,y ,this.b_bmWidth + x,this.b_bmHeight + y ,tmpdc,0,0,SRCCOPY)
DeleteDC(tmpdc)
ElseIf (this.b_Bitmap=0) And (Len(this.Caption)<> 0) Then ' Nur Text
SetBkMode(hDc, TRANSPARENT)
SetTextColor(hDC,this.TextColor)
DeleteObject(SelectObject(hDc,this.Font))
DrawText(hDC,this.Caption, -1, @rc, DT_SINGLELINE or DT_CENTER or DT_VCENTER )
ElseIf (this.b_Bitmap<>0) And (Len(this.Caption)<> 0) Then ' Bild + Text
If b_TextPos = TRUE Then ' Bild oben
bmpRC.left = Int((rc.right - this.b_bmWidth) /2)
bmpRC.top = rc.top + 5 ' Padding oben
bmpRC.right = this.b_bmWidth
bmpRC.bottom= this.b_bmHeight
rc.left = rc.left + 2
rc.Top = this.b_bmHeight + 10
Else ' Bild links
bmpRC.left = 5
bmpRC.top = Int((rc.bottom - this.b_bmHeight) /2)
bmpRC.right = this.b_bmWidth
bmpRC.bottom= this.b_bmHeight
rc.left = rc.left + 5 + this.b_bmWidth
EndIf
tmpdc = CreateCompatibleDC(hDC)
SelectObject(tmpdc,this.b_Bitmap)
BitBlt(hDC,bmpRC.left,bmpRC.top,bmpRC.right,bmpRC.bottom,tmpdc,0,0,SRCCOPY)
DeleteDC(tmpdc)
SetBkMode(hDc, TRANSPARENT)
SetTextColor(hDC,this.TextColor)
DeleteObject(SelectObject(hDc,this.Font))
DrawText(hDC,this.Caption, -1, @rc, DT_SINGLELINE or DT_CENTER or DT_VCENTER )
EndIf
' FocusRect zeichnen
If (hWnd = GetFocus()) And (this.b_Focused = TRUE)Then
GetClientRect(hWnd,@rc)
rc.left +=3
rc.top +=3
rc.right -=3
rc.bottom -=3
DrawFocusRect(hDc,@rc)
End If
EndPaint( hWnd, @pnt )
Exit Function
'-------------------------
Case WM_RBUTTONDOWN
If this.onRbuttondown Then
onRbuttondown()
End If
Exit Function
'-------------------------
Case WM_LBUTTONDOWN
If this.b_Down = FALSE Then
hDc = GetDC(hWnd)
GetClientRect(hWnd,@rc)
DrawEdge(hDC,@rc, EDGE_SUNKEN , BF_RECT )
ReleaseDC(hWnd,hDc)
Else
this.Down = FALSE
End If
Exit Function
'-------------------------
Case WM_LBUTTONUP
If this.onClick Then
onClick()
End If
SetFocus(hWnd)
Invalidate
Exit Function
'-------------------------
Case WM_MOUSEMOVE
If this.b_Down = FALSE Then
hDc = GetDC(hWnd)
GetClientRect(hWnd,@rc)
DrawEdge(hDC,@rc, EDGE_RAISED , BF_RECT )
ReleaseDC(hWnd,hDc)
End If
tEvents.myMouseMove(hWnd)
Exit Function
'-------------------------
case WM_MOUSELEAVE
Invalidate
tEvents.myReset
Exit Function
case WM_MOUSEHOVER
tEvents.myReset
Exit Function
Case WM_KEYDOWN
If wParam = 32 Then
hDc = GetDC(hWnd)
GetClientRect(hWnd,@rc)
DrawEdge(hDC,@rc, EDGE_SUNKEN , BF_RECT )
ReleaseDC(hWnd,hDc)
End If
Exit Function
'-------------------------
Case WM_KEYUP
If wParam = 32 Then
GetClientRect(hWnd,@rc)
If this.onClick Then
onClick()
End If
SetFocus(hWnd)
InvalidateRect(hWnd,@rc,TRUE)
End If
Exit Function
End Select
Function = DefWindowProc(hWnd,uMsg,wParam,lParam)
end Function
Sub FToolBtn.Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer)
Dim As ZString * 32 szClass
Dim As HINSTANCE hInst
this.Parent = hParent
szClass = "FB_CONTROL"
hInst = GetModuleHandle(0)
this.Handle = CreateWindowEx( this.ExStyle , @szClass , "" , this.Style , x, y, w , h , _
this.Parent , NULL, hInst , NULL )
SetWindowLong(this.Handle ,GWL_USERDATA,CInt(@This)) ' Zeiger diese Instanz
If this.Handle Then
this.Left = x
this.Top = y
this.Width = w
this.Height = h
this.Caption = ""
Else
MessageBox(0,"Fehler - Create FToolBtn","Fehler",MB_ICONERROR)
Exit Sub
End If
End Sub
'-------------------------------------------------------------------------------------------
' Timer
'-------------------------------------------------------------------------------------------
Type FBTimer Extends Object
public:
Declare Property Takt As Integer
Declare Property Takt(ByVal value As Integer)
Declare Sub Start(ByVal win As HWND )
Declare Sub Stop()
Declare Constructor
Declare Destructor
onTimer As Sub ()
Private:
As Integer b_takt = 1000
As HWND b_hWnd = 0
As Integer b_ID = 0
Declare Static Function MyTimerProc(hWnd As HWND, uMsg as UINT, idEvent as UINT ,dwTime As UInteger) as LRESULT
End Type
Function FBTimer.MyTimerProc(hWnd As HWND,uMsg as UINT, idEvent as UINT ,dwTime As UInteger) as LRESULT
Function = 0
Dim ret As Integer
Dim As FBTimer Ptr tim=Cast(FBTimer Ptr,idEvent)
If tim=0 Then Exit Function
If uMsg = WM_TIMER Then
If tim->onTimer Then tim->onTimer()
EndIf
End Function
Constructor FBTimer
this.b_takt = 1000
this.b_hWnd = 0
this.b_ID = CInt(@This)
End Constructor
Destructor FBTimer
this.b_takt = 0
KillTimer(this.b_hWnd,this.b_ID)
End Destructor
Property FBTimer.Takt As Integer
Return this.b_takt
End Property
Property FBTimer.Takt(ByVal value As Integer)
this.b_takt = value
End Property
Sub FBTimer.Start(ByVal win As HWND )
Dim As Integer retVal
this.b_hWnd = win
retVal=SetTimer(this.b_hWnd, this.b_ID, this.b_takt,Cast(TimerProc, @MyTimerProc ))
End Sub
Sub FBTimer.Stop()
KillTimer(this.b_hWnd,this.b_ID)
End Sub
'-------------------------------------------------------------------------------------------
' UPDOWN
'-------------------------------------------------------------------------------------------
Type FUpDown Extends Control
public:
Declare Property Upper(ByVal value As Short)
Declare Property Upper As Short
Declare Property Lower(ByVal value As Short)
Declare Property Lower As Short
Declare Property Curpos(ByVal value As Short)
Declare Property Curpos As Short
Declare Property Buddy(ByVal value As HWND)
Declare Property Buddy As HWND
Declare sub Range(ByVal min As USHORT ,ByVal max As USHORT )
Declare Sub Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Declare Constructor
Declare Destructor
' Events
onChange As Sub(ByVal nPos As Integer)
' Func
Declare Function CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Private:
As HWND b_hBuddy = 0
As Short b_UP = 10
As Short b_LO = 0
As Short b_POS = 0
End Type
Constructor FUpDown
If InitCommon = 0 Then
InitCommonControls
InitCommon = 1
EndIf
this.Handle = 0
this.ExStyle = 0
this.Style = WS_CHILD Or WS_VISIBLE
end Constructor
Destructor FUpDown
this.Handle = 0
End Destructor
Property FUpDown.Upper(ByVal value As Short)
If this.Handle Then
this.b_UP = value
SendMessage(this.Handle,UDM_SETRANGE,0,MAKELONG(this.b_UP, this.b_LO))
EndIf
End Property
Property FUpDown.Upper As Short
Dim As UInteger nRange
If this.Handle Then
nRange = SendMessage(this.Handle,UDM_GETRANGE,0,0)
this.b_UP = LoWord(nRange)
EndIf
Return this.b_UP
End Property
Property FUpDown.Lower(ByVal value As Short)
If this.Handle Then
this.b_LO = value
SendMessage(this.Handle,UDM_SETRANGE,0,MAKELONG(this.b_UP, this.b_LO))
EndIf
End Property
Property FUpDown.Lower As Short
Dim As UInteger nRange
If this.Handle Then
nRange = SendMessage(this.Handle,UDM_GETRANGE,0,0)
this.b_LO = HiWord(nRange)
EndIf
Return this.b_LO
End Property
Property FUpDown.Curpos(ByVal value As Short)
Dim zTxt As ZString * 16
If this.Handle Then
this.b_POS = value
SendMessage(this.Handle,UDM_SETPOS ,0,MAKELONG(value, 0))
If this.b_hBuddy Then
zTxt = Str(value)
SetWindowText(this.b_hBuddy,@zTxt)
EndIf
EndIf
End Property
Property FUpDown.Curpos As Short
If this.Handle Then
this.b_POS = SendMessage(this.Handle,UDM_GETPOS,0,0)
EndIf
Return this.b_POS
End Property
Property FUpDown.Buddy(ByVal value As HWND)
Dim zTxt As ZString * 16
If this.Handle Then
this.b_hBuddy = value
SendMessage(this.Handle,UDM_SETBUDDY,Cast(WPARAM, value),0)
zTxt = Str(this.Curpos)
SendMessage(this.Buddy,WM_SETTEXT,0,CInt(@zTxt))
EndIf
End Property
Property FUpDown.Buddy As HWND
Return this.b_hBuddy
End Property
sub FUpDown.Range(ByVal min As USHORT ,ByVal max As USHORT )
If this.Handle Then
this.b_LO = min
this.b_UP = max
SendMessage(this.Handle,UDM_SETRANGE,0,MAKELONG(this.b_UP, this.b_LO))
EndIf
End Sub
Function FUpDown.CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Dim zTxt As ZString * 16
Dim As RECT rc
Function = 0
Select case uMsg
Case WM_ENABLE
this.Enabled = wParam
Exit Function
Case WM_SIZE
IF this.Handle THEN
MoveWindow(this.Handle,0,0,LOWORD(lParam),HiWord(lParam),TRUE)
END IF
EXIT Function
Case WM_ERASEBKGND
Dim As RECT rc
GetClientRect(hWnd,@rc)
FillRect(Cast(HDC,wParam),@rc,GetStockObject(NULL_BRUSH))
Function = TRUE
Exit Function
Case WM_HSCROLL
Select Case LoWord(wParam)
Case SB_THUMBPOSITION
If this.onChange Then onChange(HIWORD(wParam))
If this.Buddy Then
zTxt = Str(HIWORD(wParam))
SendMessage(this.Buddy,WM_SETTEXT,0,CInt(@zTxt))
EndIf
Exit Function
End Select
Case WM_VSCROLL
Select Case LoWord(wParam)
Case SB_THUMBPOSITION
If this.onChange Then onChange(HIWORD(wParam))
If this.Buddy Then
zTxt = Str(HIWORD(wParam))
SendMessage(this.Buddy,WM_SETTEXT,0,CInt(@zTxt))
EndIf
Exit Function
End Select
End Select
Function = DefWindowProc(hWnd,uMsg,wParam,lParam)
end Function
'
Sub FUpDown.Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Dim As ZString * 32 szClass
Dim As HINSTANCE hInst
szClass = "FB_CONTROL"
hInst = GetModuleHandle(0)
this.CtHandle = CreateWindowEx( WS_EX_CONTROLPARENT , @szClass , "", WS_VISIBLE OR WS_CHILD , x, y, w , h , _
hParent , NULL, hInst , NULL )
SetWindowLong(this.CtHandle ,GWL_USERDATA,CINT(@This)) ' Zeiger diese Instanz
IF this.CtHandle THEN
this.Left = x
this.Top = y
this.Width = w
this.Height = h
this.Parent = hParent
ELSE
MessageBox(0,"Fehler - Create UPDOWN","Fehler",MB_ICONERROR)
EXIT SUB
END If
szClass = "msctls_updown32"
this.Handle = CreateWindowEx( WS_EX_CONTROLPARENT , @szClass , "", WS_VISIBLE OR WS_CHILD , 0, 0, w , h , _
this.CtHandle , NULL, hInst , NULL )
If this.Handle = 0 Then
MessageBox(0,"Fehler - Create UPDOWN","Fehler",MB_ICONERROR)
End If
End Sub
'---------------------------------------------------------------------------------------------------------
' Trackbar
'---------------------------------------------------------------------------------------------------------
Type FTrackbar Extends Control
public:
Declare Property TumpColor(ByVal value As UInteger)
Declare Property TumpColor As UInteger
Declare Property RilColor(ByVal value As UInteger)
Declare Property RilColor As UInteger
Declare Property DefTump(ByVal value As Integer)
Declare Property DefTump As Integer
Declare Property Tick(ByVal value As Integer)
Declare Property Tick As Integer
Declare Property TumpPos(ByVal value As Integer)
Declare Property TumpPos As Integer
Declare Property Border(ByVal value As Integer)
Declare Property Border As Integer
Declare Property Orientation(ByVal value As Integer) ' vordefiniert = Horizontal ; Orientation = 1 Vertical
Declare Property Orientation As Integer
Declare sub Range(ByVal min As USHORT ,ByVal max As USHORT )
Declare Sub Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Declare Constructor
Declare Destructor
' Events
onChange As SUB( ByVal tbPos As Integer)
Declare Function CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Private:
As Integer b_Orient = 0
As Integer b_Border = 0
As HBRUSH b_Brush = 0
As UInteger b_TumpColor = &HBBBBBB
As UInteger b_RilColor = &HEEEEEE
As Integer b_DefTump = FALSE
As Integer b_Tick = TRUE
End Type
Constructor FTrackbar
If InitCommon = 0 Then
InitCommonControls
InitCommon = 1
EndIf
this.Handle = 0
this.Style = WS_CHILD or WS_VISIBLE or TBS_TOOLTIPS Or TBS_FIXEDLENGTH OR TBS_AUTOTICKS
'this.Style = WS_CHILD or WS_VISIBLE or TBS_TOOLTIPS Or TBS_ENABLESELRANGE OR TBS_AUTOTICKS ' breite Rille
End Constructor
Destructor FTrackbar
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
this.Handle = 0
End Destructor
Property FTrackbar.TumpPos(ByVal value As Integer)
Dim As Integer nMin,nMax
If this.Handle Then
nMin = SendMessage(this.Handle, TBM_GETRANGEMIN , 0 , 0)
nMax = SendMessage(this.Handle, TBM_GETRANGEMAX , 0 , 0)
If (value <= nMax) And (value >= nMin) Then
SendMessage(this.Handle, TBM_SETPOS, TRUE , value)
EndIf
EndIf
End Property
Property FTrackbar.TumpPos As Integer
If this.Handle Then
Return SendMessage(this.Handle, TBM_GETPOS, 0, 0)
EndIf
End Property
Property FTrackbar.TumpColor(ByVal value As UInteger)
If this.Handle Then
this.b_TumpColor = value
Repaint
EndIf
End Property
Property FTrackbar.TumpColor As UInteger
Return this.b_TumpColor
End Property
Property FTrackbar.RilColor(ByVal value As UInteger)
If this.Handle Then
this.b_RilColor = value
Repaint
EndIf
End Property
Property FTrackbar.RilColor As UInteger
Return this.b_RilColor
End Property
Property FTrackbar.DefTump(ByVal value As Integer)
If this.Handle Then
this.b_DefTump = IIf(value,TRUE,FALSE)
EndIf
End Property
Property FTrackbar.DefTump As Integer
Return this.b_DefTump
End Property
Property FTrackbar.Tick(ByVal value As Integer)
If this.Handle Then
If value Then
this.Style = WS_CHILD or WS_VISIBLE or TBS_TOOLTIPS Or TBS_FIXEDLENGTH OR TBS_AUTOTICKS Or this.b_Orient
Else
this.Style = WS_CHILD or WS_VISIBLE or TBS_TOOLTIPS Or TBS_FIXEDLENGTH OR TBS_NOTICKS Or this.b_Orient
EndIf
SetWindowLong(this.handle,GWL_STYLE,this.Style)
Repaint
EndIf
End Property
Property FTrackbar.Tick As Integer
Return this.b_Tick
End Property
Property FTrackbar.Orientation(ByVal value As Integer)
If this.Handle Then
Dim As UInteger styl = GetWindowLong(this.handle,GWL_STYLE)
If value Then
this.b_Orient = TBS_VERT ' <> 0 TBS_VERT
styl = styl And (Not TBS_HORZ)
styl = styl Or TBS_VERT
Else
this.b_Orient = TBS_HORZ ' 0 = TBS_HORZ
styl = styl And (Not TBS_VERT )
styl = styl Or TBS_HORZ
EndIf
this.Style = styl
SetWindowLong(this.handle,GWL_STYLE,this.Style)
Repaint
EndIf
End Property
Property FTrackbar.Orientation As Integer
Return this.b_Orient
End Property
Property FTrackbar.Border(ByVal value As Integer)
If this.Handle Then
this.b_Border = value
Select Case value
Case 0
this.Style = WS_CHILD or WS_VISIBLE or TBS_AUTOTICKS Or TBS_FIXEDLENGTH Or this.b_Orient
this.ExStyle = 0
Case 1
this.Style = WS_CHILD or WS_VISIBLE or TBS_AUTOTICKS Or TBS_FIXEDLENGTH Or WS_BORDER Or this.b_Orient
this.ExStyle = 0
Case 2
this.Style = WS_CHILD or WS_VISIBLE or TBS_AUTOTICKS Or TBS_FIXEDLENGTH Or this.b_Orient
this.ExStyle = WS_EX_CLIENTEDGE
End Select
SetWindowLong(this.handle,GWL_STYLE,this.Style)
SetWindowLong(this.handle,GWL_EXSTYLE,this.ExStyle)
SetWindowPos(this.handle,0,0,0,this.Width,this.Height,SWP_DRAWFRAME Or SWP_FRAMECHANGED)
EndIf
End Property
Property FTrackbar.Border As Integer
Return this.b_Border
End Property
Function FTrackbar.CtrlMsgFunc(hWnd As HWND,uMsg as UINT,wParam as wParam,lParam as lParam) as LRESULT
Dim As Integer nPos
Dim As HBRUSH hBrush
Select Case uMsg
CASE WM_ENABLE
this.Enabled = wParam
EXIT Function
Case WM_SIZE
IF this.Handle THEN
MoveWindow(this.Handle,0,0,LOWORD(lParam),HiWord(lParam),TRUE)
END IF
EXIT Function
Case WM_NOTIFY
Dim As NMCUSTOMDRAW Ptr pNMCD = Cast(Any Ptr, LPARAM)
If pNMCD->hdr.hwndFrom = this.Handle THEN
If pNMCD->hdr.code = NM_CUSTOMDRAW THEN
Select CASE pNMCD->dwDrawStage
Case CDDS_PREPAINT
' Wenn hier NULL zurückgegeben wird kommen keine weiteren PREPAINT Messagen
Function = CDRF_NOTIFYITEMDRAW 'CDRF_NOTIFYITEMDRAW OR CDRF_NOTIFYPOSTPAINT
Exit FUNCTION
case CDDS_PREERASE , CDDS_POSTERASE ,CDDS_ITEMPREERASE, CDDS_ITEMPOSTERASE
Function = CDRF_DODEFAULT
Exit FUNCTION
case CDDS_ITEMPREPAINT
Select Case pNMCD->dwItemSpec
Case TBCD_CHANNEL
DrawEdge(pNMCD->hdc, @pNMCD->rc, EDGE_SUNKEN , BF_RECT ) ' Ränder der Rille
InflateRect( @pNMCD->rc, -1, -1 )
hBrush = CreateSolidBrush(this.b_RilColor) ' color der Rille
FillRect(pNMCD->hdc, @pNMCD->rc, hBrush ) ' Rille füllen
DeleteObject hBrush
Function = CDRF_SKIPDEFAULT 'fertig keine weiteren Zeichnungen
' wen weiter Zeichnung dann Function = CDRF_DODEFAULT Or CDRF_NOTIFYPOSTPAINT
Exit Function
case TBCD_TICS
Function = CDRF_DODEFAULT 'fertig keine weiteren Zeichnungen
Exit Function
case TBCD_THUMB
If this.b_DefTump Then
Function = CDRF_DODEFAULT 'fertig keine weiteren Zeichnungen
Exit Function
Else
hBrush = CreateSolidBrush(b_TumpColor)
FillRect(pNMCD->hdc, @pNMCD->rc, hBrush )
DeleteObject hBrush
DrawEdge(pNMCD->hdc, @pNMCD->rc, BDR_RAISEDOUTER , BF_RECT )
Function = CDRF_SKIPDEFAULT 'fertig keine weiteren Zeichnungen
Exit Function
End if
End Select
End Select
EndIf
EndIf
Case WM_CTLCOLORSTATIC
If this.b_Brush Then
DeleteObject(this.b_Brush)
EndIf
this.b_Brush = CreateSolidBrush(This.Color)
Function = Cast(LRESULT,this.b_Brush)
Exit Function
Case WM_HSCROLL
Select Case LoWord(wParam)
Case SB_THUMBTRACK
If this.onChange Then this.onChange(HIWORD(wParam))
Case SB_BOTTOM, SB_LINEDOWN, SB_LINEUP, SB_TOP
nPos = SendMessage(this.Handle, TBM_GETPOS, 0, 0)
If this.onChange Then this.onChange(nPos)
Case SB_ENDSCROLL
nPos = SendMessage(this.Handle, TBM_GETPOS, 0, 0)
If this.onChange Then this.onChange(nPos)
End Select
Function = 0
Exit Function
Case WM_VSCROLL
Select Case LoWord(wParam)
Case SB_THUMBTRACK
If this.onChange Then this.onChange(HIWORD(wParam))
Case SB_BOTTOM, SB_LINEDOWN, SB_LINEUP, SB_TOP
nPos = SendMessage(this.Handle, TBM_GETPOS, 0, 0)
If this.onChange Then this.onChange(nPos)
Case SB_ENDSCROLL
nPos = SendMessage(this.Handle, TBM_GETPOS, 0, 0)
If this.onChange Then this.onChange(nPos)
End Select
Function = 0
Exit Function
End Select
Function = DefWindowProc(hWnd,uMsg,wParam,lParam)
End Function
Sub FTrackbar.Create(ByVal hParent As HWND, ByVal x As Integer,ByVal y As Integer,ByVal w As Integer,ByVal h As Integer )
Dim As ZString * 32 szClass
Dim As HINSTANCE hInst
szClass = "FB_CONTROL"
hInst = GetModuleHandle(0)
this.CtHandle = CreateWindowEx( WS_EX_CONTROLPARENT , @szClass , "", WS_VISIBLE OR WS_CHILD , x, y, w , h , _
hParent , NULL, hInst , NULL )
SetWindowLong(this.CtHandle ,GWL_USERDATA,CINT(@This)) ' Zeiger diese Instanz
IF this.CtHandle THEN
this.Left = x
this.Top = y
this.Width = w
this.Height = h
this.Parent = hParent
ELSE
MessageBox(0,"Fehler - Create UPDOWN","Fehler",MB_ICONERROR)
EXIT SUB
END If
this.Handle = CreateWindowEx( this.ExStyle , TRACKBAR_CLASS ,"" , this.Style , 0, 0, w, h , this.CtHandle ,NULL, hInst, NULL)
If this.Handle = 0 Then
MessageBox(0,"Create Trackbar ist fehl geschlagen","Fehler",MB_ICONERROR)
EndIf
End Sub
sub FTrackbar.Range(ByVal min As USHORT ,ByVal max As USHORT )
If this.Handle Then
SendMessage(this.Handle,TBM_SETRANGE ,TRUE, MAKELONG(min, max))
RePaint
EndIf
End Sub