PowerBASIC Peer Support Forums
 

Go Back   PowerBASIC Peer Support Forums > User to user Discussions > Programming with Objects

Programming with Objects User to user discussions about programming with objects, including COM objects.

Reply
 
Thread Tools Display Modes
  #1  
Old Feb 25th, 2012, 12:22 PM
Larry Charlton Larry Charlton is offline
Member
 
Join Date: Jan 2011
Location: North Carolina USA
Posts: 1,321
Object Windows

Here's a minimal object based GUI. To use it you include winobj.inc. This exposes two functions and four interfaces.

Functions
  • GetApp - returns an instance of an iAppilcation object. In this case it happens to be a SimpleApplication object.
  • NewMessageBridge - returns an instance of an iMessageBridge. This is used to handle the transition from functions to objects.
Interfaces
  • iMessageBridge - Bridge from functions to objects
  • iMessage - An interface that any "Windowing" object must implement. It has one function, the control proc.
  • iSimpleApplication - A sample reference application that allows access to predefined top window and child window classes as well as the message handline procedure.
  • iApplication - The interface for any application.
winobj.inc
Code:
'Declare Function GetApp() Common As iApplication
'Declare Function NewMessageBridge(bridgeTo As iMessage, ByVal hWnd As Dword ) Common As iMessageBridge
'
'===========================================================================
'External interfaces
'===========================================================================
'Interface iMessageBridge Guid$("{3fa159d7-c691-4d6c-9104-5e034469097b}")
'  Inherit IUnknown
'  Method SetBridge( bridgeTo As iMessage, ByVal hWnd As Dword )
'  Method ClearBridge()
'End Interface
'
'Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
'  Inherit IUnknown
'  Method Proc( ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long, ByRef ret As Long) As Long
'End Interface
'
'Interface iSimpleApplication Guid$("{f0c50578-fb2d-4115-b615-f01838e22266}")
'  Inherit IUnknown
'  Property Get WindowClassname() As WString
'  Property Get ChildClassname() As WString
'  Property Get BridgeProc() As Dword
'End Interface
'
'Interface iApplication Guid$("{ffc3af54-b156-4137-8582-d4897cb66976}")
'  Inherit IUnknown
'  Property Get ActiveWindow() As Dword
'  Property Set ActiveWindow( value As Dword )
'  Method Run()
'End Interface
 
 
#Include Once "win32api.inc"
 
$$APP_CLASS_NAME = "lcApp"
$$CHILD_CLASS_NAME = "lcAppChild"
 
' Consider replacing this implementation with a dictionary of DWord, iMessage
' it will be slower but it will also be safer
Class cMessages Guid$("{3c255bde-47a5-48d6-bcdb-c18815782418}") Common
  Instance objs_() As iMessage
  Instance cnt_ As Long
 
  Class Method Create()
  End Method
  Class Method Destroy()
    Local i As Long
    For i=0 To cnt_
      objs_(i) = Nothing
    Next
    Erase objs_()
  End Method
 
  Interface iMessages Guid$("{b1078b6f-ee69-4464-bd1f-cdc5dc6c282a}")
    Inherit IUnknown
 
    Method Add( obj As iMessage, ByVal hWnd As Dword )
      Local i As Long
      Local ub As Long
 
      If IsFalse IsInterface( obj, iMessage ) Then Exit Method
      If IsWindow( hWnd ) = 0 Then Exit Method
 
      For i=0 To cnt_-1
        If IsFalse IsObject( objs_(i) ) Then Exit For
      Next
      ub = UBound( objs_() )
      If i = cnt_ And cnt_ >= ub Then
        ReDim Preserve objs_( ub+10 )
      End If
      objs_(i) = obj
      SetWindowLong( hWnd, %GWL_USERDATA, i )
      If i=cnt_ Then Incr cnt_
    End Method
 
    Method Remove( obj As iMessage, ByVal hWnd As Dword )
      Local idx As Long
      If IsFalse IsInterface( obj, iMessage ) Then Exit Method
      If IsFalse IsWindow( hWnd ) Then Exit Method
      idx = GetWindowLong( hWnd, %GWL_USERDATA )
      If idx>=0 And idx<cnt_ Then objs_(idx) = Nothing
      SetWindowLong( hWnd, %GWL_USERDATA, -1 )
    End Method
 
    Property Get Item( ByVal hWnd As Dword ) As iMessage
      Local idx As Long
      idx = GetWindowLong( hWnd, %GWL_USERDATA )
      If idx>=0 And idx<cnt_ Then
        Property = objs_(idx)
      End If
    End Property
  End Interface
