获取图标.bas

新魔剑压缩机。采用新的压缩算法对文件压缩。

Attribute VB_Name = "获取图标"
Option Explicit

Private Const MAX_PATH = 260
Private Type SHFILEINFO
        hIcon As Long                       '  out: icon
        iIcon As Long                       '  out: icon index
        dwAttributes As Long                '  out: SFGAO_ flags
        szDisplayName As String * MAX_PATH  '  out: display name (or path)
        szTypeName As String * 80           '  out: type name
End Type
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Const SHGFI_LARGEICON = &H0                      '获取大图标
Private Const SHGFI_SMALLICON = &H1                      '获取小图标
Private Const SHGFI_OPENICON = &H2                       '?
Private Const SHGFI_SHELLICONSIZE = &H4                  '?
Private Const SHGFI_PIDL = &H8                           '?
Private Const SHGFI_USEFILEATTRIBUTES = &H10             '使用传递的dwFileAttribute值
Private Const SHGFI_ICON = &H100                         '获取图标句柄
Private Const SHGFI_DISPLAYNAME = &H200                  '?
Private Const SHGFI_TYPENAME = &H400                     '?
Private Const SHGFI_ATTRIBUTES = &H800                   '?
Private Const SHGFI_ICONLOCATION = &H1000                '?
Private Const SHGFI_EXETYPE = &H2000                     '?
Private Const SHGFI_SYSICONINDEX = &H4000                '获取系统Icon索引值(存在iIcon中,返回值为hImageList)
Private Const SHGFI_LINKOVERLAY = &H8000                 '  put a link overlay on icon
Private Const SHGFI_SELECTED = &H10000                   '  show icon in selected state
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long


Public Function AddIcon(FileName As String, Picture As PictureBox, ImageList As ImageList) As String
On Error GoTo Err
Dim fInfo As SHFILEINFO
Dim ret As Long
If InStr(FileName, ".") Then
  AddIcon = "DS" & Mid$(FileName, InStrRev(FileName, "."))
Else
  AddIcon = "UnknowFile"
  Exit Function
End If
If Not (ImageList.ListImages.Item(AddIcon) Is Nothing) Then Exit Function
Err:
ret = SHGetFileInfo(FileName, 0&, fInfo, Len(fInfo), SHGFI_USEFILEATTRIBUTES Or SHGFI_SHELLICONSIZE Or SHGFI_ICON Or SHGFI_SMALLICON)
Picture.Cls
DrawIcon Picture.hdc, 0, 0, fInfo.hIcon
DestroyIcon fInfo.hIcon
Picture.Refresh
ImageList.ListImages.Add , AddIcon, Picture.Image
End Function