frmenumres.frm

使用32位色资源图标文件(带 Alpha 通道)的控件

      TabIndex        =   1
      Top             =   1140
      Width           =   2250
   End
   Begin VB.Image Image1 
      Height          =   345
      Left            =   7410
      Top             =   3120
      Visible         =   0   'False
      Width           =   345
   End
   Begin VB.Menu mnuBar 
      Caption         =   "文件(&F)"
      Index           =   0
      Begin VB.Menu mnuFile 
         Caption         =   "阅读说明(&O)"
         Index           =   0
         Shortcut        =   ^O
      End
      Begin VB.Menu mnuFile 
         Caption         =   "-"
         Index           =   2
      End
      Begin VB.Menu mnuFile 
         Caption         =   "退出(&X)"
         Index           =   3
      End
   End
   Begin VB.Menu mnuBar 
      Caption         =   "帮助(&H)"
      Index           =   1
      Begin VB.Menu mnuHelp 
         Caption         =   "关于(&A)..."
      End
   End
End
Attribute VB_Name = "frmEnumRes"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：05/05/18
'描  述：在VB中使用32位色资源图标文件(使用 Alpha 通道)
'网  站：http://www.mndsoft.com/
'e-mail：[e-mail]
'OICQ  : 88382850
'****************************************************************************
'---------------------------------------------------------------------------------------
' 模块      : frmEnumRes.frm
' 日期      : 03/04/2004 16.09
' 作者      : Giorgio Brausi ([e-mail])
' 工程      : EnumResource.vbp
' 标题      : 使用EXE/DLL中的图表库
' 描述      : 本程序示例了怎样在WinXP下使用32位色深的图标，以及使用可执行文件及DLL文件资源中的图标
' 注释      : 当我们看到很多漂亮的图标，想在VB中的图形控件中使用时，VB确返回一个错误"无效的图像",
'             这才知道这些漂亮的图标是带有Alpha 通道透明的图标，看到这么漂亮的图标,不用岂不可惜，那
'             么，好，就让我们来学习怎样使用吧。
'             这个代码支持如下格式及色深的图标：
'               16x16 4bpp      16x16 16bpp     16x16 32bpp
'               32x32 4bpp      32x32 16bpp     32x32 32bpp
'               48x48 4bpp      48x48 16bpp     48x48 32bpp
'             在我们使用一个包含9个格式的图标文件时，我们无法获得错误，因为VB选择了自身定义的32x32
'             16位色的格式，如果想使用真彩色，需要依赖系统。
'             所有，我们只有使用更多的API函数来解决这个问题。
'             注意：这个程序在WindowsXP下可以很好的显示，但Win2K下不太理想
'
'---------------------------------------------------------------------------------------
Option Explicit

Dim sLibraryFile As String  '/ 图标库文件的路径和文件名

Private Sub chkAllSizeFormat_Click()
    gbAllSizeFormat = chkAllSizeFormat.Value
    
    Dim i As Integer
    
    If gbAllSizeFormat Then
        For i = 0 To 3
            optSize(i).Value = False
            optType(i).Value = False
        Next i
    End If
    
End Sub

Private Sub cmdClose_Click()
    Unload Me
End Sub

Private Sub cmdLoadIcons_Click()

    If sLibraryFile = "" Then
        MsgBox "请从列表中选择一个图标库文件!", vbInformation, "提示"
        Exit Sub
    End If
    
    If Not gbAllSizeFormat And Not IsOptionChecked() Then
        MsgBox "请首先选择选择一种尺寸和色深的图标, 或者全部尺寸和格式的图标!", vbExclamation, "提示"
        Exit Sub
    End If
    
    Msg "图标加载中. 请稍候..."
    GetIconsFromLibrary sLibraryFile
    Msg "图标加载完毕."
    Me.SetFocus
End Sub

Private Sub Form_Load()
    
    ' 缺省, 使用全部尺寸和格式的图标
    chkAllSizeFormat.Value = 1
    
    ' 添加图标库文件路径...
    List1.AddItem "XP_icons_16.dll"
    List1.AddItem "XP_icons_24.dll"
    List1.AddItem "XP_icons_48.dll"
    List1.AddItem "XP_icons_all.dll"
    
    ' 添加你系统中带的包含有图标的DLL和EXE
    List1.AddItem "C:\Windows\Explorer.exe"
    List1.AddItem "C:\Windows\System32\shell32.dll"
    List1.AddItem "C:\Windows\System32\moricons.dll"
    
    Msg "请从列表中选择一个图标库文件, 然后单击载入图标按钮."
End Sub

'处理列表框中图标库文件
Private Sub List1_Click()
Dim sPath As String

    If List1.ListIndex < 4 Then
        sPath = App.Path & "\DLL\" & List1.Text
    Else
        sPath = List1.Text
    End If
    
    ' 判断是否存在
    If Dir(sPath) = "" Then
        MsgBox "加载的文件不存在!", vbCritical, "提示"
        On Error Resume Next
        List1.Selected(List1.Text) = False
        Exit Sub
    End If

    ' 返回文件路径和名称
    sLibraryFile = sPath
    Msg sPath
    
    cmdLoadIcons.Enabled = True
    
End Sub