End Class
 
Function NewMessageBridge(bridgeTo As iMessage, ByVal hWnd As Dword ) Common Export As iMessageBridge
  Local obj As iMessageBridge
  obj = Class "cMessageBridge"
  obj.SetBridge( bridgeTo, hWnd )
  Function = obj
End Function
 
Global globalBridges_ As iMessages
Global haveGlobalBridges_ As Long
 
Class cMessageBridge Guid$("{4c07094b-1bea-4150-85ce-273934df9e22}") Common
  Instance bridgeTo_ As iMessage
  Instance hWnd_ As Dword
  Instance defProc As Dword
 
  Class Method Create()
    If IsFalse haveGlobalBridges_ Then
      globalBridges_ = Class "cMessages"
      If IsInterface( globalBridges_, iMessages ) Then haveGlobalBridges_ = -1 Else End
    End If
  End Method
 
  Class Method Destroy()
    Dim bridge As iMessageBridge
    bridge = Me
    bridge.ClearBridge()
  End Method
 
  Interface iMessageBridge Guid$("{3fa159d7-c691-4d6c-9104-5e034469097b}")
    Inherit IUnknown
 
    Property Get HWnd() As Long
      Property = hWnd_
    End Property
    Method SetBridge( bridgeTo As iMessage, ByVal hWnd As Dword )
      Local bridge As iMessage
      Local mb As iMessageBridge
 
      mb = Me
 
      Call mb.ClearBridge()
 
      If IsFalse IsInterface( bridgeTo, iMessage ) Then Exit Method
      If IsFalse IsWindow( hWnd ) Then Exit Method
 
      hWnd_ = hWnd
 
      ' Sub-class if window didn't use our control proc
      defproc = GetWindowLong( hWnd, %GWL_WNDPROC)
      If defproc <> CodePtr(Bridge_ControlProc) Then
         SetWindowLong( hWnd, %GWL_WNDPROC, CodePtr(Bridge_ControlProc) )
      End If
 
      bridgeTo_ = bridgeTo
      bridge = Me
      globalBridges_.Add( bridge, hWnd )
    End Method
    Method ClearBridge()
      Local bridge As iMessage
 
      ' Reverse subclassing
      If IsInterface( bridgeTo_, iMessage ) Then
        If defproc And defproc <> CodePtr( Bridge_ControlProc ) Then
           SetWindowLong( hWnd_, %GWL_WNDPROC, defProc )
        End If
 
        bridge = Me
        globalBridges_.Remove( bridge, hWnd_ )
        bridgeTo_ = Nothing
      End If
    End Method
  End Interface
 
  ' Process messages
  Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
    Inherit IUnknown
 
    Method Proc( ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long, ByRef ret As Long) As Long
      If IsInterface( bridgeTo_, iMessage ) Then
        If IsFalse bridgeTo_.Proc( wMsg, wParam, lParam, ret ) Then
          If defProc And defProc <> CodePtr( Bridge_ControlProc ) Then
            ret = CallWindowProc( defProc, hWnd_, wMsg, wParam, lParam )
          Else
            ret = DefWindowProc( hWnd_, wMsg, wParam, lParam )
          End If
          Method = -1
        End If
      End If
    End Method
  End Interface
End Class
 
