home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / Zipping_wi2123818172008.psc / mFileIcons.bas < prev    next >
BASIC Source File  |  2008-08-15  |  7KB  |  210 lines
  1. Attribute VB_Name = "modFileIcons"
  2.  
  3. 'this part is not by myself.  JvB
  4.  
  5. Option Explicit
  6.  
  7. ' =================================================================================
  8. ' Declares and types
  9. ' =================================================================================
  10. Private Const MAX_PATH = 260
  11. Private Type SHFILEINFO
  12.     hIcon As Long
  13.     iIcon As Long
  14.     dwAttributes As Long
  15.     szDisplayName As String * MAX_PATH
  16.     szTypeName As String * 80
  17. End Type
  18. Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _
  19.     (ByVal pszPath As String, ByVal dwAttributes As Long, psfi As SHFILEINFO, ByVal _
  20.     cbSizeFileInfo As Long, ByVal uFlags As Long) As Long
  21. Private Enum EShellGetFileInfoConstants
  22.         SHGFI_ICON = &H100                ' // get icon
  23.         SHGFI_DISPLAYNAME = &H200            ' // get display name
  24.         SHGFI_TYPENAME = &H400            ' // get type name
  25.         SHGFI_ATTRIBUTES = &H800            ' // get attributes
  26.         SHGFI_ICONLOCATION = &H1000        ' // get icon location
  27.         SHGFI_EXETYPE = &H2000            ' // return exe type
  28.         SHGFI_SYSICONINDEX = &H4000        ' // get system icon index
  29.         SHGFI_LINKOVERLAY = &H8000        ' // put a link overlay on icon
  30.         SHGFI_SELECTED = &H10000            ' // show icon in selected state
  31.         SHGFI_ATTR_SPECIFIED = &H20000    ' // get only specified attributes
  32.         SHGFI_LARGEICON = &H0                ' // get large icon
  33.         SHGFI_SMALLICON = &H1                ' // get small icon
  34.         SHGFI_OPENICON = &H2                ' // get open icon
  35.         SHGFI_SHELLICONSIZE = &H4            ' // get shell size icon
  36.         SHGFI_PIDL = &H8                    ' // pszPath is a pidl
  37.         SHGFI_USEFILEATTRIBUTES = &H10    ' // use passed dwFileAttribute
  38. End Enum
  39. Private Type PictDesc
  40.     cbSizeofStruct As Long
  41.     picType As Long
  42.     hImage As Long
  43.     xExt As Long
  44.     yExt As Long
  45. End Type
  46. Private Type Guid
  47.     Data1 As Long
  48.     Data2 As Integer
  49.     Data3 As Integer
  50.     Data4(0 To 7) As Byte
  51. End Type
  52. Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
  53.     (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic _
  54.     As IPicture) As Long
  55. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As _
  56.     Long
  57.  
  58. Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal _
  59.     nBufferLength As Long, ByVal lpBuffer As String) As Long
  60. Private Declare Function GetTempFileName Lib "kernel32" Alias _
  61.     "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, _
  62.     ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
  63.  
  64. ' =================================================================================
  65. ' Interface
  66. ' =================================================================================
  67. Public Enum EGetIconTypeConstants
  68.     egitSmallIcon = 1
  69.     egitLargeIcon = 2
  70. End Enum
  71.  
  72.  
  73. Private Function GetIcon(ByVal sFIle As String, Optional ByVal EIconType As _
  74.     EGetIconTypeConstants = egitLargeIcon) As Object
  75. Dim lR As Long
  76. Dim hIcon As Long
  77. Dim tSHI As SHFILEINFO
  78. Dim lFlags As Long
  79.     
  80.     ' Prepare flags for SHGetFileInfo to get the icon:
  81.     If (EIconType = egitLargeIcon) Then
  82.         lFlags = SHGFI_ICON Or SHGFI_LARGEICON
  83.     Else
  84.         lFlags = SHGFI_ICON Or SHGFI_SMALLICON
  85.     End If
  86.     lFlags = lFlags And Not SHGFI_LINKOVERLAY
  87.     lFlags = lFlags And Not SHGFI_OPENICON
  88.     lFlags = lFlags And Not SHGFI_SELECTED
  89.     ' Call to get icon:
  90.     lR = SHGetFileInfo(sFIle, 0&, tSHI, Len(tSHI), lFlags)
  91.     If (lR <> 0) Then
  92.         ' If we succeeded, the hIcon member will be filled in:
  93.         hIcon = tSHI.hIcon
  94.         ' If we have an icon, convert it to a VB picture and return it:
  95.         If Not (hIcon = 0) Then
  96.             Set GetIcon = IconToPicture(hIcon)
  97.         End If
  98.     End If
  99.     
  100. End Function
  101. Private Function IconToPicture(ByVal hIcon As Long) As IPicture
  102.     
  103.     If hIcon = 0 Then Exit Function
  104.         
  105.     ' This is all magic if you ask me:
  106.     Dim NewPic As Picture, PicConv As PictDesc, IGuid As Guid
  107.     
  108.     PicConv.cbSizeofStruct = Len(PicConv)
  109.     PicConv.picType = vbPicTypeIcon
  110.     PicConv.hImage = hIcon
  111.     
  112.     'IGuid.Data1 = &H20400
  113.     'IGuid.Data4(0) = &HC0
  114.     'IGuid.Data4(7) = &H46
  115.     ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  116.     With IGuid
  117.         .Data1 = &H7BF80980
  118.         .Data2 = &HBF32
  119.         .Data3 = &H101A
  120.         .Data4(0) = &H8B
  121.         .Data4(1) = &HBB
  122.         .Data4(2) = &H0
  123.         .Data4(3) = &HAA
  124.         .Data4(4) = &H0
  125.         .Data4(5) = &H30
  126.         .Data4(6) = &HC
  127.         .Data4(7) = &HAB
  128.     End With
  129.     OleCreatePictureIndirect PicConv, IGuid, True, NewPic
  130.     
  131.     Set IconToPicture = NewPic
  132.     
  133. End Function
  134. Private Function GetFileTypeName(ByVal sFIle As String) As String
  135. Dim lR As Long
  136. Dim tSHI As SHFILEINFO
  137. Dim iPos As Long
  138.  
  139.     lR = SHGetFileInfo(sFIle, 0&, tSHI, Len(tSHI), SHGFI_TYPENAME)
  140.     If (lR <> 0) Then
  141.         iPos = InStr(tSHI.szTypeName, Chr$(0))
  142.         If (iPos = 0) Then
  143.             GetFileTypeName = tSHI.szTypeName
  144.         ElseIf (iPos > 1) Then
  145.             GetFileTypeName = Left$(tSHI.szTypeName, (iPos - 1))
  146.         Else
  147.             GetFileTypeName = ""
  148.         End If
  149.     End If
  150.     
  151. End Function
  152. Public Function AddIconToImageList(ByVal sFIle As String, ByRef ilsThis As _
  153.     ImageList, ByVal sDefault As String) As String
  154. Dim sExt As String
  155. Dim sTempFile As String
  156. Dim i As Long
  157. Dim iFile As Long
  158. Dim iIndex As Long
  159.  
  160.    For i = Len(sFIle) To 1 Step -1
  161.       If (Mid$(sFIle, i, 1) = ".") Then
  162.          sExt = Mid$(sFIle, i)
  163.          Exit For
  164.       End If
  165.    Next i
  166.    sExt = UCase$(sExt)
  167.    If (sExt <> "") And (sExt <> "EXE") Then
  168.       On Error Resume Next
  169.       iIndex = ilsThis.ListImages(sExt).Index
  170.       If (Err.Number = 0) Then
  171.          AddIconToImageList = sExt
  172.       Else
  173.          On Error GoTo ErrorHandler
  174.          sTempFile = TempDir
  175.          If (Right$(sTempFile, 1) <> "\") Then sTempFile = sTempFile & "\"
  176.          sTempFile = sTempFile & "VBUZTEMP" & sExt
  177.          KillFileIfExists sTempFile
  178.          iFile = FreeFile
  179.          Open sTempFile For Binary Access Write As #iFile
  180.          Put #iFile, , "TEMP"
  181.          Close #iFile
  182.          ilsThis.ListImages.Add , sExt, GetIcon(sTempFile, egitLargeIcon) 'egitSmallIcon)
  183.          ilsThis.ListImages(sExt).Tag = GetFileTypeName(sTempFile)
  184.          KillFileIfExists sTempFile
  185.          AddIconToImageList = sExt
  186.       End If
  187.    Else
  188.       AddIconToImageList = sDefault
  189.    End If
  190.    Exit Function
  191.    
  192. ErrorHandler:
  193.    KillFileIfExists sTempFile
  194.    AddIconToImageList = sDefault
  195.    Exit Function
  196. End Function
  197.  
  198. Public Sub KillFileIfExists(ByVal sFIle As String)
  199.    On Error Resume Next
  200.    Kill sFIle
  201. End Sub
  202.  
  203. Public Property Get TempDir() As String
  204. Dim sRet As String, c As Long
  205.     sRet = String$(MAX_PATH, 0)
  206.     c = GetTempPath(MAX_PATH, sRet)
  207.     If c = 0 Then Err.Raise Err.LastDllError
  208.     TempDir = Left$(sRet, c)
  209. End Property
  210.