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
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
'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