'==============================================================
' Bridge to class
'==============================================================
Function Bridge_ControlProc( ByVal hWnd As Dword, ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long) As Long
  Local obj As iMessage
  Local ret As Long
 
  If IsFalse haveGlobalBridges_ Then
    globalBridges_ = Class "cMessages"
    If IsInterface( globalBridges_, iMessages ) Then haveGlobalBridges_ = -1 Else End
  End If
  obj = globalBridges_.Item( hWnd )
  If IsInterface( obj, iMessage ) Then
    If obj.Proc( wMsg, wParam, lParam, ret ) Then
      Function = ret
      Exit Function
    End If
  End If
  Function = DefWindowProc( hWnd, wMsg, wParam, lParam )
End Function
 
'==============================================================
' Base application handling
'==============================================================
' Single instance class
Function GetApp() Common Export As iApplication
  Static app_ As iApplication
  Static haveApp_ As Long
 
  If IsFalse haveApp_ Then
    app_ = Class "cSimpleApplication"
    If Not IsObject( app_ ) Then
      End
    End If
    haveApp_ = -1
  End If
  Function = app_
End Function
 
Class cSimpleApplication Guid$("{17750903-c6c4-45cd-a9f6-19d6cfcca5fd}") Common
  Instance activeWindow_ As Dword
 
  Class Method Create()
    Call Me.RegisterClasses()
  End Method
 
  Interface iSimpleApplication Guid$("{f0c50578-fb2d-4115-b615-f01838e22266}")
    Inherit IUnknown
 
    Property Get WindowClassname() As WString
      Property = $$APP_CLASS_NAME
    End Property
    Property Get ChildClassname() As WString
      Property = $$CHILD_CLASS_NAME
    End Property
    Property Get BridgeProc() As Dword
      Property = CodePtr( Bridge_ControlProc )
    End Property
  End Interface
 
  Interface iApplication Guid$("{ffc3af54-b156-4137-8582-d4897cb66976}")
    Inherit IUnknown
 
    Property Get ActiveWindow() As Dword
      Property = activeWindow_
    End Property
    Property Set ActiveWindow( value As Dword )
      activeWindow_ = value
    End Property
 
    Method Run()
      Local msg As tagMSG
 
      Do While GetMessage( msg, %NULL, 0, 0 )>0
        If activeWindow_=0 Or IsDialogMessage( activeWindow_, msg ) = 0 Then
            TranslateMessage( msg )
            DispatchMessage( msg )
        End If
      Loop
    End Method
  End Interface
 
  Class Method RegisterClasses()
    Dim wc As WNDCLASSEX
    Dim className As WString
    Static gInit As Long
 
    If gInit Then Exit Method: ' Already initialized
    gInit=-1
    If GetClassInfoEx(%NULL, $$APP_CLASS_NAME, wc)=0 Then
      ' Register class for top window
      className = $$APP_CLASS_NAME
      wc.style = %CS_HREDRAW Or %CS_VREDRAW
      wc.cbsize = SizeOf(wc)
      wc.lpfnWndProc = CodePtr( Bridge_ControlProc )
      wc.cbClsExtra = 0
      wc.cbWndExtra = 0
      wc.hInstance = GetModuleHandle( ByVal 0 )
      wc.hIcon = LoadIcon( ByVal %NULL, ByVal %IDI_APPLICATION )
      wc.hCursor = LoadCursor(%NULL, ByVal %IDC_ARROW)
      wc.hbrBackground = %COLOR_3DFACE+1: '%COLOR_WINDOW
      wc.lpszMenuName =  0
      wc.lpszClassName = StrPtr(className)
      If RegisterClassEx( wc )=0 Then
        MsgBox "Application RegisterClass failed"
        End
      End If
    End If
    If GetClassInfoEx(%NULL, $$CHILD_CLASS_NAME, wc)=0 Then
      ' Register class for top window
      className = $$CHILD_CLASS_NAME
      wc.style = 0
      wc.cbsize = SizeOf(wc)
      wc.lpfnWndProc = CodePtr( Bridge_ControlProc )
      wc.cbClsExtra = 0
      wc.cbWndExtra = 0
      wc.hInstance = GetModuleHandle( ByVal 0 )
      wc.hIcon = LoadIcon( ByVal %NULL, ByVal %IDI_APPLICATION )
      wc.hCursor = LoadCursor(%NULL, ByVal %IDC_ARROW)
      wc.hbrBackground = %COLOR_WINDOW+1: ' %COLOR_3DFACE
      wc.lpszMenuName =  0
      wc.lpszClassName = StrPtr(className)
      If RegisterClassEx( wc )=0 Then
        MsgBox "Child RegisterClass failed"
        End
      End If
    End If
  End Method
