Solved

ExtractAssociatedIcon

Posted on 2001-08-02
3
1,817 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 70

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

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Introduction I needed to skip over some file processing within a For...Next loop in some old production code and wished that VB (classic) had a statement that would drop down to the end of the current iteration, bypassing the statements that were c…
When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
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…

837 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