Mouse Rollover images using the mouse

Logistix · Sep 5, 2006

Hi there,

Is there anyway of setting up mouse rollover images for my userforms' buttons?

I'm trying to make my new created project look a little fancy too.

Thanks,

Steve

Legacy 98055 · Sep 8, 2006

Before I answer, it never occured too me if this control is included in a standard Office installation.

Does anybody know if the imagelist is standard?

Logistics. If not, no need to worry. We can store the pictures in a hidden spreadsheet or load them from file though an imagelist is definitely the way to go here...

Also, if the download worked for you, then you do have the imagelist on your sytem. I would be reinventing the wheel by exaplaining how to use this very simple control.

If the control is properly installed on your system, open the download I sent you and look at the userform in design mode, select the Imagelist control, and then hit F1. The helps for this control should come up...

Legacy 98055 · Sep 10, 2006

This example shows several different ways to store and get a handle on pictures. From file, a range, another control, and the imagelist control. Needs improvement, but, if you spend a little time on this, you should have no problem spicing up up your userforms a bit...

MouseEventsUserformControls.zip

Class module named "FrameHotTracker":
<table width="100%" border="1" bgcolor="White" style="filter

rogid:DXImageTransform.Microsoft.Gradient(endColorstr='#C0CFE2', startColorstr='#FFFFFF', gradientType='0');"><tr><TD> Option Explicit

 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 Type POINTAPI
 X As Long
 Y As Long
 End Type

 Private WithEvents pFrame As MSForms.Frame

 Private pUF 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 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 pUF.MouseDown(Me, PicArg, Button, Shift, X, Y)
 Call SetPicture(pMouseDownPicture, 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 pUF.MouseExit(Me, PicArg)
 Call SetPicture(pMouseExitPicture, PicArg)
 ElseIf GetCapture() <> hwnd Then
 SetCapture hwnd
 Set PicArg = pMouseEnterPicture
 If pEnableEvents Then Call pUF.MouseEnter(Me, PicArg)
 Call SetPicture(pMouseEnterPicture, PicArg)
 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

 Public Sub HotTrack(UF As Object, _
 o As MSForms.Frame, _
 Optional EnableEvents As Boolean = True, _
 Optional EnableCapture As Boolean = False, _
 Optional DefaultPicture As stdole.Picture = Nothing, _
 Optional MouseEnterPicture As stdole.Picture = Nothing, _
 Optional MouseDownPicture As stdole.Picture = Nothing, _
 Optional MouseExitPicture As stdole.Picture = Nothing)

 Set pUF = UF
 Set pFrame = o
 pEnableEvents = EnableEvents
 pEnableCapture = EnableCapture
 Set pDefaultPicture = DefaultPicture
 Set pMouseEnterPicture = MouseEnterPicture
 Set pMouseDownPicture = MouseDownPicture
 Set pMouseExitPicture = MouseExitPicture
 End Sub

 Public Property Get hwnd() As Long
 hwnd = pHwnd
 End Property

 Public Property Get Frame() As MSForms.Frame
 Set Frame = pFrame
 End Property

 Public Property Set Frame(ByVal vNewValue As MSForms.Frame)
 Set pFrame = vNewValue
 End Property

 Public Property Get EnableEvents() As Boolean
 EnableEvents = pEnableEvents
 End Property

 Public Property Let EnableEvents(ByVal vNewValue As Boolean)
 pEnableEvents = vNewValue
 End Property

 Public Property Get EnableCapture() As Boolean
 EnableCapture = pEnableCapture
 End Property

 Public Property Let EnableCapture(ByVal vNewValue As Boolean)
 pEnableCapture = vNewValue
 End Property

 Public Property Get DefaultPicture() As stdole.Picture
 Set DefaultPicture = pDefaultPicture
 End Property

 Public Property Set DefaultPicture(ByVal vNewValue As stdole.Picture)
 Set pDefaultPicture = vNewValue
 End Property

 Public Property Get MouseEnterPicture() As stdole.Picture
 Set MouseEnterPicture = pMouseEnterPicture
 End Property

 Public Property Set MouseEnterPicture(ByVal vNewValue As stdole.Picture)
 Set pMouseEnterPicture = vNewValue
 End Property

 Public Property Get MouseDownPicture() As stdole.Picture
 Set MouseDownPicture = pMouseDownPicture
 End Property

 Public Property Set MouseDownPicture(ByVal vNewValue As stdole.Picture)
 Set pMouseDownPicture = vNewValue
 End Property

 Public Property Get MouseExitPicture() As stdole.Picture
 Set MouseExitPicture = pMouseExitPicture
 End Property

 Public Property Set MouseExitPicture(ByVal vNewValue As stdole.Picture)
 Set pMouseExitPicture = vNewValue
 End Property

</td></tr></table><button onclick='document.all("9102006155023687").value=document.all("9102006155023687").value.replace(/ \s\s/g,"");document.all("9102006155023687").value=document.all("9102006155023687").value.replace(/ /g,"");window.clipboardData.setData("Text",document.all("9102006155023687").value);'>Copy to Clipboard</BUTTON><textarea style="position:absolute;visibility:hidden" name="9102006155023687" wrap="virtual">
Option Explicit

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 Type POINTAPI
X As Long
Y As Long
End Type

Private WithEvents pFrame As MSForms.Frame

Private pUF 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 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 pUF.MouseDown(Me, PicArg, Button, Shift, X, Y)
Call SetPicture(pMouseDownPicture, 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 pUF.MouseExit(Me, PicArg)
Call SetPicture(pMouseExitPicture, PicArg)
ElseIf GetCapture() <> hwnd Then
SetCapture hwnd
Set PicArg = pMouseEnterPicture
If pEnableEvents Then Call pUF.MouseEnter(Me, PicArg)
Call SetPicture(pMouseEnterPicture, PicArg)
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

Public Sub HotTrack(UF As Object, _
o As MSForms.Frame, _
Optional EnableEvents As Boolean = True, _
Optional EnableCapture As Boolean = False, _
Optional DefaultPicture As stdole.Picture = Nothing, _
Optional MouseEnterPicture As stdole.Picture = Nothing, _
Optional MouseDownPicture As stdole.Picture = Nothing, _
Optional MouseExitPicture As stdole.Picture = Nothing)

Set pUF = UF
Set pFrame = o
pEnableEvents = EnableEvents
pEnableCapture = EnableCapture
Set pDefaultPicture = DefaultPicture
Set pMouseEnterPicture = MouseEnterPicture
Set pMouseDownPicture = MouseDownPicture
Set pMouseExitPicture = MouseExitPicture
End Sub

Public Property Get hwnd() As Long
hwnd = pHwnd
End Property

Public Property Get Frame() As MSForms.Frame
Set Frame = pFrame
End Property

Public Property Set Frame(ByVal vNewValue As MSForms.Frame)
Set pFrame = vNewValue
End Property

Public Property Get EnableEvents() As Boolean
EnableEvents = pEnableEvents
End Property

Public Property Let EnableEvents(ByVal vNewValue As Boolean)
pEnableEvents = vNewValue
End Property

Public Property Get EnableCapture() As Boolean
EnableCapture = pEnableCapture
End Property

Public Property Let EnableCapture(ByVal vNewValue As Boolean)
pEnableCapture = vNewValue
End Property

Public Property Get DefaultPicture() As stdole.Picture
Set DefaultPicture = pDefaultPicture
End Property

Public Property Set DefaultPicture(ByVal vNewValue As stdole.Picture)
Set pDefaultPicture = vNewValue
End Property

Public Property Get MouseEnterPicture() As stdole.Picture
Set MouseEnterPicture = pMouseEnterPicture
End Property

Public Property Set MouseEnterPicture(ByVal vNewValue As stdole.Picture)
Set pMouseEnterPicture = vNewValue
End Property

Public Property Get MouseDownPicture() As stdole.Picture
Set MouseDownPicture = pMouseDownPicture
End Property

Public Property Set MouseDownPicture(ByVal vNewValue As stdole.Picture)
Set pMouseDownPicture = vNewValue
End Property

Public Property Get MouseExitPicture() As stdole.Picture
Set MouseExitPicture = pMouseExitPicture
End Property

Public Property Set MouseExitPicture(ByVal vNewValue As stdole.Picture)
Set pMouseExitPicture = vNewValue
End Property
</textarea>
Standard module:
<table width="100%" border="1" bgcolor="White" style="filter

rogid:DXImageTransform.Microsoft.Gradient(endColorstr='#C0CFE2', startColorstr='#FFFFFF', gradientType='0');"><tr><TD> '***************************************************************************
 '*
 '* MODULE NAME: Paste Picture
 '* AUTHOR & DATE: STEPHEN BULLEN, Office Automation Ltd
 '* 15 November 1998
 '*
 '* CONTACT: Stephen@oaltd.co.uk
 '* WEB SITE: http://www.oaltd.co.uk
 '*
 '* DESCRIPTION: Creates a standard Picture object from whatever is on the clipboard.
 '* This object can then be assigned to (for example) and Image control
 '* on a userform. The PastePicture function takes an optional argument of
 '* the picture type - xlBitmap or xlPicture.
 '*
 '* The code requires a reference to the "OLE Automation" type library
 '*
 '* The code in this module has been derived from a number of sources
 '* discovered on MSDN.
 '*
 '* To use it, just copy this module into your project, then you can use:
 '* Set Image1.Picture = PastePicture(xlPicture)
 '* to paste a picture of whatever is on the clipboard into a standard image control.
 '*
 '* PROCEDURES:
 '* PastePicture The entry point for the routine
 '* CreatePicture Private function to convert a bitmap or metafile handle to an OLE reference
 '* fnOLEError Get the error text for an OLE error code
 '***************************************************************************

 Option Explicit
 Option Compare Text

 ''' User-Defined Types for API Calls

 'Declare a UDT to store a GUID for the IPicture OLE Interface
 Private Type GUID
 Data1 As Long
 Data2 As Integer
 Data3 As Integer
 Data4(0 To 7) As Byte
 End Type

 'Declare a UDT to store the bitmap information
 Private Type uPicDesc
 Size As Long
 Type As Long
 hPic As Long
 hPal As Long
 End Type

 '''Windows API Function Declarations

 'Does the clipboard contain a bitmap/metafile?
 Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long

 'Open the clipboard to read
 Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

 'Get a pointer to the bitmap/metafile
 Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

 'Close the clipboard
 Private Declare Function CloseClipboard Lib "user32" () As Long

 'Convert the handle into an OLE IPicture interface.
 Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

 'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
 Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long

 'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
 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

 'The API format types we're interested in
 Const CF_BITMAP = 2
 Const CF_PALETTE = 9
 Const CF_ENHMETAFILE = 14
 Const IMAGE_BITMAP = 0
 Const LR_COPYRETURNORG = &H4

 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 ''' Subroutine: PastePicture
 '''
 ''' Purpose: Get a Picture object showing whatever's on the clipboard.
 '''
 ''' Arguments: lXlPicType - The type of picture to create. Can be one of:
 ''' xlPicture to create a metafile (default)
 ''' xlBitmap to create a bitmap
 '''
 ''' Date Developer Action
 ''' --------------------------------------------------------------------------
 ''' 30 Oct 98 Stephen Bullen Created
 ''' 15 Nov 98 Stephen Bullen Updated to create our own copies of the clipboard images
 '''

 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

 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 ''' Subroutine: CreatePicture
 '''
 ''' Purpose: Converts a image (and palette) handle into a Picture object.
 '''
 ''' Requires a reference to the "OLE Automation" type library
 '''
 ''' Arguments: None
 '''
 ''' Date Developer Action
 ''' --------------------------------------------------------------------------
 ''' 30 Oct 98 Stephen Bullen Created
 '''

 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

 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 ''' Subroutine: fnOLEError
 '''
 ''' Purpose: Gets the message text for standard OLE errors
 '''
 ''' Arguments: None
 '''
 ''' Date Developer Action
 ''' --------------------------------------------------------------------------
 ''' 30 Oct 98 Stephen Bullen Created
 '''

 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

</td></tr></table><button onclick='document.all("9102006155045156").value=document.all("9102006155045156").value.replace(/ \s\s/g,"");document.all("9102006155045156").value=document.all("9102006155045156").value.replace(/ /g,"");window.clipboardData.setData("Text",document.all("9102006155045156").value);'>Copy to Clipboard</BUTTON><textarea style="position:absolute;visibility:hidden" name="9102006155045156" wrap="virtual">
'***************************************************************************
'*
'* MODULE NAME: Paste Picture
'* AUTHOR & DATE: STEPHEN BULLEN, Office Automation Ltd
'* 15 November 1998
'*
'* CONTACT: Stephen@oaltd.co.uk
'* WEB SITE: http://www.oaltd.co.uk
'*
'* DESCRIPTION: Creates a standard Picture object from whatever is on the clipboard.
'* This object can then be assigned to (for example) and Image control
'* on a userform. The PastePicture function takes an optional argument of
'* the picture type - xlBitmap or xlPicture.
'*
'* The code requires a reference to the "OLE Automation" type library
'*
'* The code in this module has been derived from a number of sources
'* discovered on MSDN.
'*
'* To use it, just copy this module into your project, then you can use:
'* Set Image1.Picture = PastePicture(xlPicture)
'* to paste a picture of whatever is on the clipboard into a standard image control.
'*
'* PROCEDURES:
'* PastePicture The entry point for the routine
'* CreatePicture Private function to convert a bitmap or metafile handle to an OLE reference
'* fnOLEError Get the error text for an OLE error code
'***************************************************************************

Option Explicit
Option Compare Text

''' User-Defined Types for API Calls

'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

'Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type

'''Windows API Function Declarations

'Does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long

'Open the clipboard to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

'Get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

'Close the clipboard
Private Declare Function CloseClipboard Lib "user32" () As Long

'Convert the handle into an OLE IPicture interface.
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long

'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
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

'The API format types we're interested in
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: PastePicture
'''
''' Purpose: Get a Picture object showing whatever's on the clipboard.
'''
''' Arguments: lXlPicType - The type of picture to create. Can be one of:
''' xlPicture to create a metafile (default)
''' xlBitmap to create a bitmap
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 30 Oct 98 Stephen Bullen Created
''' 15 Nov 98 Stephen Bullen Updated to create our own copies of the clipboard images
'''

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

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: CreatePicture
'''
''' Purpose: Converts a image (and palette) handle into a Picture object.
'''
''' Requires a reference to the "OLE Automation" type library
'''
''' Arguments: None
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 30 Oct 98 Stephen Bullen Created
'''

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

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: fnOLEError
'''
''' Purpose: Gets the message text for standard OLE errors
'''
''' Arguments: None
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 30 Oct 98 Stephen Bullen Created
'''

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
</textarea>

see more next post...

MouseEventsUserformControls.zip

Legacy 98055 · Sep 10, 2006

MouseEventsUserformControls.zip

useform example code:
<table width="100%" border="1" bgcolor="White" style="filter

rogid:DXImageTransform.Microsoft.Gradient(endColorstr='#C0CFE2', startColorstr='#FFFFFF', gradientType='0');"><tr><TD> Option Explicit

 Private FHT() As FrameHotTracker

 Public Sub MouseEnter(f As FrameHotTracker, p As stdole.Picture)
 'these event can be used for other things you may wish to do
 'also, the picture can be change on the fly by changing the
 'picture object being pointed to by the "p" argument

 If FHT(4).hwnd = f.hwnd Then
 Me.BackColor = &HFFEBF7
 Frame1.BackColor = &HFFEBF7
 f.Frame.BorderStyle = fmBorderStyleSingle
 End If

 End Sub

 Public Sub MouseDown(f As FrameHotTracker, p As stdole.Picture, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
 End Sub

 Public Sub MouseExit(f As FrameHotTracker, p As stdole.Picture)
 If FHT(4).hwnd = f.hwnd Then
 Me.BackColor = &H8000000F
 f.Frame.BorderStyle = fmBorderStyleNone
 End If
 End Sub

 Private Sub UserForm_Initialize()
 Dim DefaultPic As IPictureDisp
 Dim MouseEnterPic As IPictureDisp
 Dim MouseDownPic As IPictureDisp
 Dim MouseExitPic As IPictureDisp

 ReDim FHT(0)

 'set up frame1
 'frame1 will have pictures taken from range a1, a2, and a3
 Set FHT(0) = New FrameHotTracker
 Set DefaultPic = PictureFromRange([a1])
 Set MouseEnterPic = PictureFromRange([a2])
 Set MouseDownPic = PictureFromRange([a3])
 Set MouseExitPic = DefaultPic
 Set Frame1.Picture = DefaultPic
 'set it up
 Call FHT(0).HotTrack(Me, Frame1, False, True, _
 DefaultPic, MouseEnterPic, MouseDownPic, MouseExitPic)

 'set up frame2
 'frame2 will have pictures taken from the embedded ImgList control
 ReDim Preserve FHT(1)
 Set FHT(1) = New FrameHotTracker
 Set DefaultPic = ImgList.ListImages("home").Picture
 Set MouseEnterPic = ImgList.ListImages("home_enter").Picture
 Set MouseDownPic = ImgList.ListImages("home_down").Picture
 Set MouseExitPic = DefaultPic
 Call FHT(1).HotTrack(Me, Frame2, False, True, _
 DefaultPic, MouseEnterPic, MouseDownPic, MouseExitPic)

 'set up frame3
 'frame3 will have pictures taken from three hidden labels
 ReDim Preserve FHT(2)
 Set FHT(2) = New FrameHotTracker
 Set DefaultPic = Label50.Picture
 Set MouseEnterPic = Label51.Picture
 Set MouseDownPic = Label52.Picture
 Set MouseExitPic = DefaultPic
 Call FHT(2).HotTrack(Me, Frame3, False, True, _
 DefaultPic, MouseEnterPic, MouseDownPic, MouseExitPic)

 'set up frame4
 'frame4 will have pictures taken from files on disc using the LoadPicture method
 'assumes that these file are located in ThisWorkbook's path
 'you can place them wherever you like but the path obviously must be correct
 ReDim Preserve FHT(3)
 Set FHT(3) = New FrameHotTracker
 Set DefaultPic = LoadPicture(Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "bar.gif"))
 Set MouseEnterPic = LoadPicture(Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "bar_enter.gif"))
 Set MouseDownPic = LoadPicture(Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "bar_down.gif"))
 Set MouseExitPic = DefaultPic
 Call FHT(3).HotTrack(Me, Frame4, False, True, _
 DefaultPic, MouseEnterPic, MouseDownPic, MouseExitPic)

 'set up frame14
 'frame14 will have it's pictures taken from ranges
 'note that we will use the pseudo events to change the properties of Frame13
 'so the third argument will be True to enable events
 'we also will not respond to mouse clicks for this frame
 ReDim Preserve FHT(4)
 Set FHT(4) = New FrameHotTracker
 Set DefaultPic = PictureFromRange([d4])
 Set MouseEnterPic = PictureFromRange([d5])
 Set MouseExitPic = DefaultPic
 Call FHT(4).HotTrack(Me, Frame14, True, True, _
 DefaultPic, MouseEnterPic, , MouseExitPic)

 End Sub

 Private Sub UserForm_Terminate()
 Erase FHT
 End Sub
</td></tr></table><button onclick='document.all("9102006155548796").value=document.all("9102006155548796").value.replace(/ \s\s/g,"");document.all("9102006155548796").value=document.all("9102006155548796").value.replace(/ /g,"");window.clipboardData.setData("Text",document.all("9102006155548796").value);'>Copy to Clipboard</BUTTON><textarea style="position:absolute;visibility:hidden" name="9102006155548796" wrap="virtual">
Option Explicit

Private FHT() As FrameHotTracker

Public Sub MouseEnter(f As FrameHotTracker, p As stdole.Picture)
'these event can be used for other things you may wish to do
'also, the picture can be change on the fly by changing the
'picture object being pointed to by the "p" argument

If FHT(4).hwnd = f.hwnd Then
Me.BackColor = &HFFEBF7
Frame1.BackColor = &HFFEBF7
f.Frame.BorderStyle = fmBorderStyleSingle
End If

End Sub

Public Sub MouseDown(f As FrameHotTracker, p As stdole.Picture, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
End Sub

Public Sub MouseExit(f As FrameHotTracker, p As stdole.Picture)
If FHT(4).hwnd = f.hwnd Then
Me.BackColor = &H8000000F
f.Frame.BorderStyle = fmBorderStyleNone
End If
End Sub

Private Sub UserForm_Initialize()
Dim DefaultPic As IPictureDisp
Dim MouseEnterPic As IPictureDisp
Dim MouseDownPic As IPictureDisp
Dim MouseExitPic As IPictureDisp

ReDim FHT(0)

'set up frame1
'frame1 will have pictures taken from range a1, a2, and a3
Set FHT(0) = New FrameHotTracker
Set DefaultPic = PictureFromRange([a1])
Set MouseEnterPic = PictureFromRange([a2])
Set MouseDownPic = PictureFromRange([a3])
Set MouseExitPic = DefaultPic
Set Frame1.Picture = DefaultPic
'set it up
Call FHT(0).HotTrack(Me, Frame1, False, True, _
DefaultPic, MouseEnterPic, MouseDownPic, MouseExitPic)

'set up frame2
'frame2 will have pictures taken from the embedded ImgList control
ReDim Preserve FHT(1)
Set FHT(1) = New FrameHotTracker
Set DefaultPic = ImgList.ListImages("home").Picture
Set MouseEnterPic = ImgList.ListImages("home_enter").Picture
Set MouseDownPic = ImgList.ListImages("home_down").Picture
Set MouseExitPic = DefaultPic
Call FHT(1).HotTrack(Me, Frame2, False, True, _
DefaultPic, MouseEnterPic, MouseDownPic, MouseExitPic)

'set up frame3
'frame3 will have pictures taken from three hidden labels
ReDim Preserve FHT(2)
Set FHT(2) = New FrameHotTracker
Set DefaultPic = Label50.Picture
Set MouseEnterPic = Label51.Picture
Set MouseDownPic = Label52.Picture
Set MouseExitPic = DefaultPic
Call FHT(2).HotTrack(Me, Frame3, False, True, _
DefaultPic, MouseEnterPic, MouseDownPic, MouseExitPic)

'set up frame4
'frame4 will have pictures taken from files on disc using the LoadPicture method
'assumes that these file are located in ThisWorkbook's path
'you can place them wherever you like but the path obviously must be correct
ReDim Preserve FHT(3)
Set FHT(3) = New FrameHotTracker
Set DefaultPic = LoadPicture(Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "bar.gif"))
Set MouseEnterPic = LoadPicture(Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "bar_enter.gif"))
Set MouseDownPic = LoadPicture(Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "bar_down.gif"))
Set MouseExitPic = DefaultPic
Call FHT(3).HotTrack(Me, Frame4, False, True, _
DefaultPic, MouseEnterPic, MouseDownPic, MouseExitPic)

'set up frame14
'frame14 will have it's pictures taken from ranges
'note that we will use the pseudo events to change the properties of Frame13
'so the third argument will be True to enable events
'we also will not respond to mouse clicks for this frame
ReDim Preserve FHT(4)
Set FHT(4) = New FrameHotTracker
Set DefaultPic = PictureFromRange([d4])
Set MouseEnterPic = PictureFromRange([d5])
Set MouseExitPic = DefaultPic
Call FHT(4).HotTrack(Me, Frame14, True, True, _
DefaultPic, MouseEnterPic, , MouseExitPic)

End Sub

Private Sub UserForm_Terminate()
Erase FHT
End Sub</textarea>

MouseEventsUserformControls.zip

Mouse Rollover images using the mouse

Logistix

Board Regular

Legacy 98055

Guest

Excel Facts

Legacy 98055

Guest

Legacy 98055

Guest

Similar threads

Forum statistics

Share this page

Mouse Rollover images using the mouse

Logistix

Board Regular

Legacy 98055

Guest

Excel Facts

Legacy 98055

Guest

Legacy 98055

Guest

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock