【VB技巧】VB不失真提取ico图标并保存

Option Explicit

Private Type PicBmp
    Size  As Long
    tType As Long
    hBmp  As Long
    hPal  As Long
    Reserved As Long
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hicon As Long) As Long

Public Function GetIconFromFile(FileName As String, IconIndex As Long, UseLargeIcon As Boolean) As Picture
    '参数:
    'FileName - 包含有图标的文件 (EXE or DLL)
    'IconIndex - 欲提取的圉标的索引，从零开始
    'UseLargeIcon-如设置为True，则提取大图标，否则提取小图标
    '返回值: 包含标标的Picture对象
    Dim hlargeicon As Long
    Dim hsmallicon As Long
    Dim selhandle As Long
    ' IPicture requires a reference to "Standard OLE Types."
    Dim pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
    If ExtractIconEx(FileName, IconIndex, hlargeicon, hsmallicon, 1) > 0 Then
        If UseLargeIcon Then
            selhandle = hlargeicon
        Else
            selhandle = hsmallicon
        End If
        ' Fill in with IDispatch Interface ID.
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        ' Fill Pic with necessary parts.
        With pic
            .Size = Len(pic)                                                    ' Length of structure.
            .tType = vbPicTypeIcon                                              ' Type of Picture (bitmap).
            .hBmp = selhandle                                                   ' Handle to bitmap.
        End With
        ' Create Picture object.
        Call OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic)
        ' Return the new Picture object.
        Set GetIconFromFile = IPic
        DestroyIcon hsmallicon
        DestroyIcon hlargeicon
    End If
End Function

SavePicture GetIconFromFile("c:windowssystem32moricons.dll", 1, True), "c:a.ico"

文章来源于lcx.cc:【VB技巧】VB不失真提取ico图标并保存

相关推荐: 【文章】9.3 密码分组链接模式 - 反馈寄存器

9.3 密码分组链接模式     链接将一种反馈机制加进分组密码中：前一个分组的加密结果被反馈到当前分组的加密中，换句话说，每一分组被用来修改下一分组的加密。每个密文分组不仅依赖于产生它的明文分组，而且依赖于所有前面的明文分组。     在密码分组链接（CBC…