Set focus on Image Control

[slimimi]

Hi there - i am using an image control on my userform instead of a command button - so that i can use a different shape (instead of the normal rect/square).

I cant set focus to this image control though - it says its not supported.
Is there a workaround so that, on mouse pointer over the image control , to either:

Set focus with a line around it (as per the normal way on command buttons)

or

Change picture on Mouse Pointer Over. This way i can save 2 images and just color them differently so that when mouse pointer is over it changes to image 2, if not then it stays on image 1

Are any of the above 2 solutions possible or is there a better workaround please?

Thanks in advance.

 

[John_w]

Hi there - i am using an image control on my userform instead of a command button - so that i can use a different shape (instead of the normal rect/square).

Why not just set the command button's Picture property?

I cant set focus to this image control though - it says its not supported.
Is there a workaround so that, on mouse pointer over the image control , to either:

Set focus with a line around it (as per the normal way on command buttons)

You could put a Frame around the image control and then use this code so that the image appears to receive focus when you mouse over it:

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Frame1.BorderStyle = fmBorderStyleNone
End Sub

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Frame1.BorderStyle = fmBorderStyleSingle
End Sub

However you can't tab to the image to receive focus.

or

Change picture on Mouse Pointer Over. This way i can save 2 images and just color them differently so that when mouse pointer is over it changes to image 2, if not then it stays on image 1

Do something similar to the code above and change the Image control's Picture property.

 

[slimimi]

please can you tell me the code to change the image control's picture property? thanks for your help too..

 

[John_w]

Image1.Picture = LoadPicture("C:\temp\image.jpg")

 

[slimimi]

thank you john - i will give that a try.....
Many thanks again.

 

[Legacy 98055]

If you really want to make some nice userforms, add a browser control and create your own DHTML. There are many options when doing it this way including all of the rendering capability of Internet Explorer and the many events that are available in the DOM. If you are not familiar with HTML, the only other way that I know by way of the native MSForms controls is a frame control. This control provides a handle. The only other control that has an Hwnd is the listbox control which will do us no good for lack of a picture property. There is a handful of code, but the actual coding required to utilize this is simple.

The easiest way to obtain images is to create web buttons. There are several websites that provide free button creators or you can create your own with more than a few third party apps.

Your pictures can be supplied from ranges, from file, or from any other control that has a picture property. Since you can get a picture from a range, you can use any of the autoshapes, wordart, or cell formats and render these in your frame(s)...

Download the example and extract to one folder. The example includes some image files and examples of using ranges. The code, as is, will look for these images in the workbook's path. Just make sure all of the files are in the same folder.

HotTrackingFrame.zip

The class provides three events. Mouse Enter, Down, and Exit.

For example, create the class below and add Frame1 to your userform. Set the various properties of Frame1 and size it according to your picture(s). You will get better rendering if the size of the control and your pictures is the same.

You should create a Default Picture, a MouseOver picture, and a Mouse Down or Click picture. The exit picture is usually going to be the same as the default picture.

You must enter the three procedures rather you use them or not. The class uses callbacks, not events.
Add this code to your userform...

Option Explicit
 
Private FHT As FrameHotTracker
 
Private Sub UserForm_Initialize()
    ChDir ThisWorkbook.Path
 
    Set FHT = New FrameHotTracker
 
    Call FHT.SetHotTrackFromFile(Frame1, _
        "Default.bmp", _
        "MouseOver.bmp", _
        "MouseDown.bmp", _
        "Default.bmp")
End Sub
 
Public Sub FHT_MouseEnter(f As FrameHotTracker, p As stdole.Picture)
 
End Sub
 
Public Sub FHT_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 FHT_MouseExit(f As FrameHotTracker, p As stdole.Picture)
 
End Sub

Create a class module and name it "FrameHotTracker" without the quotes. Paste in this code...

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

Here is some additional example code in the userform containing Frame1 to Frame7. This code is in the download link above.

Option Explicit
 
Private FHT() As FrameHotTracker
 
