A very valuable source code!

zhaozj2021-02-12  158

'New ActiveX DLL project, name smartsubclasslib

'The following code is placed in the standard module, the module name msmartsubclass

'------------------------------------- ---

'Module Msmartsubclass

'

'Version ... 1.0

'Date ... 24 April 2001

'

'CopyRight (C) 2001 Andr 閟 Pons (andres@vbsmart.com)

'------------------------------------- ---

'API Declarations:

Option expedition

Public const SSC_OLDPROC = "SSC_OLDPROC"

Public const ssc_objaddr = "ssc_objaddr"

Private Declare Function GetProp Lib "User32" Alias ​​"getpropa" (_ _

Byval hwnd as long, _

Byval lpstring as string) As long

Private Declare Sub CopyMemory LIB "kernel32" Alias ​​"RTLMOVEMEMORY" (_

Destination as any, _

Source as any, _

BYVAL Length As long

'

'Function StartSubclassWindowProc ()

'

'This is the first windowProc That Receives Messages

'for all subclassed windows.

'The aim of this function is to just collect the message

'and deliver it to the right smartsubclass instance.

'

Public Function SmartSubclassWindowProc (_

Byval hwnd as long, _

Byval umsg as long, _

Byval wparam as long, _

BYVAL LPARAM AS Long AS Long

Dim Lret As Long

Dim Osmartsubclass as SmartSubclass

'Get the memory address of the class instance ...

Lret = getprop (hwnd, ssc_objaddr)

IF lret <> 0 THEN

'Osmartsubclass Will Point To The Class Instance

'WITHOUT INCREMENTING THE CLASS REFERENCE COUNTER ...

Copymemory Osmartsubclass, Lret, 4

'Send the message to the class instance ...

SmartSubclassWindowProc = Osmartsubclass.WindowProc (hwnd, _

UMSG, WPARAM, LPARAM)

'Remove The Address from Memory ...

CopyMemory Osmartsubclass, 0 &, 4END IF

END FUNCTION

'The following code is placed in the class module, module name smartsubclass

'------------------------------------- ---

'Class SmartSubclass

'

'Version ... 1.0

'Date ... 24 April 2001

'

'CopyRight (C) 2001 Andr 閟 Pons (andres@vbsmart.com)

'------------------------------------- ---

Option expedition

'Public Event:

Public Event NewMessage (_

Byval hwnd as long, _

Byref umsg as long, _

Byref wparam as long, _

Byref lParam as long, _

Byref Cancel as Boolean)

'Private Variables:

Private m_hwnds () as long

'API Declarations:

Private const GWL_WndProc = (-4)

Private Declare Function GetWindowlong Lib "User32" Alias ​​"getWindowlonga" (_

Byval hwnd as long, _

BYVAL NINDEX AS Long) As long

Private declare function setwindowlong lib "user32" alias "setwindowlonga" (_

Byval hwnd as long, _

Byval Nindex as long, _

BYVAL DWNEWLONG AS Long AS Long

Private DecLare Function CallWindowProc Lib "User32" Alias ​​"CallWindowProca" (_

BYVAL LPPREVWNDFUNC AS Long, _

Byval hwnd as long, _

Byval msg as long, _

Byval wparam as long, _

BYVAL LPARAM AS Long AS Long

Private Declare Function GetProp Lib "User32" Alias ​​"getpropa" (_ _

Byval hwnd as long, _

Byval lpstring as string) As long

Private Declare Function SetProp Lib "User32" Alias ​​"setpropa" (_

Byval hwnd as long, _

Byval LPSTRING As String, _

BYVAL HDATA AS long) As long

Private Declare Function RemoveProp Lib "User32" Alias ​​"RemovePropa" (_

Byval hwnd as long, _

Byval lpstring as string) As long

Private Declare Function Iswindow Lib "User32" (_BYVAL HWND As Long) As long

'

'Function SubclasshWnd

'

'This is the core function in this class.

'You can use it to iboth subclass and unsubclass a window.

'Once a window is Subclassed The Event NewMessage Will

'be raised every time a message issent to the window.

'

Public Function SubclasshWnd (Byval Hwnd As Long, _

BYVAL BSUBCLASS as boolean) AS Boolean

Dim Lret As Long

LRET = 0

'Make Sure That Hwnd Is A Valid Window Handler ...

IF iswindow (hwnd) THEN

IF Bsubclass Then

'WE Are Subclassing a Window ...

'Make Sure That The Window Wasn't Already Subclassed ...

IF getProp (hwnd, ssc_oldproc) = 0 THEN

'Now we subclass the window by Changing ITS WindowProc

Lret = setWindowlong (hwnd, gwl_wndproc, _

Addressof SmartSubclassWindowProc

'Check if We've Managed to Subclass ...

IF lret <> 0 THEN

'Store the old windowProc and the memory

'Address of this class ...

SetProp Hwnd, SSC_OLDPROC, LRET

SetProp Hwnd, SSC_Objaddr, Objptr (ME)

'Add the window to an internal list of

'Subclassed Windows ...

Paddhwndtolist hwnd

END IF

END IF

Else

'We are unsubclassing a window ...

'Get the old windowproc ...

Lret = getProp (hwnd, ssc_oldproc)

IF lret <> 0 THEN

'Unsubclass the window ...

Lret = setWindowlong (hwnd, gwl_wndproc, lret)

END IF

'Remove Any Extra Information ...

REMOVEPROP HWND, SSC_OLDPROC

REMOVEPROP HWND, SSC_OBJADDR

'Remove the window from the internal list ...

PremovehWndFromList Hwnd

END IF

Else

'Ness hwnd is not a valid window,

'Make Sure That There ISn't Stored Garbage ...

REMOVEPROP HWND, SSC_OLDPROCREMOVEPROP HWND, SSC_OBJADDR

PremovehWndFromList Hwnd

END IF

SubclasshWnd = (LRET <> 0)

END FUNCTION

'

'Function WindowProc

'

'This is the link between the windowproc and the class instance.

'Every Time SmartSubclassWindowProc Receives A Window Message,

'it will post it to the right class instance.

'

Friend Function WindowProc (_

Byval hwnd as long, _

Byval umsg as long, _

Byval wparam as long, _

BYVAL LPARAM AS Long AS Long

Dim Lret As Long

DIM BCANCEL AS BOOLEAN

BCANCEL = FALSE

Windowproc = 0

'Raise The Event NewMessage ...

'This Will Tell The Owner of the class variable what A

'new message is ready to be processed.

'The owner will be aable to cancel the message by setting

'The Variable Bcancel to True.

RaiseEvent NewMessage (HWND, UMSG, WPARAM, LPARAM, BCANCEL)

'If The Event hasn't been caledled by the Owner

'we need to send it to the Original WindowProc

IF not bcancel kil

Lret = getProp (hwnd, ssc_oldproc)

IF lret <> 0 THEN

'Send the message to the Original WindowProc ...

WindowProc = CallWindowProc (LRET, HWND, UMSG, WPARAM, LPARAM)

END IF

END IF

END FUNCTION

'

'Every Instance of The Class Mantains An Internal

'List of subclassed windows.

'

Private sub coplass_initialize ()

Redim m_hwnds (0) As long

End Sub

'

'When The Class Terminates It Makes Sure That

'there is no remainig subclassed window.

'

Private sub coplass_terminate ()

DIM I as long

For i = ubound (m_hwnds) to 1 Step -1

IF m_hwnds (i)> 0 THEN

SubclasshWnd M_HWNDS (I), FALSE

END IF

Next i

End Sub

'

'Private function pfindhwndinlist ()

'

'This functions search for a specific window

'in its inTernal List. if it doesn't find the

'Window It Returns 0.

'

Private function PfindhWndinList (Byval Hwnd As Long) As long

DIM I as long

DIM LPOS As Long

LPOS = 0

For i = 1 to ubound (m_hwnds)

IF m_hwnds (i) = hwnd and m_hwnds (i)> 0 THEN

LPOS = i

EXIT for

END IF

Next i

PfindhWndinList = LPOS

END FUNCTION

'

'Private Sub Paddhwndtolist ()

'

'This Procedure Adds A Window Handle To The Internal List ...

'

Private sub paddhwndtolist (byval hwnd as ring)

DIM LPOS As Long

IF pfindhwndinlist (hwnd) = 0 THEN

LPOS = PfindnextPositionavailableinList

IF LPOS <> 0 THEN

m_hwnds (lpos) = hwnd

Else

LPOS = ubound (m_hwnds) 1

Redim preserve m_hwnds (lpos) as long

m_hwnds (lpos) = hwnd

END IF

END IF

End Sub

'

'Private sub premovehwndfromlist ()

'

'This Procedure Removes a Window Handle from the Internal List ...

'

Private sub premovehwndfromlist (byval hwnd as ring)

DIM LPOS As Long

LPOS = PfindhWndinList (hwnd)

IF LPOS <> 0 THEN

If lpos = ubound (m_hwnds) THEN

Redim preserve m_hwnds (LPOS - 1) AS Long

Else

m_hwnds (lpos) = -1

END IF

END IF

End Sub

'

'Private function pfindnextpositionavailableinlist ()

'

'This functions search for an "empty" entry in the

'Internal List of window handles. When an entry is

'Removed ITS is Marked as Empty by Setting ITS Value To -1.

'

'Ness the Function Returns 0.

'

Private function pfindnextpositionavailableinlist () as long

DIM I as long

DIM LPOS As Long

LPOS = 0

For i = 1 to ubound (m_hwnds) if m_hwnds (i) <= 0 THEN

LPOS = i

EXIT for

END IF

Next I

PfindnextPositionavailableinList = LPOS

END FUNCTION