form1.frm

利用VB编写软件显示文件图标

VERSION 5.00
Begin VB.Form ShowIconsForm 
   Caption         =   "ShowIcons"
   ClientHeight    =   4245
   ClientLeft      =   1650
   ClientTop       =   1545
   ClientWidth     =   3375
   LinkTopic       =   "Form1"
   ScaleHeight     =   283
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   225
   Begin VB.TextBox PatternText 
      Height          =   285
      Left            =   0
      TabIndex        =   5
      Text            =   "*.*"
      Top             =   3960
      Width           =   2175
   End
   Begin VB.FileListBox FileList 
      Height          =   2235
      Left            =   0
      TabIndex        =   4
      Top             =   1680
      Width           =   2175
   End
   Begin VB.DirListBox DirList 
      Height          =   1215
      Left            =   0
      TabIndex        =   3
      Top             =   360
      Width           =   2175
   End
   Begin VB.DriveListBox DriveList 
      Height          =   315
      Left            =   0
      TabIndex        =   2
      Top             =   0
      Width           =   2175
   End
   Begin VB.PictureBox LargeIconPicture 
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   480
      Left            =   2280
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   1
      Top             =   360
      Width           =   480
   End
   Begin VB.PictureBox SmallIconPicture 
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   360
      Left            =   2280
      ScaleHeight     =   24
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   24
      TabIndex        =   0
      Top             =   1320
      Width           =   360
   End
   Begin VB.Label SmallIconLabel 
      Height          =   255
      Left            =   2280
      TabIndex        =   7
      Top             =   960
      Width           =   975
   End
   Begin VB.Label LargeIconLabel 
      Height          =   255
      Left            =   2280
      TabIndex        =   6
      Top             =   0
      Width           =   975
   End
End
Attribute VB_Name = "ShowIconsForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type TypeIcon
    cbSize As Long
    picType As PictureTypeConstants
    hIcon As Long
End Type

Private Type CLSID
    id(16) As Byte
End Type

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 OleCreatePictureIndirect Lib "oleaut32.dll" (pDicDesc As TypeIcon, riid As CLSID, ByVal fown As Long, lpUnk As Object) As Long
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_ICON = &H100
Private Const SHGFI_LARGEICON = &H0
Private Const SHGFI_SMALLICON = &H1

' Convert an icon handle into an IPictureDisp.
Private Function IconToPicture(hIcon As Long) As IPictureDisp
Dim cls_id As CLSID
Dim hRes As Long
Dim new_icon As TypeIcon
Dim lpUnk As IUnknown

    With new_icon
        .cbSize = Len(new_icon)
        .picType = vbPicTypeIcon
        .hIcon = hIcon
    End With
    With cls_id
        .id(8) = &HC0
        .id(15) = &H46
    End With
    hRes = OleCreatePictureIndirect(new_icon, _
        cls_id, 1, lpUnk)
    If hRes = 0 Then Set IconToPicture = lpUnk
End Function

Private Function GetIcon(filename As String, icon_size As Long) As IPictureDisp
Dim index As Integer
Dim hIcon As Long
Dim item_num As Long
Dim icon_pic As IPictureDisp
Dim sh_info As SHFILEINFO

    SHGetFileInfo filename, 0, sh_info, _
        Len(sh_info), SHGFI_ICON + icon_size
    hIcon = sh_info.hIcon
    Set icon_pic = IconToPicture(hIcon)
    Set GetIcon = icon_pic
End Function

Private Sub DirList_Change()
    FileList.Path = DirList.Path
End Sub
Private Sub DriveList_Change()
    On Error GoTo DriveError
    DirList.Path = DriveList.Drive
    Exit Sub

DriveError:
    DriveList.Drive = DirList.Path
    Exit Sub
End Sub

Private Sub FileList_Click()
Dim fname As String

    On Error GoTo LoadPictureError

    fname = FileList.Path + "\" + FileList.filename
    Caption = "ShowIcons [" & fname & "]"
    
    SmallIconPicture.Picture = _
        GetIcon(fname, SHGFI_SMALLICON)
    SmallIconLabel.Caption = _
        Format$(SmallIconPicture.ScaleWidth) & _
        "x" & _
        Format$(SmallIconPicture.ScaleHeight)

    LargeIconPicture.Picture = _
        GetIcon(fname, SHGFI_LARGEICON)
    LargeIconLabel.Caption = _
        Format$(LargeIconPicture.ScaleWidth) & _
        "x" & _
        Format$(LargeIconPicture.ScaleHeight)
    
    Exit Sub

LoadPictureError:
    Beep
    Caption = "ShowIcons [Invalid picture]"
    Exit Sub
End Sub

Private Sub Form_Resize()
Dim wid As Integer
Dim hgt As Integer

    If WindowState = vbMinimized Then Exit Sub

    PatternText.Move _
        0, ScaleHeight - PatternText.Height

    hgt = (PatternText.Top - DriveList.Top - _
        DriveList.Height) / 2
    If hgt < 10 Then hgt = 10
    wid = DriveList.Width
    DirList.Move 0, DriveList.Top + _
        DriveList.Height, wid, hgt
    FileList.Move 0, DirList.Top + _
        DirList.Height, wid, hgt
End Sub


Private Sub PatternText_Change()
    FileList.Pattern = PatternText.Text
End Sub