Private Sub mnuFile_Click(Index As Integer)
Const FILE_OPEN = 0
Const FILE_SHOW = 1
Const FILE_EXIT = 3
    Select Case Index
        Case FILE_OPEN   '打开说明文件
            Shell "Notepad.exe " & App.Path & "\README.TXT", vbNormalFocus
        Case FILE_SHOW   '示例说明
            'frmSample.Show , Me
        Case FILE_EXIT
            Unload Me
    End Select
End Sub

'帮助菜单
Private Sub mnuHelp_Click()
    Dim s As String
        s = "在VB中使用32位色资源图标文件(使用 Alpha 通道)" & vbCrLf
        s = s & "作者:Giorgio Brausi (aka GIBRA)" & vbCrLf & vbCrLf
        s = s & "枕善居汉化整理" & vbCrLf
        s = s & "http://www.Mndsoft.com" & vbCrLf & vbCrLf
        s = s & "假如发现错误或您做出更好的功能，请到枕善居留言!"
        s = s & "谢谢!"
        MsgBox s, vbInformation
        
End Sub

'图标尺寸选择
Private Sub optSize_Click(Index As Integer)
    
    Select Case Index
        Case 0
            giSize = 16
        Case 1
            giSize = 24
        Case 2
            giSize = 32
        Case 3
            giSize = 48
    End Select
    
    chkAllSizeFormat.Value = 0
    
End Sub

'图标类型选择
Private Sub optType_Click(Index As Integer)
    Select Case Index
        Case 0
            giColorDepth = 4
        Case 1
            giColorDepth = 16
        Case 2
            giColorDepth = 24
        Case 3
            giColorDepth = 32
    End Select
    
    chkAllSizeFormat.Value = 0
    
End Sub

'---------------------------------------------------------------------------------------
' 过程   : GetIconsFromLibrary
' 日期   : 04/04/2004 17.40
' 作者   : Giorgio Brausi
' 用途   : 从选择的图标库文件中提取图标, 并加载图形下拉列表框(ImageCombo1)中
'---------------------------------------------------------------------------------------

Public Sub GetIconsFromLibrary(ByVal sLibraryFilePath As String)
    Dim i As Integer
    Dim tRes As ResType, iCount As Integer
        
    ghmodule = LoadLibraryEx(sLibraryFilePath, 0, DONT_RESOLVE_DLL_REFERENCES)

    If ghmodule = 0 Then
        MsgBox "无效的图标库文件.", vbCritical, "错误"
        Exit Sub
    End If
    
    ' 清空
    ImageCombo1.ImageList = Nothing
    ImageCombo1.ComboItems.Clear
    Toolbar1.ImageList = Nothing
    ImageList1.ListImages.Clear
    List2.Clear
    StatusBar1.Panels(2).Text = ""
    
    ' 提取图标可能会需要一些时间
    Screen.MousePointer = vbHourglass
    For tRes = RT_FIRST To RT_LAST
        DoEvents
        EnumResourceNames ghmodule, tRes, AddressOf EnumResNameProc, 0
    Next
    FreeLibrary ghmodule
    
    Screen.MousePointer = vbNormal
    
    If ImageList1.ListImages.Count = 0 Then
        StatusBar1.Panels(2).Text = "没有图标"
        Exit Sub
    End If
    
    ' 加载图形下拉列表框(ImageCombo1)中
    ImageCombo1.ImageList = ImageList1
    For i = 1 To ImageList1.ListImages.Count
        ImageCombo1.ComboItems.Add , , "icon " & ImageList1.ListImages(i).Key, ImageList1.ListImages(i).Index
    Next i
      
    ' ... 加载到 Toolbar1
    Toolbar1.ImageList = ImageList1
    ' 获取图标最大编号
    iCount = IIf(Toolbar1.Buttons.Count > ImageList1.ListImages.Count, ImageList1.ListImages.Count, Toolbar1.Buttons.Count)

    For i = 1 To iCount
        Toolbar1.Buttons(i).Image = ImageList1.ListImages(i).Index
    Next i
    
    ' 显示图标库图标个数
    StatusBar1.Panels(2).Text = ImageList1.ListImages.Count & " 个图标."
    
  
End Sub

'---------------------------------------------------------------------------------------
' 过程   : Msg
' 日期   : 04/04/2004 17.44
' 作者   : Giorgio Brausi
' 用途   : 在状态栏中显示信息
'---------------------------------------------------------------------------------------
Public Sub Msg(ByVal s As String)
    StatusBar1.Panels(1).Text = s
End Sub

'---------------------------------------------------------------------------------------
' 过程   : IsOptionChecked
' 日期   : 04/04/2004 11.09
' 作者   : Giorgio Brausi
' 用途   : 检查尺寸和色深是否选择
' 描述   : 如果开始提取图标的详细尺寸和色深，需要这个值
' 注释   :
'---------------------------------------------------------------------------------------

Public Function IsOptionChecked() As Boolean
Dim i As Integer, bSize As Boolean, bType As Boolean

    For i = 0 To 3
        If optSize(i) Then
            bSize = True
            Exit For
        End If
    Next i
    
    For i = 0 To 3
        If optType(i) Then
            bType = True
            Exit For
        End If
    Next i
    IsOptionChecked = bSize And bType
    
End Function