Public Sub FHT_MouseEnter(f As FrameHotTracker, p As stdole.Picture)
    Label1 = "MouseEnter " & f.Frame.Name
    Label2 = "Toggled = " & f.Toggled
    If f.Frame.Name = "Frame7" And Not f.Toggled Then
        f.Frame.BorderStyle = fmBorderStyleSingle
        f.Frame.BorderColor = vbRed
    End If
End Sub
 
Public Sub FHT_MouseDown(f As FrameHotTracker, p As stdole.Picture, _
    ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Label1 = "MouseDown " & f.Frame.Name
    Label2 = "Toggled = " & f.Toggled
End Sub
 
Public Sub FHT_MouseExit(f As FrameHotTracker, p As stdole.Picture)
    Label1 = "MouseExit " & f.Frame.Name
    Label2 = "Toggled = " & f.Toggled
    If f.Frame.Name = "Frame7" And Not f.Toggled Then
        f.Frame.SpecialEffect = fmSpecialEffectFlat
        f.Frame.BorderStyle = fmBorderStyleNone
    End If
End Sub
 
Private Sub UserForm_Initialize()
 
    ReDim FHT(6)
 
    ChDir ThisWorkbook.Path
 
    'set up frame1
    'frame1 will have pictures taken from sheet1, range a1 to a4
    Set FHT(0) = New FrameHotTracker
    With Sheets("Sheet1")
        Call FHT(0).SetHotTrackFromRange(Frame1, .[a1], .[a2], .[a3], .[a4])
    End With
    FHT(0).IsToggleButton = True
 
    'set up frame2
    'frame2 will have pictures taken from sheet1, range c1 to c4
    Set FHT(1) = New FrameHotTracker
    With Sheets("Sheet1")
        Call FHT(1).SetHotTrackFromRange(Frame2, .[c1], .[c2], .[c3], .[c4])
    End With
 
    'set up frame3
    'frame3 will have pictures taken from bmp files located in thisworkbook's path
    Set FHT(2) = New FrameHotTracker
    Call FHT(2).SetHotTrackFromFile(Frame3, _
        "Default.bmp", _
        "MouseOver.bmp", _
        "MouseDown.bmp", _
        "Default.bmp")
 
    'set up frame4, 5, and 6
    'these will have pictures taken from bmp files located in thisworkbook's path
    Set FHT(3) = New FrameHotTracker
    Call FHT(3).SetHotTrackFromFile(Frame4, _
        "Frame4_Default.bmp", _
        "Frame4_MouseOver.bmp", _
        "Frame4_MouseDown.bmp", _
        "Frame4_Default.bmp")
 
    Set FHT(4) = New FrameHotTracker
    Call FHT(4).SetHotTrackFromFile(Frame5, _
        "Frame4_Default.bmp", _
        "Frame4_MouseOver.bmp", _
        "Frame4_MouseDown.bmp", _
        "Frame4_Default.bmp")
 
    Set FHT(5) = New FrameHotTracker
    Call FHT(5).SetHotTrackFromFile(Frame6, _
        "Frame4_Default.bmp", _
        "Frame4_MouseOver.bmp", _
        "Frame4_MouseDown.bmp", _
        "Frame4_Default.bmp")
 
    Set FHT(6) = New FrameHotTracker
    Frame7.SpecialEffect = fmSpecialEffectFlat
    Frame7.BorderStyle = fmBorderStyleSingle
    Call FHT(6).SetHotTrackEvents(Frame7)
    FHT(6).IsToggleButton = True
 
End Sub
 
Private Sub UserForm_Terminate()
 Erase FHT
End Sub

 

[slimimi]

THank you for such a wonderful and informative reply. I really appreciate it very much.
I will have to take baby steps though cause i am still v.new to VB.

If i could start with this please:
If i could just show you an image that i am using for my userfrom.
As you can see its a hand holding a phone on a black background.

Is there any code to make my userform transparent so that my new userform now becomes the shape of the hand instead?

Hope this makes sense.
(sorry i cant figure out how to attach the image but i am sure you get the drift) ))