Add pictures to drop down menu

messymaverick

New Member
Joined
Aug 28, 2005
Messages
1
I m creating a custom drop down menu using data validation, i just wanted to know if it is possible to add pictures in drop down menu
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
No, not in data validation or any drop-down object for that matter. Photos would need to be housed in a shape (example comment) or Image control or on the worksheet itself, but not within any drop-down lists which are only meant for text.
 
Upvote 0
Hello Tom,

Actually, you can use some Common Windows Controls like Treview,ImageList...to display an Image next to the Text which can enhance the UI very nicely.

The other Good news is that these Controls are installed with any MS Office which means that there is no need to copy the Control file together with the Application as would otherwise be the case with other third parties Controls.

Anyway, here is an example I came up with which uses an ImageComboBox Control, and Three CommandButtons.

1) Insert a ImageCombo1 on Sheet1
(To get the ImageCombo1, Click on the MoreControls Icon on the Controls ToolBar and Select " Microsoft ImageComboBox Control "

2) Create thre Buttons from the Forms ToolBar and assign to them the Routines as follows :
- Button1 ==> Procedure : PopulateCombo
- Button2 ==> Procedure : ChangeCursor
- Button3 ==> Procedure : RestoreDefault

When you click Button1, the ComboBox gets populated by all the Cursors that exist in the System. (*.cur)

When you click on Button2, the System Cursor changes to the one that is selected on the ComboBox.

When Button3 is clicked , the Default Win Cursor is restored.


Code to be placed in a Standard Module :


Code:
Private Declare Function LoadCursorFromFile Lib "user32" Alias _
"LoadCursorFromFileA" (ByVal lpFileName As String) As Long

Private Declare Function SetSystemCursor Lib "user32" _
(ByVal hcur As Long, ByVal id As Long) As Long

 Const OCR_NORMAL As Long = 32512


Sub PopulateCombo()

    Dim intI As Integer
    Dim objImgCmb As ImageCombo
    Dim objTempImgList As New ImageList
    Set objTempImgList = GetIcons("C:\WINDOWS\Cursors")
    '\\ This assumes the Combo name is the Def 'ImageCombo1'
    '\\ and is Embeeded in Sheet1 .Change these as required
    With Sheet1.ImageCombo1
        '\\Clear Combo just in case
        .ComboItems.Clear
        '\\ Transfer images to the Combo ImageList Property
        Set .ImageList = objTempImgList
        For intI = 1 To objTempImgList.ListImages.Count
            .ComboItems.Add , , _
            objTempImgList.ListImages(intI).Key, intI
        Next intI
        '\\ Format the Combo so it displays Text & Imgs
        Set .SelectedItem = .ComboItems(1)
        .ForeColor = vbRed
        .Font.Bold = True
        .Width = 250
    End With
    '\\ Clean up
    Set objImgCmb = Nothing
    Set objTempImgList = Nothing

End Sub


Sub ChangeCursor()

    '\\ Load Selected Curs
    With Sheet1.ImageCombo1
        GetSpecialCursor .SelectedItem
    End With
    
End Sub


Sub GetSpecialCursor(ByVal ChngCursor As String)

    Dim lngNewCurs As Long
    lngNewCurs = LoadCursorFromFile(ChngCursor)
    SetSystemCursor lngNewCurs, OCR_NORMAL
    
End Sub


Function GetIcons(strCursorFolder As String) As ImageList

    '\\ Declare var to hold Curs Pictures
    Dim objImgList As New ImageList
    Dim curs As Variant
    '\\ Search Win\Cur..for Curs Files
    With Application.FileSearch
        .NewSearch
        .LookIn = strCursorFolder
        .Filename = ".cur"
        .SearchSubFolders = False
        If .Execute() > 0 Then
            For Each curs In .FoundFiles
                '\\ Store curs Icons in the ImageList
                objImgList.ListImages.Add _
                Key:=curs, Picture:=LoadPicture(curs)
            Next
        End If
        If .FoundFiles.Count = 0 Then
            MsgBox "No  (*.Cur)  files found in ( " & strCursorFolder _
            & " )" & vbCrLf & "Try another folder.", vbCritical: End
        End If
    End With
    '\\ Clean Up
    Set GetIcons = objImgList
    Set objImgList = Nothing

End Function


Sub RestoreDefault()
    '\\Run this if you want to restore Default Sys Cursor
    GetSpecialCursor ("C:\WINDOWS\Cursors\arrow_m.cur")
End Sub

By displaying the actual Cursor Images, the user can better decide which cursor they want because they can conviniently see it.


Regards.
 
Upvote 0
Jaafar

Thanks.:)

After playing with your code I now have an oversized cursor.

And yes I did run the routine to restore the default.
 
Upvote 0
Hello Jaafar - -

Actually you and I agree on this, because my point was that everyday drop-downs (I did not say "everyday" drop-downs but mentioned common ones like data validation and comboboxes) do not support this property, whereas other shapes (comments, buttons, etc) and controls (Image) do support the property, the latter of which your suggestion might fall, though I should not have sounded so definitive with my "no" answer.

Speaking of, I have never used the ImageCombo control and did not think to suggest it as an alternative, thanks for that, you always have some interesting solutions to offer and I enjoy adding them to my library.

Did your code really work for you? I get an error in the GetIcons function with the LoadPicture argument. I would like to see this work. The other thing on my mind is, 99.99% of all Excel work I do is for my clients, not for me, so I need to make sure their graphic Image is included somewhere in the file itself (can't count on it always being in an accessible path for all users of the app), so the cbo can find it and display it. In actual practice, the images would likely be pictures or custom graphics associated with the client.

Thanks.
 
Upvote 0
Norie,

Just restore the Default Cursor via Control Pannel and try to adapt this Code I found on [url]http://www.mentalis.org/apilist/GetCursor.shtml [/url]Website.

Rich (BB code):
'Code by Jerry Grant (Jerry@jg-design.net)
'Visit his website at http://www.jg-design.net
'This example requires two command buttons
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function CopyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Function SetSystemCursor Lib "user32" (ByVal hcur As Long, ByVal id As Long) As Long
Private Declare Function GetCursor Lib "user32" () As Long
Private Const OCR_NORMAL As Long = 32512
Private currenthcurs As Long
Private tempcurs As Long
Private newhcurs As Long
Private Sub Command1_Click()
    Dim myDir As String
    Dim lDir As Long
    myDir = Space(255)
    currenthcurs = GetCursor()
    tempcurs = CopyIcon(currenthcurs)
    lDir = GetWindowsDirectory(myDir, 255)
    myDir = Left$(myDir, lDir) & "\cursors\banana.ani"
    newhcurs = LoadCursorFromFile(myDir)
    Call SetSystemCursor(newhcurs, OCR_NORMAL)
End Sub
Private Sub Command2_Click()
    Call SetSystemCursor(tempcurs, OCR_NORMAL)
End Sub

This should recover your initial Cursor becuse it stores it in a Global variable before changing it.

For some strange reason, in some systems like mine, the above Code doesn't work . ie , the Initial Cursor is not Restored !!!! That's why I had to hardCode it : GetSpecialCursor ("C:\WINDOWS\Cursors\arrow_m.cur")

Regards.
 
Upvote 0
Hi Tom,

I am not sure why you get an error but I suspect it could be because of the folder Path. The code works well in my computer.

As you rightly said, there is no garanty that the User's computer folders\files will be the same. Would work if hardcoded though.

Regards.
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top