home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Simple_Mac2110964282008.psc / class / clsGetIconFile.cls < prev    next >
Text File  |  2008-04-03  |  10KB  |  330 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsGetIconFile"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. 'Author         : Noel A. Dacara (noeldacara@yahoo.com)
  17. 'Filename       : Get File Icon.cls (cFileIcon Class Module)
  18. 'Description    : Get icon(s) of an existing file
  19. 'Date           : Tuesday, January 07, 2003, 10:12 AM
  20. 'Last Update    : Friday, November 25, 2005, 12:28 AM
  21.  
  22. 'You can freely use and distribute this class or upload these codes on any site
  23. 'provided that the original credits are kept unmodified.
  24.  
  25. 'Keep note that :
  26. 'If File property is not set, the current directory will automatically be used by API.
  27.  
  28. 'Credits goes to:
  29. 'Makers of the great Win32 Programmer's Reference, don't know who you are but thanks.
  30. 'Christoph von Wittich (Christoph@ActiveVB.de), author of ApiViewer 2004 for the APIs
  31.  
  32. 'Modified API Declaration
  33. Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, ByRef psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As ESHGetFileInfoFlagConstants) As Long
  34. Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (ByRef lpPictDesc As PictDesc, ByRef riid As Guid, ByVal fOwn As Long, ByRef lplpvObj As IPictureDisp)
  35.  
  36. 'API Constants
  37. Private Const ERRORAPI As Long = 0
  38. Private Const MAX_PATH As Long = 260
  39.  
  40. 'API Types
  41. Private Type Guid
  42.     Data1           As Long
  43.     Data2           As Integer
  44.     Data3           As Integer
  45.     Data4(0 To 7)   As Byte
  46. End Type
  47.  
  48. Private Type PictDesc
  49.     cbSizeofStruct  As Long
  50.     picType         As Long
  51.     hImage          As Long
  52.     xExt            As Long
  53.     yExt            As Long
  54. End Type
  55.  
  56. Private Type SHFILEINFO
  57.     hIcon           As Long ' : icon
  58.     iIcon           As Long ' : icondex
  59.     dwAttributes    As Long ' : SFGAO_ flags
  60.     szDisplayName   As String * MAX_PATH ' : display name (or path)
  61.     szTypeName      As String * 80 ' : type name
  62. End Type
  63.  
  64. 'User-Defined API Enum
  65. Private Enum ESHGetFileInfoFlagConstants
  66.     SHGFI_ATTRIBUTES = &H800        'get file attributes
  67.     SHGFI_DISPLAYNAME = &H200       'get display name
  68.     SHGFI_EXETYPE = &H2000          'get exe type
  69.     SHGFI_ICON = &H100              'get icon handle and index
  70.     SHGFI_LARGEICON = &H0           'get file's large icon
  71.     SHGFI_LINKOVERLAY = &H8000      'add link overlay on the icon
  72.     SHGFI_OPENICON = &H2            'get file's open icon
  73.     SHGFI_SELECTED = &H10000        'blend icon with the system highlight color
  74.     SHGFI_SHELLICONSIZE = &H4       'get shell-sized icon
  75.     SHGFI_SMALLICON = &H1           'get file's small icon
  76.     SHGFI_SYSICONINDEX = &H4000     'get icon index from system image list
  77.     SHGFI_TYPENAME = &H400          'get file type description
  78.     SHGFI_USEFILEATTRIBUTES = &H10  'use dwFileAttributes parameter
  79. End Enum
  80.  
  81. Enum EFileIconTypeConstants
  82.     LargeIcon = 0
  83.     SmallIcon = 1
  84. End Enum
  85.  
  86. Enum EFileExeTypeConstants
  87.     MSDosApp = 2        'MS-DOS .EXE, .COM or .BAT file
  88.     NonExecutable = 0   'Nonexecutable file or an error condition
  89.     Win32Console = 3    'Win32 console application
  90.     WindowsApp = 1      'Windows application
  91. End Enum
  92.  
  93. 'Variable Declarations
  94. Private m_File      As String
  95. Private m_Handle    As Long
  96. Private m_IconType  As EFileIconTypeConstants
  97. Private m_OpenState As Boolean
  98. Private m_Overlay   As Boolean
  99. Private m_Selected  As Boolean
  100.  
  101. Property Get DisplayName(Optional File) As String
  102. 'Returns the display name of the specified file.
  103.     Dim p_Null  As Long
  104.     Dim p_Ret   As Long
  105.     Dim p_SHFI  As SHFILEINFO
  106.     
  107.     If IsMissing(File) Then
  108.         File = m_File
  109.     End If
  110.     
  111.     p_Ret = SHGetFileInfo(CStr(File), 0&, p_SHFI, Len(p_SHFI), SHGFI_DISPLAYNAME)
  112.     
  113.     If Not p_Ret = ERRORAPI Then
  114.         DisplayName = p_SHFI.szDisplayName
  115.         
  116.         p_Null = InStr(1, DisplayName, vbNullChar)
  117.         
  118.         If p_Null > 0& Then
  119.             DisplayName = Left$(DisplayName, p_Null - 1)
  120.         End If
  121.     End If
  122. End Property
  123.  
  124. Property Get ExeType(Optional File) As EFileExeTypeConstants
  125. 'Returns the display name of the specified file.
  126.     Dim p_Ret   As Long
  127.     Dim p_SHFI  As SHFILEINFO
  128.     
  129.     If IsMissing(File) Then
  130.         File = m_File
  131.     End If
  132.     
  133.     p_Ret = SHGetFileInfo(CStr(File), 0&, p_SHFI, Len(p_SHFI), SHGFI_EXETYPE)
  134.     
  135.     If p_Ret = 0 Then
  136.         ExeType = NonExecutable
  137.     Else
  138.         If HiWord(p_Ret) > 0 Then 'NE 0x00004E45 or PE 0x00005045
  139.             ExeType = WindowsApp
  140.         Else
  141.             Select Case LoWord(p_Ret)
  142.                 Case 23117 'MZ 0x00004D5A
  143.                     ExeType = MSDosApp
  144.                 Case 17744 'PE 0x00005045
  145.                     ExeType = Win32Console
  146.             End Select
  147.         End If
  148.     End If
  149. End Property
  150.  
  151. Property Get File() As String
  152. 'Returns/sets the complete file path to be used.
  153.     File = m_File
  154. End Property
  155.  
  156. Property Let File(Value As String)
  157.     m_File = Value
  158. End Property
  159.  
  160. Property Get Handle() As Long
  161. 'Returns/sets the icon handle to be used by the IconEx property.
  162.     Handle = m_Handle
  163. End Property
  164.  
  165. Property Let Handle(Value As Long)
  166.     m_Handle = Value
  167. End Property
  168.  
  169. Property Get IconType() As EFileIconTypeConstants
  170. 'Returns/sets the type of icon to retrieve.
  171.     IconType = m_IconType
  172. End Property
  173.  
  174. Property Let IconType(Value As EFileIconTypeConstants)
  175.     m_IconType = Value
  176. End Property
  177.  
  178. Property Get Icon(Optional File, Optional IconType) As IPictureDisp
  179. 'Returns the icon of the specified file.
  180.     If IsMissing(File) Then
  181.         File = m_File
  182.     End If
  183.     
  184.     If IsMissing(IconType) Then
  185.         IconType = m_IconType
  186.     End If
  187.     
  188.     Dim p_Flags As ESHGetFileInfoFlagConstants
  189.     Dim p_hIcon As Long
  190.     Dim p_Ret   As Long
  191.     Dim p_SHFI  As SHFILEINFO
  192.     
  193.     If m_IconType = LargeIcon Then
  194.         p_Flags = SHGFI_ICON Or SHGFI_LARGEICON
  195.     Else
  196.         p_Flags = SHGFI_ICON Or SHGFI_SMALLICON
  197.     End If
  198.     
  199.     If m_Overlay Then
  200.         p_Flags = p_Flags Or SHGFI_LINKOVERLAY
  201.     End If
  202.     
  203.     If m_Selected Then
  204.         p_Flags = p_Flags Or SHGFI_SELECTED
  205.     Else
  206.         p_Flags = p_Flags And Not SHGFI_SELECTED
  207.     End If
  208.     
  209.     If m_OpenState Then
  210.         p_Flags = p_Flags Or SHGFI_OPENICON
  211.     Else
  212.         p_Flags = p_Flags And Not SHGFI_OPENICON
  213.     End If
  214.     
  215.     p_Ret = SHGetFileInfo(CStr(File), 0&, p_SHFI, Len(p_SHFI), p_Flags)
  216.     
  217.     If Not p_Ret = ERRORAPI Then
  218.         p_hIcon = p_SHFI.hIcon
  219.         
  220.         If Not p_hIcon = 0& Then
  221.             Set Icon = IconEx(p_hIcon)
  222.         End If
  223.     End If
  224. End Property
  225.  
  226. Property Get IconEx(Optional hIcon As Long) As IPictureDisp
  227. 'Returns the file's icon using the specified icon handle.
  228.     If hIcon = 0& Then
  229.         hIcon = m_Handle
  230.         
  231.         If hIcon = 0& Then
  232.             Exit Property
  233.         End If
  234.     End If
  235.     
  236.     Dim p_Picture   As IPictureDisp
  237.     Dim p_PicDesc   As PictDesc
  238.     Dim p_Guid      As Guid
  239.     
  240.     p_PicDesc.cbSizeofStruct = Len(p_PicDesc)
  241.     p_PicDesc.picType = vbPicTypeIcon
  242.     p_PicDesc.hImage = hIcon
  243.     
  244.     'IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  245.     With p_Guid
  246.         .Data1 = &H7BF80980
  247.         .Data2 = &HBF32
  248.         .Data3 = &H101A
  249.         .Data4(0) = &H8B
  250.         .Data4(1) = &HBB
  251.         .Data4(2) = &H0
  252.         .Data4(3) = &HAA
  253.         .Data4(4) = &H0
  254.         .Data4(5) = &H30
  255.         .Data4(6) = &HC
  256.         .Data4(7) = &HAB
  257.     End With
  258.     'From vbAccelerator... (http://www.vbaccelerator.com)
  259.     
  260.     OleCreatePictureIndirect p_PicDesc, p_Guid, True, p_Picture
  261.     
  262.     Set IconEx = p_Picture
  263. End Property
  264.  
  265. Property Get LinkOverlay() As Boolean
  266. 'Returns/sets a value to determine if a linkoverlay icon is displayed on the icon.
  267.     LinkOverlay = m_Overlay
  268. End Property
  269.  
  270. Property Let LinkOverlay(Value As Boolean)
  271.     m_Overlay = Value
  272. End Property
  273.  
  274. Property Get OpenState() As Boolean
  275. 'Returns/sets a value to determine if the icon will be in open state. (Ex. Folders)
  276.     OpenState = m_OpenState
  277. End Property
  278.  
  279. Property Let OpenState(Value As Boolean)
  280.     m_OpenState = Value
  281. End Property
  282.  
  283. Property Get Selected() As Boolean
  284. 'Returns/sets a value to determine if the icon is in selected state.
  285.     Selected = m_Selected
  286. End Property
  287.  
  288. Property Let Selected(Value As Boolean)
  289.     m_Selected = Value
  290. End Property
  291.  
  292. Property Get TypeName(Optional File) As String
  293. 'Returns the type name of the specified file.
  294.     Dim p_Null  As Long
  295.     Dim p_Ret   As Long
  296.     Dim p_SHFI  As SHFILEINFO
  297.     
  298.     If IsMissing(File) Then
  299.         File = m_File
  300.     End If
  301.     
  302.     p_Ret = SHGetFileInfo(CStr(File), 0&, p_SHFI, Len(p_SHFI), SHGFI_TYPENAME)
  303.     
  304.     If Not p_Ret = ERRORAPI Then
  305.         TypeName = p_SHFI.szTypeName
  306.         
  307.         p_Null = InStr(1, TypeName, vbNullChar)
  308.         
  309.         If p_Null > 0& Then
  310.             TypeName = Left$(TypeName, p_Null - 1)
  311.         End If
  312.     End If
  313. End Property
  314.  
  315. 'Private properties
  316. Private Property Get HiWord(DWord As Long) As Long
  317.     HiWord = (DWord And &HFFFF0000) \ &H10000
  318. End Property
  319.  
  320. Private Property Get LoWord(DWord As Long) As Long
  321.     If DWord And &H8000& Then
  322.         LoWord = DWord Or &HFFFF0000
  323.     Else
  324.         LoWord = DWord And &HFFFF&
  325.     End If
  326. End Property
  327.  
  328. 'Created by Noel A. Dacara | Copyright ⌐ 2003-2005 Davao City, Philippines
  329.  
  330.