'===========================================================================
' Subject: Get ICON from  Name                Date: 12-22-02 (  :  )       
'  Author: Edwin Knoppert                     Code: PBWIN,PBDLL            
'  Origin: ebknoppert@hotmail.com           Packet: PBDLL.ABC
'===========================================================================
'Icon from Name
'Edwin Knoppert Email:  ebknoppert@hotmail.com 

#Compile Exe 
  
Option Explicit 
  
#Include "win32api.inc" 
#Include "IcoByNam.inc" 
  
CallBack Function DlgProc() As Long 
  
    Static hIcon As Long 
  
    Select Case CbMsg 
    Case %WM_INITDIALOG 
  
   hIcon = IcoByName( "*.doc", 1, 0 ) 
'   hIcon = IcoByName( "c:\windows\calc.exe", 1, 0 ) 
'   hIcon = IcoByName( curdir$, 1, 1 ) 
   If hIcon Then 
  SendMessage CbHndl, %WM_SETICON, %ICON_BIG, hIcon 
  SendMessage CbHndl, %WM_SETICON, %ICON_SMALL, hIcon 
   End If 
  
    Case %WM_DESTROY 
  
   If hIcon Then DestroyIcon hIcon 
  
    End Select 
  
End Function 
  
Function WinMain ( ByVal hCurInstance  As Long, _ 
    ByVal hPrevInstance As Long, _ 
    lpszCmdLine    As Asciiz Ptr, _ 
    ByVal nCmdShow As Long ) As Long 
  
    Dim a  As Long 
    Dim hDlg    As Long 
    Dim Result  As Long 
  
    Dialog New 0, "Icon by name",,, 240, 180 _ 
   ,  %WS_OVERLAPPED _ 
   Or %WS_SYSMENU _ 
   Or %WS_MINIMIZEBOX _ 
   Or %WS_MAXIMIZEBOX _ 
   Or %WS_THICKFRAME _ 
   Or %WS_CLIPSIBLINGS _ 
   Or %WS_CLIPCHILDREN _ 
   To hDlg 
  
    If hDlg = 0 Then Exit Function 
  
    Dialog Show Modal hDlg Call DlgProc To Result 
  
    Function = 1 
  
End Function 
'-----------------------------------------------------------------
'// Retrieve a system icon from a file or extension. 
'// Examples: 
  
'hIcon = IcoByName( "*.doc", 1, 1 ) 
'Or 
'hIcon = IcoByName( "c:\windows\calc.exe", 1, 0 ) 
'Or 
'hIcon = IcoByName( CurDir$, 1, 1 ) 
  
'// Set to dialog (Use both) 
'SendMessage CbHndl, %WM_SETICON, %ICON_BIG, hIcon 
'SendMessage CbHndl, %WM_SETICON, %ICON_SMALL, hIcon 
  
'// You must destroy the icon yourself by using: 
'If hIcon Then DestroyIcon hIcon 
  
Function IcoByName( ByVal sExtension As String, ByVal bSmall As Long, ByVal bOpen As Long ) As Long 
  
    Dim dwFlags     As Dword 
    Dim sfi    As SHFILEINFO 
  
    sExtension = Trim$( Trim$( Trim$( sExtension ), Chr$( 34 ) ) ) 
    If sExtension = "" Then Exit Function 
  
    dwFlags = %SHGFI_ICON 
    If Left$( sExtension, 1 ) = "*" Then dwFlags = dwFlags Or %SHGFI_USEFILEATTRIBUTES 
    If bSmall Then dwFlags = dwFlags Or %SHGFI_SMALLICON 
    If bOpen  Then dwFlags = dwFlags Or %SHGFI_OPENICON 
  
    sfi.dwAttributes = %FILE_ATTRIBUTE_NORMAL 
    SHGetFileInfo ByVal StrPtr( sExtension ), 0, sfi, Len( sfi ), dwFlags 
    Function = sfi.hIcon 
  
End Function