End Class
Here's a sample application using the object windowing:
Test.bas
Code:
#Compile Exe
#Dim All
#Compiler PBWin 10
#Register All
 
%UNICODE = 1
#Include Once "win32api.inc"
#Include Once "winobj.inc"
 
#Include Once "MainWindow.inc"
#Include Once "Textbox.inc"
#Include Once "Support.inc"
 
Function PBMain () As Long
  Local app As iApplication
  app = GetApp()
 
  Local win As iMainWindow
  win = NewMainWindow( "Test Classes", %CW_USEDEFAULT, %CW_USEDEFAULT, 320, 200 )
  win.Show()
 
  NewEditNumeric( "1", win.HWnd, 10, 10, 100, 23 )
  NewEditNumeric( "2", win.HWnd, 10, 40, 100, 23 )
  NewEditNumeric( "3", win.HWnd, 10, 70, 100, 23 )
 
  app.Run()
End Function
And here's a couple of sample windows and some support routines.
MainWindow.inc
Code:
Function NewMainWindow( title As WString, ByVal l As Long, ByVal t As Long, ByVal w As Long, ByVal h As Long ) Common Export As iMainWindow
  Local obj As iMainWindow
  obj = Class "cMainWindow"
  obj.CreateWindow( title, l, t, w, h )
  Function = obj
End Function
 
Class cMainWindow Guid$("{a319a1ad-11b0-4edb-8166-f5232ae95c1a}") Common
  Instance hWnd_ As Dword:            ' Handle to window
  Instance bridge_ As iMessageBridge: ' Message bridge
 
  Interface iMainWindow Guid$("{69bd9b9a-61f9-4cd2-a803-bd6cc364fd00}")
    Inherit IUnknown
 
    Method Show()
      ShowWindow( hWnd_, %SW_ShowNormal )
      UpdateWindow( hWnd_ )
    End Method
 
    Method CreateWindow( title As WString, ByVal l As Long, ByVal t As Long, ByVal w As Long, ByVal h As Long )
      Local vmsg As iMessage: ' This function belongs in the Create method, but PB doesn't support parameterized constructors
      Local app As iSimpleApplication
      Local className As WString
 
      app = GetSimpleApp()
      className = app.WindowClassname()
 
      hWnd_ = CreateWindowEx( 0, ByVal StrPtr(className), ByVal StrPtr(title), %WS_OverlappedWindow Or %WS_ClipChildren, l, t, w, h, %NULL, %NULL, GetModuleHandle( ByVal 0 ), ByVal 0 )
      If IsWindow( hWnd_ ) = 0 Then End
 
      vmsg = Me
      bridge_ = NewMessageBridge( vmsg, hWnd_ ): ' hWnd needs to be valid before this is called
    End Method
    Property Get HWnd() As Dword
      Property = hWnd_
    End Property
  End Interface
 
  Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
    Inherit IUnknown
 
    Method Proc( ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long, ByRef ret As Long) As Long
      Method = -1: ' Default to handled, ret is already 0
      Select Case wMsg
        Case %WM_SysColorChange: Call Me.OnSysColorChange()
        Case %WM_EraseBkgnd: Exit Method
        Case %WM_MouseActivate:   Method = Me.OnActivate( Mak(Dword, %WA_ACTIVE, 0 )): Exit Method
        Case %WM_Activate:        Call Me.OnActivate( wParam ): Exit Method
        Case %WM_Destroy:         PostQuitMessage(0): Exit Method
      End Select
      Method = 0: ' If we exit this way, we didn't handle message
    End Method
  End Interface
 
  Class Method OnActivate( ByVal wParam As Long ) As Long
    Local app As iApplication
    app = GetApp()
    app.ActiveWindow = IIf&(wParam, hWnd_, 0 )
    If Lo(Word, wParam) <> %WA_INACTIVE Then SetFocus( hWnd_ )
    Method = %MA_ACTIVATE
  End Method
 
  Class Method OnSysColorChange()
    Call EnumChildWindows( hWnd_,  CodePtr( MainWindow_SysColorChange ), 0 ): ' Ensure child controls know of change
  End Method
