Option Explicit
Option Compare Text
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) 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 GetCapture Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Const CF_BITMAP = 2
Private Const CF_PALETTE = 9
Private Const CF_ENHMETAFILE = 14
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private WithEvents pFrame As MSForms.Frame
Private pFrameParent As Object
Private pHwnd As Long
Private pEnableEvents As Boolean
Private pEnableCapture As Boolean
Private pDefaultPicture As stdole.Picture
Private pMouseEnterPicture As stdole.Picture
Private pMouseDownPicture As stdole.Picture
Private pMouseExitPicture As stdole.Picture
Private pIsToggleButton As Boolean
Private pToggled As Boolean
Private pShowHoverBorder As Boolean
Private Sub Class_Initialize()
pEnableCapture = True
pEnableEvents = True
End Sub
Private Sub pFrame_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim PicArg As stdole.Picture
Set PicArg = pMouseDownPicture
If pEnableEvents Then Call pFrameParent.FHT_MouseDown(Me, PicArg, Button, Shift, X, Y)
Call SetPicture(pMouseDownPicture, PicArg)
pToggled = Not pToggled
Toggled = pToggled
End Sub
Private Sub pFrame_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' Dim PicArg As stdole.Picture
' Set PicArg = pMouseEnterPicture
' If pEnableEvents Then Call pFrameParent.FHT_MouseUp(Me, PicArg, Button, Shift, X, Y)
' Call SetPicture(pMouseEnterPicture, PicArg)
End Sub
Private Sub pFrame_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim PicArg As stdole.Picture
If hwnd = 0 Then pHwnd = GetFrameHwnd()
If (X < 0) Or (Y < 0) Or (X > pFrame.Width) Or (Y > pFrame.Height) Then
ReleaseCapture
Set PicArg = pMouseExitPicture
If pEnableEvents Then Call pFrameParent.FHT_MouseExit(Me, PicArg)
Call SetPicture(pMouseExitPicture, PicArg)
ElseIf GetCapture() <> hwnd Then
SetCapture hwnd
Set PicArg = pMouseEnterPicture
If pEnableEvents Then Call pFrameParent.FHT_MouseEnter(Me, PicArg)
Call SetPicture(pMouseEnterPicture, PicArg)
If pShowHoverBorder Then pFrame.BorderStyle = fmBorderStyleSingle
End If
End Sub
Private Sub SetPicture(DefaultEventPic As stdole.Picture, OverRideDefaultEventPic As stdole.Picture)
On Error Resume Next
If pEnableCapture Then
If (OverRideDefaultEventPic.handle = DefaultEventPic.handle) Then
If (Not DefaultEventPic Is Nothing) Then
pFrame.Picture = DefaultEventPic
End If
End If
Else
pFrame.Picture = OverRideDefaultEventPic
End If
End Sub
Private Function GetFrameHwnd() As Long
Dim PT As POINTAPI
GetCursorPos PT
GetFrameHwnd = WindowFromPoint(PT.X, PT.Y)
End Function
Private Sub HotTrackCommon(Frame As MSForms.Frame, _
DefaultPicture As stdole.Picture, _
MouseEnterPicture As stdole.Picture, _
MouseDownPicture As stdole.Picture, _
MouseExitPicture As stdole.Picture)
Set pFrameParent = Frame.Parent
Set pFrame = Frame
Set pDefaultPicture = DefaultPicture
Set pMouseEnterPicture = MouseEnterPicture
Set pMouseDownPicture = MouseDownPicture
Set pMouseExitPicture = MouseExitPicture
Set pFrame.Picture = DefaultPicture
End Sub
Friend Sub SetHotTrackFromRange(Frame As MSForms.Frame, _
DefaultPicture As Range, _
MouseEnterPicture As Range, _
MouseDownPicture As Range, _
MouseExitPicture As Range)
Call HotTrackCommon(Frame, _
PictureFromRange(DefaultPicture), _
PictureFromRange(MouseEnterPicture), _
PictureFromRange(MouseDownPicture), _
PictureFromRange(MouseExitPicture))
End Sub
Friend Sub SetHotTrackFromFile(Frame As MSForms.Frame, _
DefaultPicture As String, _
MouseEnterPicture As String, _
MouseDownPicture As String, _
MouseExitPicture As String)
Call HotTrackCommon(Frame, _
LoadPicture(DefaultPicture), _
LoadPicture(MouseEnterPicture), _
LoadPicture(MouseDownPicture), _
LoadPicture(MouseExitPicture))
End Sub
Friend Sub SetHotTrackDirect(Frame As MSForms.Frame, _
DefaultPicture As stdole.Picture, _
MouseEnterPicture As stdole.Picture, _
MouseDownPicture As stdole.Picture, _
MouseExitPicture As stdole.Picture)
Call HotTrackCommon(Frame, DefaultPicture, MouseEnterPicture, MouseDownPicture, MouseExitPicture)
End Sub
Friend Sub SetHotTrackEvents(Frame As MSForms.Frame)
Set pFrameParent = Frame.Parent
Set pFrame = Frame
End Sub
Friend Property Get hwnd() As Long
hwnd = pHwnd
End Property
Friend Property Get Frame() As MSForms.Frame
Set Frame = pFrame
End Property
Friend Property Set Frame(ByVal vNewValue As MSForms.Frame)
Set pFrame = vNewValue
End Property
Friend Property Get IsToggleButton() As Boolean
IsToggleButton = pIsToggleButton
End Property
Friend Property Let IsToggleButton(ByVal vNewValue As Boolean)
pIsToggleButton = vNewValue
Toggled = pToggled
End Property
Friend Property Get Toggled() As Boolean
If Not IsToggleButton Then
Toggled = False
Else
Toggled = pToggled
End If
End Property
Friend Property Let Toggled(ByVal vNewValue As Boolean)
If Not IsToggleButton Then
pToggled = False
Else
If vNewValue = True Then
pFrame.SpecialEffect = fmSpecialEffectSunken
Else
pFrame.SpecialEffect = fmSpecialEffectRaised
End If
End If
End Property
Friend Property Get EnableEvents() As Boolean
EnableEvents = pEnableEvents
End Property
Friend Property Let EnableEvents(ByVal vNewValue As Boolean)
pEnableEvents = vNewValue
End Property
Friend Property Get EnableCapture() As Boolean
EnableCapture = pEnableCapture
End Property
Friend Property Let EnableCapture(ByVal vNewValue As Boolean)
pEnableCapture = vNewValue
End Property
Friend Property Get DefaultPicture() As stdole.Picture
Set DefaultPicture = pDefaultPicture
End Property
Friend Property Set DefaultPicture(ByVal vNewValue As stdole.Picture)
Set pDefaultPicture = vNewValue
End Property
Friend Property Get MouseEnterPicture() As stdole.Picture
Set MouseEnterPicture = pMouseEnterPicture
End Property
Friend Property Set MouseEnterPicture(ByVal vNewValue As stdole.Picture)
Set pMouseEnterPicture = vNewValue
End Property
Friend Property Get MouseDownPicture() As stdole.Picture
Set MouseDownPicture = pMouseDownPicture
End Property
Friend Property Set MouseDownPicture(ByVal vNewValue As stdole.Picture)
Set pMouseDownPicture = vNewValue
End Property
Friend Property Get MouseExitPicture() As stdole.Picture
Set MouseExitPicture = pMouseExitPicture
End Property
Friend Property Set MouseExitPicture(ByVal vNewValue As stdole.Picture)
Set pMouseExitPicture = vNewValue
End Property
'Thanks to STEPHEN BULLEN for much of the remaining code...
Private Function PictureFromRange(Target As Range, Optional lXlPicType As Long = xlPicture) As IPictureDisp
'Some pointers
Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
Target.CopyPicture
'Convert the type of picture requested from the xl constant to the API constant
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
'Check if the clipboard contains the required format
hPicAvail = IsClipboardFormatAvailable(lPicType)
If hPicAvail <> 0 Then
'Get access to the clipboard
h = OpenClipboard(0&)
If h > 0 Then
'Get a handle to the image data
hPtr = GetClipboardData(lPicType)
'Create our own copy of the image on the clipboard, in the appropriate format.
If lPicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
'Release the clipboard to other programs
h = CloseClipboard
'If we got a handle to the image, convert it into a Picture object and return it
If hPtr <> 0 Then Set PictureFromRange = CreatePicture(hCopy, 0, lPicType)
End If
End If
End Function
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPictureDisp
' IPicture requires a reference to "OLE Automation"
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPictureDisp
'OLE Picture types
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
' Create the Interface GUID (for the IPicture interface)
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' Fill uPicInfo with necessary parts.
With uPicInfo
.Size = Len(uPicInfo) ' Length of structure.
.Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture
.hPic = hPic ' Handle to image.
.hPal = IIf(lPicType = CF_BITMAP, hPal, 0) ' Handle to palette (if bitmap).
End With
' Create the Picture object.
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
' If an error occured, show the description
If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)
' Return the new Picture object.
Set CreatePicture = IPic
End Function
Private Function fnOLEError(lErrNum As Long) As String
'OLECreatePictureIndirect return values
Const E_ABORT = &H80004004
Const E_ACCESSDENIED = &H80070005
Const E_FAIL = &H80004005
Const E_HANDLE = &H80070006
Const E_INVALIDARG = &H80070057
Const E_NOINTERFACE = &H80004002
Const E_NOTIMPL = &H80004001
Const E_OUTOFMEMORY = &H8007000E
Const E_POINTER = &H80004003
Const E_UNEXPECTED = &H8000FFFF
Const S_OK = &H0
Select Case lErrNum
Case E_ABORT
fnOLEError = " Aborted"
Case E_ACCESSDENIED
fnOLEError = " Access Denied"
Case E_FAIL
fnOLEError = " General Failure"
Case E_HANDLE
fnOLEError = " Bad/Missing Handle"
Case E_INVALIDARG
fnOLEError = " Invalid Argument"
Case E_NOINTERFACE
fnOLEError = " No Interface"
Case E_NOTIMPL
fnOLEError = " Not Implemented"
Case E_OUTOFMEMORY
fnOLEError = " Out of Memory"
Case E_POINTER
fnOLEError = " Invalid Pointer"
Case E_UNEXPECTED
fnOLEError = " Unknown Error"
Case S_OK
fnOLEError = " Success!"
End Select
End Function