modenumres.bas

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

Attribute VB_Name = "modEnumResIcons"
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：05/05/18
'描  述：从EXE/DLL库文件中加载图标资源
'网  站：http://www.mndsoft.com/
'e-mail：[e-mail]
'OICQ  : 88382850
'****************************************************************************
'---------------------------------------------------------------------------------------
' 模块      : modEnumResIcons.bas
' 日期      : 03/04/2004 21.52
' 作者      : Giorgio Brausi
' 工程      : EnumResource.vbp
' 用途      : 从EXE/DLL库文件中加载图标资源
' 描述      : 本工程演示怎样从可执行文件中加载Windows XP (32bpp) 图标
' 注释      : 参阅'frmEnumRes.frm'中的细节注释.
'             或者阅读 README.TXT
'---------------------------------------------------------------------------------------
Option Explicit

Public ghmodule As Long
Public giSize As Integer
Public giColorDepth As Integer
Public gbAllSizeFormat As Boolean

Public arrSize As Long

Private arIcon(1 To 4, 1 To 4)
Private Const SIZE_16 = 1
Private Const SIZE_24 = 2
Private Const SIZE_32 = 3
Private Const SIZE_48 = 4
Private Const COLOR_4 = 1
Private Const COLOR_16 = 2
Private Const COLOR_24 = 3
Private Const COLOR_32 = 4

Public Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
Public Const DONT_RESOLVE_DLL_REFERENCES = &H1
Public Const LOAD_LIBRARY_AS_DATAFILE = &H2
Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Public Declare Function EnumResourceNames Lib "kernel32" Alias "EnumResourceNamesA" (ByVal ghmodule As Long, ByVal lpType As ResType, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
'字符串处理
Public Declare Function StrLen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Public Declare Function StrCpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Const DIFFERENCE = 11
Public Enum ResType ' 资源类型
    RT_FIRST = 1&
    RT_CURSOR = 1&
    RT_BITMAP = 2&
    RT_ICON = 3&
    RT_MENU = 4&
    RT_DIALOG = 5&
    RT_STRING = 6&
    RT_FONTDIR = 7&
    RT_FONT = 8&
    RT_ACCELERATOR = 9&
    RT_RCDATA = 10&
    RT_MESSAGETABLE = (11)
    RT_GROUP_CURSOR = (RT_CURSOR + DIFFERENCE)  ' (12)
    RT_GROUP_ICON = (RT_ICON + DIFFERENCE)      ' (14)
    RT_VERSION = (16)
    'RT_DLGINCLUDE = (17)
    'RT_PLUGPLAY = (19)
    'RT_VXD = (20)
    'RT_ANICURSOR = (21)
    'RT_ANIICON = (22)
    'RT_HTML = (23)
    RT_LAST = (16)
End Enum

' 图像处理
'Const IMAGE_BITMAP = 0
'Const IMAGE_ICON = 1
'Const IMAGE_CURSOR = 2
'Const IMAGE_ENHMETAFILE = 3
'Private Const LR_COLOR As Long = &H2
'Private Const LR_COPYDELETEORG As Long = &H8
'Private Const LR_COPYFROMRESOURCE As Long = &H4000
'Private Const LR_COPYRETURNORG As Long = &H4
'Private Const LR_CREATEDIBSECTION As Long = &H2000
'Private Const LR_DEFAULTCOLOR As Long = &H0
'Private Const LR_DEFAULTSIZE As Long = &H40
'Private Const LR_LOADFROMFILE As Long = &H10
Private Const LR_LOADMAP3DCOLORS As Long = &H1000
'Private Const LR_LOADTRANSPARENT As Long = &H20
'Private Const LR_MONOCHROME As Long = &H1
'Private Const LR_SHARED As Long = &H8000
'Private Const LR_VGACOLOR As Long = &H80

'/ mie
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
'Private Declare Function DrawIconEx Lib "user32.dll" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
'Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
'Private Declare Function GetLastError Lib "kernel32.dll" () As Long
'Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Public Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long

Private Declare Function FindResource Lib "kernel32.dll" Alias "FindResourceA" (ByVal hInstance As Long, ByVal lpName As String, ByVal lpType As String) As Long
Private Declare Function FindResourceByNum Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, ByVal lpName As String, ByVal lpType As Long) As Long

