Thanks Douglas. I will have a crack at porting Randy's example soon.
In the meantime, I been searching google for suitable code to try and adapt
for my own purposes. Although I don't have much knowledge about programming
generally, much less about api's etc, I have cobbled together the following
code from other threads I've located on the same issue. The problem I seem
to be running into is that if I set the picture type to bmp (ie 1), the code
gives rise to an "out of memory" error (7). On the other hand, if I set the
picture type to 3 for icons, I run into an "invalid picture" error. Since
all the code examples I've run into so far seem to attempt to utilise api
calls, I assume I'm going to have to grapple with trying to understand them.
However, I'm completely stumped as to what is wrong with the code below.
Have you got any ideas?
The onload event in my form calls the GetIcon code, which then calls the
GetIconFromHandle sub. As far as I can tell, the GetIcon code is working,
but the problem rests with the GetIconFromHandle code.
' **********************************************************
' Module Code
' **********************************************************
Option Compare Database
Option Explicit
'For looking at registry keys
'To: Open key ready to look at
Private Declare Function RegValue Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
'To: Look at key
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal lpReserved As Long, lpType As Long, ByVal lpData As Any, lpcbData As
Long) As Long
'To: Close the key when it's finished with
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long)
As Long
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const KEY_READ = &H20019 'To allow us to READ the registery keys
'For Drawing the icon
'To: Retrieve the icon from the .EXE, .DLL or .ICO
Private Declare Function ExtractIcon Lib "shell32.dll" Alias _
"ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal
nIconIndex As Long) As Long
'To: Draw the icon into our picture box
Private Declare Function DrawIcon Lib "user32.dll" _
(ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long)
As Long
'To: Clean up after our selves (destroy the icon that "ExtractIcon" created)
Private Declare Function DestroyIcon Lib "user32.dll" (ByVal hIcon As Long)
As Long
'For Finding the System folder
Private Declare Function GetSystemDirectory Lib "kernel32.dll" Alias _
"GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As
Long
Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const PICTYPE_UNINITIALIZED = -1
Const PICTYPE_NONE = 0
Const PICTYPE_BITMAP = 1
Const PICTYPE_METAFILE = 2
Const PICTYPE_ICON = 3
Const PICTYPE_ENHMETAFILE = 4
Dim strPictureFile As String
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, _
RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
' **********************************************************
Public Function GetIcon(strExtension As String) As StdPicture
Dim strFileType As String
Dim strIconFile As String
Dim lngIconHandle As Long
Dim lngIconNumber As Long
Dim lngRegKeyHandle As Long
Dim hdlProcessHandle As Long
Dim lngStringLength As Long
hdlProcessHandle = GetCurrentProcessId
'Search the registry for the file type associated with this extension
'(e.g. Word.Document.8)
strFileType = RegValue(HKEY_CLASSES_ROOT, "." & strExtension,
lngRegKeyHandle)
' strFileType = RegValue(HKEY_CLASSES_ROOT, "." & strExtension,
vbNullString)
'Search the registry for the default icon associated with this file
'type (e.g. C:\Windows\...\wordicon.exe,1)
strIconFile = RegValue(HKEY_CLASSES_ROOT, strFileType & "\DefaultIcon",
lngRegKeyHandle)
' strIconFile = RegValue(HKEY_CLASSES_ROOT, strFileType & "\DefaultIcon",
lngRegKeyHandle vbNullString)
'Trim the icon number out of this string (e.g. 1)
lngIconNumber = Trim(Right(strIconFile, Len(strIconFile) -
InStrRev(strIconFile, ",")))
'Trim the icon file out of this string (e.g.
'C:\Windows\...\wordicon.exe)
strIconFile = Trim(Left(strIconFile, Len(strIconFile) -
InStrRev(strIconFile, ",")))
Draw_Icon:
'Get a handle to this icon
lngIconHandle = ExtractIcon(hdlProcessHandle, strIconFile, lngIconNumber)
' If 1 or 0 then no Icon could be retrieved
If lngIconHandle = 1 Or lngIconHandle = 0 Then GoTo No_Icon
'Create a picture from this handle and return it
Set GetIcon = GetIconFromHandle(lngIconHandle)
'CreateOlePicture(lngIconHandle, 3) '
Exit Function
No_Icon:
' No icon could be found so we use the normal windows icon
' This icon is held in shell32.dll in the system director, Icon 0
strIconFile = Space(260)
lngStringLength = GetSystemDirectory(strIconFile, 260)
strIconFile = Left(strIconFile, lngStringLength) & "\SHELL32.DLL"
lngIconNumber = 0
GoTo Draw_Icon
End Function
' **********************************************************
Public Function GetIconFromHandle(ByVal Handle As Long) As StdPicture
Dim IID_IDispatch As GUID
Dim uPicinfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
'Create the interface GUID for the picture
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
..hPal = 0
..hPic = hPtr
..Size = Len(uPicinfo)
..Type = PICTYPE_BITMAP <----- results in "out of memory" error, and changing
it to PICTYPE_ICON results in an "invalid picture" error
End With
'Create the picture object
OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
Set GetIconFromHandle = IPic
End Function
Regards
Bob
