Memperoleh Icon Asosiasi File Menggunakan SHFileInfo

Option Explicit

Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_EXETYPE = &H2000
Private Const SHGFI_SYSICONINDEX = &H4000
Private Const SHGFI_LARGEICON = &H0
Private Const SHGFI_SMALLICON = &H1
Private Const ILD_TRANSPARENT = &H1
Private Const SHGFI_SHELLICONSIZE = &H4
Private Const SHGFI_TYPENAME = &H400
Private Const BASIC_SHGFI_FLAGS = SHGFI_TYPENAME Or SHGFI_SHELLICONSIZE Or SHGFI_SYSICONINDEX Or SHGFI_DISPLAYNAME Or SHGFI_EXETYPE

Private Const MAX_PATH = 260

Private Type SHFILEINFO
    hIcon          As Long
    iIcon          As Long
    dwAttributes   As Long
    szDisplayName  As String * MAX_PATH
    szTypeName     As String * 80
End Type

Private Declare Function ImageList_Draw Lib "comctl32.dll" (ByVal himl As Long, ByVal i As Long, ByVal hDCDest As Long, ByVal x As Long, ByVal y As Long, ByVal flags As Long) As Long
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As Long

Private Sub Form_Load()
    With picDummyPictureBox
        .AutoRedraw = True
        .AutoSize = True
        .Height = 495
        .Width = 495
        .Appearance = 0
        .Visible = False
    End With

    With picInvisiblePictureBox
        .AutoRedraw = True
        .AutoSize = True
        .Height = 495
        .Width = 495
        .Appearance = 0
        .Visible = False
    End With

    rtBox.OLEDropMode = rtfOLEDropManual

    picDummyPictureBox.Picture = LoadPicture("C:\Program Files\Microsoft Visual Studio\Common\Graphics\Icons\Flags\flgusa01.ico")

    Set lvFileList.SmallIcons = Nothing
    ilImages.ListImages.Clear
    ilImages.ListImages.Add , "dummy", picDummyPictureBox.Picture
    Set lvFileList.Icons = ilImages
End Sub

Private Sub rtBox_OLEDragDrop(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)

    Dim nCounter As Integer
    Dim lBoundary As Long

    For nCounter = 1 To Data.Files.Count
        StickIconOntoListView Data.Files(nCounter)
    Next nCounter
End Sub

Private Sub StickIconOntoListView(strFile As String)

    Dim hImgLarge As Long
    Dim hFile As Long
    Dim strFileType As String
    Dim strListImageKey As String
    Dim imgX As ListImage
    Dim hEXEType As Long
    Dim tEXEType As Long
    Dim lRet As Long
    Dim itmX As ListItem
    Dim shinfo As SHFILEINFO

    hImgLarge = SHGetFileInfo(strFile, 0&, shinfo, Len(shinfo), BASIC_SHGFI_FLAGS Or SHGFI_LARGEICON)

    strFileType = LCase(StripNulls(shinfo.szTypeName))

    If hImgLarge > 0 Then
        lRet = vbAddFileItemIcon(hImgLarge, shinfo)

        Set imgX = ilImages.ListImages.Add(, strFile, picInvisiblePictureBox.Picture)
        strListImageKey = strFile
    Else
    End If

    Set itmX = lvFileList.ListItems.Add(, , LCase(strFile))
    itmX.Icon = ilImages.ListImages(strListImageKey).Key

    Set itmX = Nothing
End Sub

Private Function vbAddFileItemIcon(hImage As Long, sInfo As SHFILEINFO) As Long

    Dim lRet As Long

    picInvisiblePictureBox.Picture = LoadPicture()
    lRet = ImageList_Draw(hImage, sInfo.iIcon, picInvisiblePictureBox.hdc, 0, 0, ILD_TRANSPARENT)

    picInvisiblePictureBox.Picture = picInvisiblePictureBox.Image
    picInvisiblePictureBox.Height = 495
    picInvisiblePictureBox.Width = 495

    vbAddFileItemIcon = lRet
End Function

Private Function StripNulls(strItem As String) As String

    Dim nPos As Integer

    nPos = InStr(strItem, Chr$(0))
    If nPos Then
        strItem = Left$(strItem, nPos - 1)
    End If
    StripNulls = strItem
End Function