End Class
 
Function MainWindow_SysColorChange(ByVal hWnd As Dword, ByVal lParam As Long ) As Long
  SendMessage( hWnd, %WM_SYSCOLORCHANGE, 0, 0 )
  Function = %TRUE
End Function
Textbox.inc
Code:
Function NewEditNumeric( title As WString, ByVal hParent As Dword, ByVal l As Long, ByVal t As Long, ByVal w As Long, ByVal h As Long ) Common Export As iMainWindow
  Local obj As iEditNumeric
  obj = Class "cEditNumeric"
  obj.CreateWindow( title, hParent, l, t, w, h )
  Function = obj
End Function
 
Class cEditNumeric Guid$("{30CE371E-4115-4FF2-94CE-E0AA6704252F}") Common
  Instance hWnd_ As Dword:            ' Handle to window
  Instance bridge_ As iMessageBridge: ' Message bridge
 
  Interface iEditNumeric Guid$("{75c4658b-57fb-4979-83a2-2c6cceddc6d6}")
    Inherit IUnknown
    Method CreateWindow( text As WString, hParent As Dword, ByVal l As Long, ByVal t As Long, ByVal w As Long, ByVal h As Long )
      Dim vmsg As iMessage: ' This function belongs in the Create method, but PB doesn't support parameterized constructors
      Local vStyle As Dword
 
      vStyle = %WS_Child Or %WS_Visible Or %WS_TabStop Or %WS_Border
 
      hWnd_ = CreateWindowEx( 0, "EDIT", ByVal StrPtr(Text), vStyle, l, t, w, h, hParent, %NULL, GetModuleHandle( ByVal 0 ), ByVal 0 )
 
      vmsg = Me
      bridge_ = NewMessageBridge( vmsg, hWnd_): ' hWnd needs to be valid before this is called
    End Method
 
    Property Get Text() As WString
      Local ln As Long
      Local buf As WStringZ*2
      ln = GetWindowText( hWnd_, buf, 1 )
      Local tx As WString
      tx = Space$(ln+1)
      GetWindowText( hWnd_, ByVal StrPtr(tx), ln )
      Property = tx
    End Property
    Property Set Text( value As WString )
      SetWindowText( hWnd_, ByVal StrPtr(value) )
    End Property
 
    Method Move(ByVal l As Long, ByVal t As Long, ByVal w As Long, ByVal h As Long )
      MoveWindow( hWnd_, l, t, w, h, %FALSE )
    End Method
  End Interface
 
  Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
    Inherit IUnknown
 
    Method Proc( ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long, ByRef ret As Long) As Long
      Method = -1: ' Default to handled, ret is already 0
      Select Case wMsg
        Case %WM_Char: If InStr("0123456789" +$Bs, Chr$(wParam))=0 Then Exit Method
      End Select
      Method = 0: ' If we exit this way, we didn't handle message
    End Method
  End Interface
End Class
Support.inc
Code:
Function GetSimpleApp() As iSimpleApplication
Dim app As iApplication
Dim simp As iSimpleApplication
app = GetApp()

simp = app
Function = simp
End Function

Function SystemError() Common Export As WString
Local errorCode As Dword
Static buffer As WStringZ * 512
errorCode = GetLastError()
FormatMessage( %FORMAT_MESSAGE_FROM_SYSTEM, ByVal %NULL, errorCode, %NULL, buffer, SizeOf(buffer), ByVal %NULL )
Function = buffer
End Function
__________________
LarryC
Website
Sometimes life's a dream, sometimes it's a scream
Reply With Quote
  #2  
