Solved

ExtractAssociatedIcon

Posted on 2001-08-02
3
1,789 Views
Last Modified: 2007-11-27
Need some help with the ExtractAssociatedIcon function,
When I use the function the return value is the handle of the associated icon, but it is in 32x32 format which causes the icon to be blurry when i use the DrawIconEx at 16x16 size.

Therefore I chosed to extract the 16x16 icon manually by using the path that GetAssociatedIcon is supposeed to receive (IconExe variable and IconIndex variable).

but the problem is that the function always receive the "c:\windows\system\shell32.dll" file?! instead of the actuall icon file. It causes the extracticonex to always receive the same icon.. why????

anyone have a solution?



----------------

'Declarations
Private Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, lpiIcon As Long) As Long
Private Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Const DI_MASK = &H1
Const DI_IMAGE = &H2
Const DI_NORMAL = DI_MASK Or DI_IMAGE
Const MAX_PATH = 260




Dim mIcon As Long
Dim IconExe As String
Dim IconIndex As Long

Dim glLargeIcons() As Long
Dim glSmallicons() As Long
ReDim glLargeIcons(0)
ReDim glSmallicons(0)

Dim X As Integer

   IconExe = "c:\myfile.txt"
   IconExe = IconExe & Space(MAX_PATH - Len(IconExe))  
   IconIndex = 0

   'Here is the problem, the fu**ing function doesn't work
   mIcon = ExtractAssociatedIcon(App.hInstance, IconExe, IconIndex)
   

   Call ExtractIconEx(IconExe, IconIndex, glLargeIcons(0), glSmallicons(0), 1)
   
   DrawIconEx Picture1.hdc, 0, 0, glSmallicons(0), 16, 16, 0, 0, DI_NORMAL
   
   DestroyIcon mIcon
   For X = 0 To UBound(glLargeIcons)
      DestroyIcon glLargeIcons(X)
      DestroyIcon glSmallicons(X)
   Next X
0
Comment
Question by:Marshow
3 Comments
 
LVL 69

Expert Comment

by:Éric Moreau
ID: 6346857
0
 
LVL 1

Accepted Solution

by:
Aaron_Young earned 200 total points
ID: 6346954

Here's one way to do it:

'---------------------------------------------------------
' In a Module:
'
' API Constants and Declares.
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const KEY_QUERY_VALUE = &H1
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_MORE_DATA = 234

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.

Public Function GetAssociatedIconSource(ByVal sFile As String, ByRef lIndex As Long) As String
    ' Returns the Icon Resource being used to supply the specified files associated icon
    ' Extracted from the HKEY_CLASSES_ROOT Hive, will also return the ResourceID/Index for the Icon
    ' In the Resource via the ByRef parameter: <lIndex>
    Dim sSource As String, sKey As String, sName As String
    Dim lKey As Long, lType As Long, lSize As Long
   
    ' Get just the extension of the file
    sKey = "." & LCase(JustExt(sFile))
   
    ' If there is no extension, abort.
    If Len(sKey) = 0 Then Exit Function
   
    ' Open the Registry Key for this Extension, i.e. ".txt",
    ' If it doesn't exist in the HKEY_CLASSES_ROOT Hive, Abort.
    If RegOpenKeyEx(HKEY_CLASSES_ROOT, ByVal sKey, 0, KEY_QUERY_VALUE, lKey) <> ERROR_SUCCESS Then Exit Function
   
    ' Extract the default value, which points to another Key in the same hive, this is normally
    ' More descriptive, i.e. "txtFile"
    If RegQueryValueEx(lKey, "", 0, lType, "", lSize) = ERROR_MORE_DATA Then
        sName = Space(lSize - 1)
        If RegQueryValueEx(lKey, "", 0, lType, ByVal sName, lSize) <> ERROR_SUCCESS Then sName = ""
    End If
   
    ' Close the Key
    Call RegCloseKey(lKey)
   
    ' If no default value was found, Abort.
    If Len(sName) = 0 Then Exit Function
   
    ' Append the "\DefaultIcon" string to the "Default" value, i.e. "txtFile\DefaultIcon"
    sName = sName & "\DefaultIcon"
   
    ' Search for this new key from the CLASSES hive,
    ' If it's not there, Abort.
    If RegOpenKeyEx(HKEY_CLASSES_ROOT, ByVal sName, 0, KEY_QUERY_VALUE, lKey) <> ERROR_SUCCESS Then Exit Function
   
    ' Extract the default value for this Key, this is the IconResource windows uses
    ' for this file association, i.e. "Shell.dll,-153"
    lType = 0
    lSize = 0
    If RegQueryValueEx(lKey, "", 0, lType, "", lSize) = ERROR_MORE_DATA Then
        sSource = Space(lSize - 1)
        If RegQueryValueEx(lKey, "", 0, lType, ByVal sSource, lSize) <> ERROR_SUCCESS Then sSource = ""
    End If
   
    ' Close the Key
    Call RegCloseKey(lKey)
   
    ' If there isn't a comma in the Resource, i.e. no ResourceID or Index, Abort.
    If InStr(sSource, ",") = 0 Then Exit Function
   
    ' Extract the value of the ResourceID/Index to the "lIndex" parameter reference
    lIndex = Val(Mid(sSource, InStr(sSource, ",") + 1))
    ' Extract only the Resource File, i.e. "Shell.dll" and return it.
    sSource = Left(sSource, InStr(sSource, ",") - 1)
    GetAssociatedIconSource = sSource
End Function

Function JustExt(ByVal sFile As String) As String
    ' Function to just extract a files extension, i.e. "Text.txt" returns "txt"
    If InStr(sFile, ".") Then JustExt = Mid(sFile, InStrRev(sFile, ".") + 1)
End Function
'---------------------------------------------------------

'---------------------------------------------------------
' In a Form with a Picturebox and Command Button
'
Private Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long

Private Const DI_MASK = &H1
Private Const DI_IMAGE = &H2
Private Const DI_NORMAL = DI_MASK Or DI_IMAGE

Private Sub Command1_Click()
    Dim sFile As String, sSource As String
    Dim lLarge As Long, lSmall As Long, lIndex As Long
   
    ' Set the file we want to extract the icon(s) for
    sFile = "C:\SomeThing.txt"
   
    ' Get the Files Associated Icon Resource and Index/ID
    sSource = GetAssociatedIconSource(sFile, lIndex)
   
    ' If a Resource was not found, Abort.
    If Len(sSource) = 0 Then Exit Sub
   
    ' Extract the Large and Small versions of this Icon from the resource
    Call ExtractIconEx(sSource, lIndex, lLarge, lSmall, 1)
    ' Draw Both in a Picturebox
    Call DrawIconEx(Picture1.hdc, 0, 0, lSmall, 0, 0, 0, 0, DI_NORMAL)
    Call DrawIconEx(Picture1.hdc, 32, 0, lLarge, 0, 0, 0, 0, DI_NORMAL)
    ' Destroy the Icon Handles
    Call DestroyIcon(lLarge)
    Call DestroyIcon(lSmall)
End Sub
'---------------------------------------------------------

Regards,

- Aaron.
0
 
LVL 4

Expert Comment

by:nutwiss
ID: 6348106
"c:\windows\system\shell32.dll" is where all (well most) of the windows standard icons are stored - so the function is working correctly - there are no ICO files for the standard filetype icons installed with windows.
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…

758 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now