CWindowBase.sbp [ここをクリックすると内容が表示されます] [ここをクリックすると非表示にします]コード:
Class CWindowBase
Public
Sub CWindowBase()
Width=GetSystemMetrics(SM_CXSCREEN)
Height=GetSystemMetrics(SM_CYSCREEN)
Background=GetStockObject(WHITE_BRUSH)
ClassName="MainWindow"
WindowName="MainWindow For ObjectPrograming"
Style=WS_OVERLAPPEDWINDOW
cx=640
cy=480
x=Width\2-cx\2
y=Height\2-cy\2
End Sub
Sub ~CWindowBase()
RemoveProp(hwnd,"pThis")
End Sub
Sub Register()
If pRegister Then
pRegister(VarPtr(this))
Else
Dim wcx As WNDCLASSEX
With wcx
.cbSize =SizeOf(WNDCLASSEX)
.cbClsExtra =0
.cbWndExtra =0
.hbrBackground =Background
.hCursor =LoadCursor(NULL,IDC_ARROW)
.hIcon =LoadIcon(NULL,IDI_APPLICATION)
.hIconSm =NULL
.hInstance =hInstance
.lpfnWndProc =AddressOf(GlobalProc)
.lpszClassName =ClassName
.lpszMenuName =NULL
.style =CS_VREDRAW or CS_HREDRAW
End With
If RegisterClassEx(wcx) Then Else End
End If
End Sub
Sub Create()
If pCreate Then
pCreate(VarPtr(this))
Else
hwnd=CreateWindowEx(0,ClassName,WindowName,Style,x,y,cx,cy,NULL,NULL,hInstance,NULL)
SetProp(hwnd,"pThis",VarPtr(this))
End If
End Sub
Function LocalProc(hwnd As HWND,msg As DWord,wParam As WPARAM,lParam As LPARAM) As LRESULT
Select Case msg
Case WM_DESTROY
PostQuitMessage(0)
Case Else
If pLocalProc Then
LocalProc=pLocalProc(hwnd,msg,wParam,lParam)
Else
LocalProc=DefWindowProc(hwnd,msg,wParam,lParam)
End If
End Select
End Function
Sub _Loop()
If pLoop Then
pLoop(VarPtr(this))
Else
Dim msg As MSG
Do
TranslateMessage(msg)
DispatchMessage(msg)
Loop while GetMessage(msg,NULL,0,0)
End If
End Sub
Sub Initalize()
If pInitalize Then pInitalize(VarPtr(this))
End Sub
Sub Uninitalize()
If pUninitalize Then pUninitalize(VarPtr(this))
End Sub
Public
pRegister As *Sub(pThis As *CWindowBase)
pCreate As *Sub(pThis As *CWindowBase)
pLoop As *Sub(pThis As *CWindowBase)
pLocalProc As *Function(hwnd As HWND,msg As DWord,wParam As WPARAM,lParam As LPARAM) As LRESULT
pInitalize As *Sub(pThis As *CWindowBase)
pUninitalize As *Sub(pThis As *CWindowBase)
Protected
Background As DWord
ClassName As *Byte
WindowName As *Byte
Style As DWord
x As Long
y As Long
cx As Long
cy As Long
WndProc As DWord
Public
hwnd As HWND
hInstance As HINSTANCE
Width As Long
Height As Long
End Class
Function GlobalProc(hwnd As HWND,msg As DWord,wParam As WPARAM,lParam As LPARAM) As LRESULT
Dim pThis As *CWindowBase
pThis=GetProp(hwnd,"pThis")
If pThis Then
GlobalProc=pThis->LocalProc(hwnd,msg,wParam,lParam)
Else
GlobalProc=DefWindowProc(hwnd,msg,wParam,lParam)
End If
End Function
CApplicationBase.sbp [ここをクリックすると内容が表示されます] [ここをクリックすると非表示にします]コード: #include "CWindowBase.sbp"
Class CApplicationBase
Public
Sub CApplicationBase()
End Sub
Sub ~CApplicationBase()
End
End Sub
Sub Run(pWindow As *CWindowBase)
pWindow->hInstance=GetModuleHandle(0)
pWindow->Register()
pWindow->Create()
pWindow->Initalize()
ShowWindow(pWindow->hwnd,SW_SHOW)
pWindow->_Loop()
pWindow->Uninitalize()
Delete pWindow
Delete VarPtr(this)
End Sub
End Class
Dim Application As *CApplicationBase
Application=New CApplicationBase
Main.abp [ここをクリックすると内容が表示されます] [ここをクリックすると非表示にします]コード:
#include "CApplicationBase.sbp"
Application->Run(New CWindow)
Class CWindow
Inherits CWindowBase
Public
Sub CWindow()
pLocalProc=AddressOf(LocalProc) ' Override Function/Sub
pInitalize=AddressOf(Initalize)
Background=COLOR_3DFACE+1
End Sub
Sub ~CWindow()
End Sub
Sub Initalize(pThis As *CWindowBase)
Dim hdc As HDC
hdc=GetDC(pThis->hwnd)
ReleaseDC(pThis->hwnd,hdc)
End Sub
Function LocalProc(hwnd As HWND,msg As DWord,wParam As WPARAM,lParam As LPARAM) As LRESULT
Select Case msg
Case Else
LocalProc=DefWindowProc(hwnd,msg,wParam,lParam)
End Select
End Function
End Class
良いのになぁなんて妄想して関数ポインタ使用しm
[hide=CWindowBase.sbp][code] Class CWindowBase Public Sub CWindowBase() Width=GetSystemMetrics(SM_CXSCREEN) Height=GetSystemMetrics(SM_CYSCREEN) Background=GetStockObject(WHITE_BRUSH) ClassName="MainWindow" WindowName="MainWindow For ObjectPrograming" Style=WS_OVERLAPPEDWINDOW cx=640 cy=480 x=Width\2-cx\2 y=Height\2-cy\2 End Sub
Sub ~CWindowBase() RemoveProp(hwnd,"pThis") End Sub
Sub Register() If pRegister Then pRegister(VarPtr(this)) Else Dim wcx As WNDCLASSEX
With wcx .cbSize =SizeOf(WNDCLASSEX) .cbClsExtra =0 .cbWndExtra =0 .hbrBackground =Background .hCursor =LoadCursor(NULL,IDC_ARROW) .hIcon =LoadIcon(NULL,IDI_APPLICATION) .hIconSm =NULL .hInstance =hInstance .lpfnWndProc =AddressOf(GlobalProc) .lpszClassName =ClassName .lpszMenuName =NULL .style =CS_VREDRAW or CS_HREDRAW End With If RegisterClassEx(wcx) Then Else End End If End Sub
Sub Create() If pCreate Then pCreate(VarPtr(this)) Else hwnd=CreateWindowEx(0,ClassName,WindowName,Style,x,y,cx,cy,NULL,NULL,hInstance,NULL) SetProp(hwnd,"pThis",VarPtr(this)) End If End Sub
Function LocalProc(hwnd As HWND,msg As DWord,wParam As WPARAM,lParam As LPARAM) As LRESULT Select Case msg Case WM_DESTROY PostQuitMessage(0) Case Else If pLocalProc Then LocalProc=pLocalProc(hwnd,msg,wParam,lParam) Else LocalProc=DefWindowProc(hwnd,msg,wParam,lParam) End If End Select End Function
Sub _Loop() If pLoop Then pLoop(VarPtr(this)) Else Dim msg As MSG
Do TranslateMessage(msg) DispatchMessage(msg) Loop while GetMessage(msg,NULL,0,0) End If End Sub
Sub Initalize() If pInitalize Then pInitalize(VarPtr(this)) End Sub
Sub Uninitalize() If pUninitalize Then pUninitalize(VarPtr(this)) End Sub Public pRegister As *Sub(pThis As *CWindowBase) pCreate As *Sub(pThis As *CWindowBase) pLoop As *Sub(pThis As *CWindowBase) pLocalProc As *Function(hwnd As HWND,msg As DWord,wParam As WPARAM,lParam As LPARAM) As LRESULT pInitalize As *Sub(pThis As *CWindowBase) pUninitalize As *Sub(pThis As *CWindowBase) Protected Background As DWord ClassName As *Byte WindowName As *Byte Style As DWord x As Long y As Long cx As Long cy As Long WndProc As DWord Public hwnd As HWND hInstance As HINSTANCE Width As Long Height As Long End Class Function GlobalProc(hwnd As HWND,msg As DWord,wParam As WPARAM,lParam As LPARAM) As LRESULT Dim pThis As *CWindowBase
pThis=GetProp(hwnd,"pThis") If pThis Then GlobalProc=pThis->LocalProc(hwnd,msg,wParam,lParam) Else GlobalProc=DefWindowProc(hwnd,msg,wParam,lParam) End If End Function[/code][/hide] [hide=CApplicationBase.sbp][code]#include "CWindowBase.sbp" Class CApplicationBase Public Sub CApplicationBase() End Sub
Sub ~CApplicationBase() End End Sub
Sub Run(pWindow As *CWindowBase) pWindow->hInstance=GetModuleHandle(0) pWindow->Register() pWindow->Create() pWindow->Initalize() ShowWindow(pWindow->hwnd,SW_SHOW) pWindow->_Loop() pWindow->Uninitalize()
Delete pWindow Delete VarPtr(this) End Sub End Class Dim Application As *CApplicationBase Application=New CApplicationBase[/code][/hide] [hide=Main.abp][code] #include "CApplicationBase.sbp"
Application->Run(New CWindow) Class CWindow Inherits CWindowBase Public Sub CWindow() pLocalProc=AddressOf(LocalProc) ' Override Function/Sub pInitalize=AddressOf(Initalize)
Background=COLOR_3DFACE+1 End Sub Sub ~CWindow() End Sub
Sub Initalize(pThis As *CWindowBase) Dim hdc As HDC
hdc=GetDC(pThis->hwnd) ReleaseDC(pThis->hwnd,hdc) End Sub
Function LocalProc(hwnd As HWND,msg As DWord,wParam As WPARAM,lParam As LPARAM) As LRESULT Select Case msg Case Else LocalProc=DefWindowProc(hwnd,msg,wParam,lParam) End Select End Function End Class[/code][/hide] 良いのになぁなんて妄想して関数ポインタ使用しm
|