Old Feb 25th, 2012, 03:01 PM
John Montenigro John Montenigro is offline
Member
 
Join Date: Nov 2002
Location: New Jersey, USA
Posts: 1,029
Quote:
In this case it happens to be a SimpleApplication object
OK, this has got to be the year's dumbest question: what is the source of information that tells me such things as a "SimpleApplication object" exists?

I'm trying to make the transition to Objects, and I don't have a starting point.

Can you direct me to a book or website that reveals where all these object structures live, what they're for, and maybe even how to use them? Like when I left DOS, people pointed me to Win32 books and the SDK.

I appreciate any guidance!

Also, although it may take me a weekend, I will play with your code and learn from it. Thank you!

-John
Reply With Quote
  #3  
Old Feb 25th, 2012, 04:14 PM
Larry Charlton Larry Charlton is offline
Member
 
Join Date: Jan 2011
Location: North Carolina USA
Posts: 1,321
Source code . At the top of winobj.inc there comments listing the functions and interfaces that I provided to use externally. Documentation, still a dream, might be a scream...

Depending on your needs you could also just put everything in the iApplication interface. A better organization might have been to put the iApplication / iSimpleApplication interfaces at the top of the source code since they would like change depending on the application needs.

Keep in mind that PB only natively provides a handful of interfaces and objects. The PB objects/interfaces can be found in the PB help. see:
INTERFACE, Built-in Interfaces
Object
Power Collection (Most of the collections available on this page)
POWERARRAY
PowerThread
PowerTime

Might be missing a few. The rest of the interfaces / objects you would be writting.
__________________
LarryC
Website
Sometimes life's a dream, sometimes it's a scream
Reply With Quote
  #4  
Old Mar 5th, 2012, 11:27 AM
Larry Charlton Larry Charlton is offline
Member
 
Join Date: Jan 2011
Location: North Carolina USA
Posts: 1,321
Updated winobj to use a PowerCollection to map hWnd to classes. It's slower but safer than using USERDATA. Apparently the common control IPAddress uses USERDATA, so if you try to stuff and address in there, things go BOOM.

winobj.inc
Code:
'Declare Function GetApp() Common As iApplication
'Declare Function NewMessageBridge(bridgeTo As iMessage, ByVal hWnd As Dword ) Common As iMessageBridge
'
'===========================================================================
'External interfaces
'===========================================================================
'Interface iMessageBridge Guid$("{3fa159d7-c691-4d6c-9104-5e034469097b}")
'  Inherit IUnknown
'
'  Property Get HWnd() As Long
'  Method SetBridge( bridgeTo As iMessage, ByVal hWnd As Dword )
'  Method ClearBridge()
'End Interface
'
'Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
'  Inherit IUnknown
'  Method Proc( ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long, ByRef ret As Long) As Long
'End Interface
'
'Interface iSimpleApplication Guid$("{f0c50578-fb2d-4115-b615-f01838e22266}")
'  Inherit IUnknown
'  Property Get WindowClassname() As WString
'  Property Get ChildClassname() As WString
'  Property Get BridgeProc() As Dword
'End Interface
'
'Interface iApplication Guid$("{ffc3af54-b156-4137-8582-d4897cb66976}")
'  Inherit IUnknown
'  Property Get ActiveWindow() As Dword
'  Property Set ActiveWindow( value As Dword )
'  Method Run()
'End Interface
 
 
#Include Once "win32api.inc"
 
$$APP_CLASS_NAME = "lcApp"
$$CHILD_CLASS_NAME = "lcAppChild"
 
' Consider replacing this implementation with a dictionary of DWord, iMessage
' it will be slower but it will also be safer
Global msgMap_ As IPowerCollection
Global haveMsgMap_ As Long
 
Function NewMessageBridge(bridgeTo As iMessage, ByVal hWnd As Dword ) Common Export As iMessageBridge
  Local obj As iMessageBridge
  obj = Class "cMessageBridge"
  obj.SetBridge( bridgeTo, hWnd )
  Function = obj
End Function
 
