Option Explicit
Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
Private m_bDown As Boolean
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
m_bDown = True
UserControl_MouseMove Button, Shift, X, Y
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
m_bDown = False
UserControl_MouseMove Button, Shift, X, Y
End Sub
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
UserControl_MouseMove Button, Shift, Label1.Left + X, Label1.Top + Y
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo EH
If X >= 0 And X <= ScaleWidth And Y >= 0 And Y <= ScaleHeight Then
Label1.Caption = IIf(m_bDown, "Down", "Hot")
Else
Label1.Caption = IIf(m_bDown, "Down Outside", "Normal")
End If
If X >= 0 And X <= ScaleWidth And Y >= 0 And Y <= ScaleHeight Or m_bDown <> 0 Then
If Not pvGetCapture() Then
pvSetCapture True
End If
Else
If pvGetCapture() Then
pvSetCapture False
End If
End If
Exit Sub
EH:
Debug.Print "UserControl_MouseMove "; Err.Description; Err.Source
End Sub
Private Function pvGetCapture() As Boolean
Const IDX_GetCapture As Long = 19
If UserControl.hWnd = 0 Then
If DispCallByVtbl(GetInPlaceSiteWindowless(Me), IDX_GetCapture) = 0 Then ' S_OK
pvGetCapture = True
End If
ElseIf GetCapture() = UserControl.hWnd Then
pvGetCapture = True
End If
End Function
Private Sub pvSetCapture(ByVal bValue As Boolean)
Const IDX_SetCapture As Long = 20
If UserControl.hWnd = 0 Then
DispCallByVtbl GetInPlaceSiteWindowless(Me), IDX_SetCapture, CLng(-bValue)
Else
If bValue Then
Call SetCapture(UserControl.hWnd)
Else
Call ReleaseCapture
End If
End If
End Sub
Private Function GetInPlaceSiteWindowless(pCtl As IUnknown) As IUnknown
Const E_NOINTERFACE As Long = &H80004002
Const IDX_QueryInterface As Long = 0
Const IDX_GetClientSite As Long = 4
Dim aGuid(0 To 3) As Long
Dim pOleObject As IUnknown
Dim pOleClientSite As IUnknown
Dim hResult As Long
aGuid(0) = &H112: aGuid(2) = &HC0: aGuid(3) = &H46000000 ' IID_IOleObject
hResult = DispCallByVtbl(pCtl, IDX_QueryInterface, VarPtr(aGuid(0)), VarPtr(pOleObject))
If hResult < 0 Or pOleObject Is Nothing Then
Err.Raise IIf(hResult < 0, hResult, E_NOINTERFACE), "IUnknown.QueryInterface(IID_IOleObject)"
End If
hResult = DispCallByVtbl(pOleObject, IDX_GetClientSite, VarPtr(pOleClientSite))
If hResult < 0 Or pOleClientSite Is Nothing Then
Err.Raise IIf(hResult < 0, hResult, E_NOINTERFACE), "IOleObject.GetClientSite"
End If
aGuid(0) = &H922EADA0: aGuid(1) = &H11CF3424 ' IID_IOleInPlaceSiteWindowless
aGuid(2) = &HAA0070B6: aGuid(3) = &HD8D64C00
hResult = DispCallByVtbl(pOleClientSite, IDX_QueryInterface, VarPtr(aGuid(0)), VarPtr(GetInPlaceSiteWindowless))
If hResult < 0 Or GetInPlaceSiteWindowless Is Nothing Then
Err.Raise IIf(hResult < 0, hResult, E_NOINTERFACE), "IUnknown.QueryInterface(IID_IOleInPlaceSiteWindowless)"
End If
End Function
Private Function DispCallByVtbl(pUnk As IUnknown, ByVal lIndex As Long, ParamArray A() As Variant) As Variant
Const CC_STDCALL As Long = 4
Dim lIdx As Long
Dim vParam() As Variant
Dim vType(0 To 63) As Integer
Dim vPtr(0 To 63) As Long
Dim hResult As Long
vParam = A
For lIdx = 0 To UBound(vParam)
vType(lIdx) = VarType(vParam(lIdx))
vPtr(lIdx) = VarPtr(vParam(lIdx))
Next
hResult = DispCallFunc(ObjPtr(pUnk), lIndex * 4, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByVtbl)
If hResult < 0 Then
Err.Raise hResult, "DispCallFunc"
End If
End Function