Private Declare Function LoadResource Lib "kernel32.dll" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function CreateIconFromResourceEx Lib "user32" (presbits As Byte, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal uFlags As Long) As Long
Private Declare Function LockResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Function SizeofResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function FreeResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Type PictDesc
    cbSizeofStruct As Long
    PicType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As GUID, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long

'Private Declare Function GetBitmapDimensionEx Lib "gdi32.dll" (ByVal hBitmap As Long, lpDimension As SIZE) As Long
Private Type SIZE
    cx As Long
    cy As Long
End Type




'---------------------------------------------------------------------------------------
' 函数   : GetPictureRes
' 日期   : 04/04/2004 17.47
' 作者   : Giorgio Brausi
' 用途   : 从库文件中获取图标资源
' 描述   : 获取资源类型并判断是否需要（ICON)
' 注释   :
'---------------------------------------------------------------------------------------

Public Function GetPictureRes(ByVal sResType As String, ByVal sResName As String, ByVal iSize As Integer, ByVal iColorDepth As Integer) As StdPicture
    Dim hData As Long
    Dim arr() As Byte, vRet As Variant
    Select Case sResType
        Case "1", "3" ' 依赖硬件的光标或图标.
            vRet = GetDataArray(sResType, sResName, iSize, iColorDepth)
            If CStr(vRet) = "0" Then
                Set GetPictureRes = Nothing
                Exit Function
            Else
                arr = vRet
                hData = CreateIconFromResourceEx(arr(0), UBound(arr) + 1, CLng(sResType) - 1, &H30000, 0, 0, LR_LOADMAP3DCOLORS)
            End If
            
        Case "2"  ' 位图文件
            hData = LoadImage(ghmodule, sResName, 0, 0, 0, LR_LOADMAP3DCOLORS)
        Case "12" ' 依赖硬件的光标
            hData = LoadImage(ghmodule, sResName, 2, 0, 0, LR_LOADMAP3DCOLORS)
        Case "14" ' 依赖硬件的图标
            hData = LoadImage(ghmodule, sResName, 1, 0, 0, LR_LOADMAP3DCOLORS)
    End Select
    If hData = 0 Then Exit Function
    
    Set GetPictureRes = IconToPicture(hData)
    
End Function

'---------------------------------------------------------------------------------------
' 函数   : IconToPicture
' 日期   : 04/04/2004 17.46
' 作者   : Giorgio Brausi
' 用途   : 把资源文件中的 ICON 输出位 PICTURE
' 描述   :
' 注释   :
'---------------------------------------------------------------------------------------

Private Function IconToPicture(ByVal hIcon As Long) As StdPicture
    
    If hIcon = 0 Then Exit Function
    Dim oNewPic As Picture
    Dim tPicConv As PictDesc
    Dim IGuid As GUID
    With tPicConv
        .cbSizeofStruct = Len(tPicConv)
        .PicType = vbPicTypeIcon
        .hImage = hIcon
    End With
    With IGuid
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    OleCreatePictureIndirect tPicConv, IGuid, True, oNewPic
    Set IconToPicture = oNewPic
End Function

Public Function GetDataArray(ByVal ResType As String, ByVal ResName As String, ByVal iSize As Integer, ByVal iColorDepth As Integer) As Variant
    Dim hRsrc As Long
    Dim hGlobal As Long
    Dim arrData() As Byte
    Dim lpData As Long
    'Dim arrSize As Long
    If IsNumeric(ResType) Then hRsrc = FindResourceByNum(ghmodule, ResName, CLng(ResType))
    If hRsrc = 0 Then hRsrc = FindResource(ghmodule, ResName, ResType)
    If hRsrc = 0 Then Exit Function
    hGlobal = LoadResource(ghmodule, hRsrc)
    lpData = LockResource(hGlobal)
    
    arrSize = SizeofResource(ghmodule, hRsrc)
    Dim iNDXSize As Integer, iNDXColor As Integer
    Select Case iSize
        Case 16
            iNDXSize = 1
        Case 24
            iNDXSize = 2
        Case 32
            iNDXSize = 3
        Case 48
            iNDXSize = 4
    End Select
    Select Case iColorDepth
        Case 4
            iNDXColor = 1
        Case 16
            iNDXColor = 2
        Case 24
            iNDXColor = 3
        Case 32
            iNDXColor = 4
    End Select
    
    
    If Not gbAllSizeFormat Then
        ' 图标是否匹配色深
        If arrSize <> arIcon(iNDXSize, iNDXColor) Then
            GetDataArray = 0
            Exit Function
        End If
    End If
    
    If arrSize = 0 Then
        GetDataArray = 0
        Exit Function
    End If
    
    ReDim arrData(arrSize - 1)
    Call CopyMemory(arrData(0), ByVal lpData, arrSize)
    Call FreeResource(hGlobal)
    GetDataArray = arrData