Class cMessageBridge Guid$("{4c07094b-1bea-4150-85ce-273934df9e22}") Common
  Instance bridgeTo_ As iMessage
  Instance handle_ As Dword
  Instance defProc As Dword
 
  Class Method Create()
    If IsFalse haveMsgMap_ Then
      msgMap_ = Class "PowerCollection"
      If IsInterface( msgMap_, IPowerCollection ) Then haveMsgMap_ = -1 Else End
    End If
  End Method
 
  Class Method Destroy()
    Dim bridge As iMessageBridge
    bridge = Me
    bridge.ClearBridge()
  End Method
 
  Interface iMessageBridge Guid$("{3fa159d7-c691-4d6c-9104-5e034469097b}")
    Inherit IUnknown
 
    Property Get Handle() As Long
      Property = handle_
    End Property
    Method SetBridge( bridgeTo As iMessage, ByVal hWnd As Dword )
      Local bridge As iMessage
      Local mb As iMessageBridge
 
      mb = Me
 
      Call mb.ClearBridge()
 
      If IsFalse IsInterface( bridgeTo, iMessage ) Then Exit Method
      If IsFalse IsWindow( hWnd ) Then Exit Method
 
      handle_ = hWnd
 
      ' Sub-class if window didn't use our control proc
      defproc = GetWindowLong( hWnd, %GWL_WNDPROC)
      SetWindowLong( hWnd, %GWL_WNDPROC, CodePtr(Bridge_ControlProc) )
 
      bridgeTo_ = bridgeTo
      bridge = Me
      Local key As WString
      key = Format$( hWnd, "0")
      msgMap_.Add( key, bridge )
    End Method
    Method ClearBridge()
      Local bridge As iMessage
 
      ' Reverse subclassing
      If IsInterface( bridgeTo_, iMessage ) Then
        SetWindowLong( handle_, %GWL_WNDPROC, defProc )
 
        bridge = Me
        Local key As WString
        key = Format$( handle_, "0")
        msgMap_.Remove( key )
        bridgeTo_ = Nothing
      End If
    End Method
  End Interface
 
  ' Process messages
  Interface iMessage Guid$("{2e0e23cf-6e19-4a88-a33c-2cca8397778f}")
    Inherit IUnknown
 
    Method Proc( ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long, ByRef ret As Long) As Long
      If IsInterface( bridgeTo_, iMessage ) Then
        If IsFalse bridgeTo_.Proc( wMsg, wParam, lParam, ret ) Then
          If defProc And defProc <> CodePtr( Bridge_ControlProc ) Then
            ret = CallWindowProc( defProc, handle_, wMsg, wParam, lParam )
          Else
            ret = DefWindowProc( handle_, wMsg, wParam, lParam )
          End If
          Method = -1
        End If
      End If
    End Method
  End Interface
End Class
 
'==============================================================
' Bridge to class
'==============================================================
Function Bridge_ControlProc( ByVal hWnd As Dword, ByVal wMsg As Dword, ByVal wParam As Long, ByVal lParam As Long) As Long
  Local obj As iMessage
  Local ret As Long
  Local v As Variant
 
  Local key As WString
  key = Format$( hWnd, "0")
  v = msgMap_.Item( key )
  obj = v
  If IsInterface( obj, iMessage ) Then
    If obj.Proc( wMsg, wParam, lParam, ret ) Then
      Function = ret
      Exit Function
    End If
  End If
  Function = DefWindowProc( hWnd, wMsg, wParam, lParam )
End Function
 
'==============================================================
' Base application handling
'==============================================================
' Single instance class
Function GetApp() Common Export As iApplication
  Static app_ As iApplication
  Static haveApp_ As Long
 
  If IsFalse haveApp_ Then
    If IsFalse haveMsgMap_ Then
      msgMap_ = Class "PowerCollection"
      If IsInterface( msgMap_, IPowerCollection ) Then haveMsgMap_ = -1 Else End
    End If
 
    app_ = Class "cSimpleApplication"
    If Not IsObject( app_ ) Then
      End
    End If
    haveApp_ = -1
  End If
  Function = app_
