谁有将EXE文件中的ICO图标转换为PICTURE对象的函数？

Question

可以将 icon、Cursor、bitmap对象或者PictureBox内的图象编辑结果转换为VB的picture对象'功能 Picture对象相关操作
'类别 模块 Option Explicit'*****************************************************************
'* 将 icon 对象转换为 VB 的 picture 对象
'* 参数∶ hIcon 一个有效的图标句柄
'*****************************************************************
Function IconToPicture(ByVal hIcon As Long) As IPicture
　　Dim ipic As IPicture
　　Dim picdes As PICTDESC, iidIPicture As IID　　If hIcon = hNull Then Exit Function
　　picdes.cbSizeofstruct = Len(picdes)
　　picdes.picType = vbPicTypeIcon
　　picdes.hgdiobj = hIcon
　　' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
　　iidIPicture.Data1 = &H7BF80980
　　iidIPicture.Data2 = &HBF32
　　iidIPicture.Data3 = &H101A
　　iidIPicture.Data4(0) = &H8B
　　iidIPicture.Data4(1) = &HBB
　　iidIPicture.Data4(2) = &H0
　　iidIPicture.Data4(3) = &HAA
　　iidIPicture.Data4(4) = &H0
　　iidIPicture.Data4(5) = &H30
　　iidIPicture.Data4(6) = &HC
　　iidIPicture.Data4(7) = &HAB
　 
　　OleCreatePictureIndirect picdes, iidIPicture, True, ipic
　
　　Set IconToPicture = ipic
End Function'******************************************************************
'* 将 Cursor 对象转换为 VB 的 Picture 对象
'* 参数∶ hIcon 一个有效的光标句柄
'******************************************************************
Function CursorToPicture(ByVal hIcon As Long) As IPicture
　　' It's just an alias
　　Set CursorToPicture = IconToPicture(hIcon)
　　End Function'******************************************************************
'* 将 bitmap 对象转换为 VB 的 picture 对象
'* 参数∶ hBmp 一个有效的位图句柄
'* hpal 一个有效的调色板句柄
'******************************************************************
Function BitmapToPicture(ByVal hBmp As Long, _
　　　　　　　　　　　　 Optional ByVal hPal As Long = hNull) As IPicture
　 
　　Dim ipic As IPicture
　　Dim picdes As PICTDESC, iidIPicture As IID
　　picdes.cbSizeofstruct = Len(picdes)
　　picdes.picType = vbPicTypeBitmap
　　picdes.hgdiobj = hBmp
　　picdes.hPalOrXYExt = hPal
　　' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
　　iidIPicture.Data1 = &H7BF80980
　　iidIPicture.Data2 = &HBF32
　　iidIPicture.Data3 = &H101A
　　iidIPicture.Data4(0) = &H8B
　　iidIPicture.Data4(1) = &HBB
　　iidIPicture.Data4(2) = &H0
　　iidIPicture.Data4(3) = &HAA
　　iidIPicture.Data4(4) = &H0
　　iidIPicture.Data4(5) = &H30
　　iidIPicture.Data4(6) = &HC
　　iidIPicture.Data4(7) = &HAB　　OleCreatePictureIndirect picdes, iidIPicture, True, ipic
　
　　Set BitmapToPicture = ipic
End Function'**********************************************************************
'* 刷新 PictureBox 控件的 Picture 对象。对PictureBox中的任何绘图操作，
'*　　　　　　　　　　　　　　　　　 通过它即可转换为Picture对象
'* 使用该函数可将PictureBox内的图象编辑结果永久更新为 Picture 对象
'* 参数∶ PicBox PictureBox控件名
'*　　　　　　　　lWidth 需要更新的图象宽度(按你的需要，不局限于目前Picture对
'*　　　　　　　　　　　　　　 象的实际大小)，也是最后要形成的Picture对象的图象宽度(单位∶像素)
'*　　　　　　　　lHeight 需要更新的图象高度，其他类同与 lWidth(单位∶像素)
'**********************************************************************
Function UpdatePicture(ByRef PicBox As Object, Optional ByVal lWidth As Long = -1, _
　　　　　　　　　　　 Optional ByVal lHeight As Long = -1) As Boolean
　 
　On Error GoTo errHandle　　Dim oldScMode As Integer
　　Dim hNewDC As Long
　　Dim hOldBit As Long
　　Dim hNewBit As Long　　oldScMode = -1
　　oldScMode = PicBox.ScaleMode
　　If lWidth = -1 Then
　　　　lWidth = PicBox.ScaleX(PicBox.Picture.Width, 8, vbPixels)
　　End If
　　If lHeight = -1 Then
　　　　lHeight = PicBox.ScaleY(PicBox.Picture.Height, 8, vbPixels)
　　End If　　hNewDC = CreateCompatibleDC(PicBox.hdc)
　　hNewBit = CreateCompatibleBitmap(PicBox.hdc, lWidth, lHeight)
　　hOldBit = SelectObject(hNewDC, hNewBit) 　　BitBlt hNewDC, 0, 0, lWidth, lHeight, PicBox.hdc, 0, 0, vbSrcCopy
　　SelectObject hNewDC, hOldBit 　　PicBox.Picture = BitmapToPicture(hNewBit)　　DeleteObject hNewDC
　　DeleteDC hNewDC
　　If oldScMode <> -1 Then PicBox.ScaleMode = oldScMode
　　UpdatePicture = True　　Exit Function
errHandle:
　　UpdatePicture = False
　　If oldScMode <> -1 Then PicBox.ScaleMode = oldScMode
End Function 
有关的API函数声明Option ExplicitPublic Const hNull = 0Public Type IID
　　 Data1 As Long
　　 Data2 As Integer
　　 Data3 As Integer
　　 Data4(0 To 7) As Byte
End TypePublic Type PICTDESC
　　cbSizeofstruct As Long
　　picType As Long
　　hgdiobj As Long
　　hPalOrXYExt As Long
End TypePublic Declare Sub OleCreatePictureIndirect Lib "olepro32.dll" ( _
　　lpPictDesc As PICTDESC, _
　　riid As IID, _
　　ByVal fPictureOwnsHandle As Long, _
　　ipic As IPicture)
Public Declare Function CreateCompatibleDC& Lib "gdi32" (ByVal hdc As Long)
Public Declare Function CreateCompatibleBitmap& Lib "gdi32" ( _
　　ByVal hdc As Long, _
　　ByVal nWidth As Long, _
　　ByVal nHeight As Long)
Public Declare Function DeleteDC& Lib "gdi32" (ByVal hdc As Long)
Public Declare Function SelectObject& Lib "gdi32" ( _
　　ByVal hdc As Long, _
　　ByVal hObject As Long)
Public Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)

Answer 1

Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (pDicDesc As TypeIcon, riid As CLSID, ByVal fown As Long, lpUnk As Object) As Long
Public Type TypeIcon
　　cbSize As Long
　　picType As PictureTypeConstants
　　hIcon As Long
End Type
Public Type CLSID
　　id(16) As Byte
End TypePublic 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

Answer 2

太谢谢Seedling(叶子) 和平共处zyl910(910：分儿，我来了！) 了，帮我解决了一个相当急的难题！，现在我都不知道该怎样给你们加分，干脆贴子提分，每人50!

Answer 3

另：zyl910(910：分儿，我来了！) 兄，你的信誉分是怎么涨到110分的？