End Function

Public Function EnumResNameProc(ByVal ghmodule As Long, ByVal lpszType As ResType, ByVal lpszName As Long, ByVal lParam As Long) As Long
    Dim sNumber As String, IsNum As Boolean
    
    If (lpszName > &HFFFF&) Or (lpszName < 0) Then
        sNumber = PtrToVBString(lpszName)
        IsNum = False
    Else
        sNumber = CStr(lpszName)
        IsNum = True
    End If
    
    ' 16x16
    arIcon(SIZE_16, COLOR_4) = 296
    arIcon(SIZE_16, COLOR_16) = 1384
    arIcon(SIZE_16, COLOR_24) = 872
    arIcon(SIZE_16, COLOR_32) = 1128
    ' 24x24
    arIcon(SIZE_24, COLOR_4) = 488
    arIcon(SIZE_24, COLOR_16) = 1736
    arIcon(SIZE_24, COLOR_24) = 1864
    arIcon(SIZE_24, COLOR_32) = 2440
    ' 32x32
    arIcon(SIZE_32, COLOR_4) = 744
    arIcon(SIZE_32, COLOR_16) = 2216
    arIcon(SIZE_32, COLOR_24) = 3240
    arIcon(SIZE_32, COLOR_32) = 4264
    ' 48x48
    arIcon(SIZE_48, COLOR_4) = 1640
    arIcon(SIZE_48, COLOR_16) = 3752
    arIcon(SIZE_48, COLOR_24) = 7336
    arIcon(SIZE_48, COLOR_32) = 9640
    
    
        
    If IsNum Then
        If lpszType = RT_ICON Then
            LoadIconRes lpszType, sNumber, giSize, giColorDepth
        End If
    End If
    EnumResNameProc = 1
End Function

Private Function PtrToVBString(ByVal lpszBuffer As Long) As String
    Dim Buffer As String, LenBuffer As Long
    LenBuffer = StrLen(lpszBuffer)
    Buffer = String(LenBuffer + 1, 0)
    StrCpy Buffer, lpszBuffer
    PtrToVBString = Left(Buffer, LenBuffer)
End Function

'---------------------------------------------------------------------------------------
' 过程   : LoadIconRes
' 日期   : 04/04/2004 17.50
' 作者   : Giorgio Brausi
' 用途   : 从图标资源中获取每个图像的格式
' 描述   :
' 注释   : 使用 GetPictureRes函数
'---------------------------------------------------------------------------------------

Public Sub LoadIconRes(ByVal sResType As ResType, ByVal sResNumber As String, ByVal iSize As Integer, ByVal iColorDepth As Integer)
    Dim sResName As String
    
    Dim hPicture As StdPicture
    
    sResName = sResNumber
    If IsNumeric(sResName) Then sResName = "#" & sResName
    
    ' 载入图标匹配大小
    Set hPicture = GetPictureRes(sResType, sResName, iSize, iColorDepth)
    
    Dim h As Long, w As Long
    Set frmEnumRes.Image1.Picture = hPicture
    w = frmEnumRes.Image1.Width / Screen.TwipsPerPixelX
    h = frmEnumRes.Image1.Height / Screen.TwipsPerPixelY
    
    If Not hPicture Is Nothing Then
        With frmEnumRes.ImageList1
            .ListImages.Add , sResName & " " & CStr(arrSize) & " " & w & "x" & h, hPicture
            
            ' 需要知道更多的图像格式
            Select Case arrSize
                Case 1640, 744, 488, 296, 3752, 2216, 1736, 1384, 9640, 4264, 2440, 1128, 7336, 3240, 1864, 872
                    ' 这是已知的图像格式
                Case Else
                    ' 常用的图像格式: 单色, 21x24, ...
                    ' 当想列出所有格式时会出现'无法获取'，请大家一起看看
                    frmEnumRes.List2.AddItem Format(sResName, "@@@@@") & " " & _
                                             Format(arrSize, "@@@@@") & " " & _
                                             w & "x" & h
            End Select
        End With
    End If
    
End Sub