End Function
 
Class cSimpleApplication Guid$("{17750903-c6c4-45cd-a9f6-19d6cfcca5fd}") Common
  Instance activeWindow_ As Dword
 
  Class Method Create()
    Call Me.RegisterClasses()
  End Method
 
  Interface iSimpleApplication Guid$("{f0c50578-fb2d-4115-b615-f01838e22266}")
    Inherit IUnknown
 
    Property Get WindowClassname() As WString
      Property = $$APP_CLASS_NAME
    End Property
    Property Get ChildClassname() As WString
      Property = $$CHILD_CLASS_NAME
    End Property
    Property Get BridgeProc() As Dword
      Property = CodePtr( Bridge_ControlProc )
    End Property
  End Interface
 
  Interface iApplication Guid$("{ffc3af54-b156-4137-8582-d4897cb66976}")
    Inherit IUnknown
 
    Property Get ActiveWindow() As Dword
      Property = activeWindow_
    End Property
    Property Set ActiveWindow( value As Dword )
      activeWindow_ = value
    End Property
 
    Method Run()
      Local msg As tagMSG
 
      Do While GetMessage( msg, %NULL, 0, 0 )>0
        If activeWindow_=0 Or IsDialogMessage( activeWindow_, msg ) = 0 Then
            TranslateMessage( msg )
            DispatchMessage( msg )
        End If
      Loop
    End Method
  End Interface
 
  Class Method RegisterClasses()
    Dim wc As WNDCLASSEX
    Dim className As WString
    Static gInit As Long
 
    If gInit Then Exit Method: ' Already initialized
    gInit=-1
    If GetClassInfoEx(%NULL, $$APP_CLASS_NAME, wc)=0 Then
      ' Register class for top window
      className = $$APP_CLASS_NAME
      wc.style = %CS_HREDRAW Or %CS_VREDRAW
      wc.cbsize = SizeOf(wc)
      wc.lpfnWndProc = CodePtr( Bridge_ControlProc )
      wc.cbClsExtra = 0
      wc.cbWndExtra = 0
      wc.hInstance = GetModuleHandle( ByVal 0 )
      wc.hIcon = LoadIcon( ByVal %NULL, ByVal %IDI_APPLICATION )
      wc.hCursor = LoadCursor(%NULL, ByVal %IDC_ARROW)
      wc.hbrBackground = %COLOR_3DFACE+1: '%COLOR_WINDOW
      wc.lpszMenuName =  0
      wc.lpszClassName = StrPtr(className)
      If RegisterClassEx( wc )=0 Then
        MsgBox "Application RegisterClass failed"
        End
      End If
    End If
    If GetClassInfoEx(%NULL, $$CHILD_CLASS_NAME, wc)=0 Then
      ' Register class for top window
      className = $$CHILD_CLASS_NAME
      wc.style = 0
      wc.cbsize = SizeOf(wc)
      wc.lpfnWndProc = CodePtr( Bridge_ControlProc )
      wc.cbClsExtra = 0
      wc.cbWndExtra = 0
      wc.hInstance = GetModuleHandle( ByVal 0 )
      wc.hIcon = LoadIcon( ByVal %NULL, ByVal %IDI_APPLICATION )
      wc.hCursor = LoadCursor(%NULL, ByVal %IDC_ARROW)
      wc.hbrBackground = %COLOR_WINDOW+1: ' %COLOR_3DFACE
      wc.lpszMenuName =  0
      wc.lpszClassName = StrPtr(className)
      If RegisterClassEx( wc )=0 Then
        MsgBox "Child RegisterClass failed"
        End
      End If
    End If
  End Method
End Class
__________________
LarryC
Website
Sometimes life's a dream, sometimes it's a scream
Reply With Quote
Reply

Thread Tools
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump


All times are GMT -4. The time now is 01:59 AM.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2014, Jelsoft Enterprises Ltd.
Copyright 1999-2011 PowerBASIC, Inc. All Rights Reserved.
Error in my_thread_global_end(): 1 threads didn't exit