vb将BMP图转化为ICO代码

建立如下工程

picture控件:picImage picMask

backcolor属性分别为黑色和白色

其他四个picture控件从上到下,从左到右名称依次为默认值

按键从左到右为Command1和Command2

在form1中输入以下代码:

Option Explicit

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, _
ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, _
ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
ByVal hObject As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function CreateIconIndirect Lib "user32" (icoinfo As ICONINFO) As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lppictDesc As _
pictDesc, riid As Guid, ByVal fown As Long, ipic As IPicture) As Long

Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, _
icoinfo As ICONINFO) As Long

Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, _
ByVal crColor As Long) As Long

Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight _
As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long

Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hBMMask As Long
hBMColor As Long
End Type

Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Private Type pictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type

Const PICTYPE_BITMAP = 1
Const PICTYPE_ICON = 3
Dim iGuid As Guid
Dim hdcMono
Dim bmpMono
Dim bmpMonoTemp
Const stdW = 32
Const stdH = 32
Dim mresult
Private Sub Form_Load()
hdcMono = CreateCompatibleDC(hdc)
bmpMono = CreateCompatibleBitmap(hdcMono, stdW, stdH)
bmpMonoTemp = SelectObject(hdcMono, bmpMono)
With iGuid
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
End Sub
Private Sub command1_Click()
On Error Resume Next
Dim mtransp As Long
picImage.BackColor = Picture1.BackColor
mtransp = Picture1.Point(0, 0)
CreateTransparent Picture1, picImage, mtransp
CreateMask_viaMemoryDC picImage, picMask
mresult = BitBlt(Picture2.hdc, 0, 0, stdW, stdH, picMask.hdc, 0, 0, vbSrcAnd)
mresult = BitBlt(Picture2.hdc, 0, 0, stdW, stdH, picImage.hdc, 0, 0, vbSrcInvert)
BuildIcon Picture2
SavePicture Picture2.Picture, App.Path & "/Frombmp.ico"
End Sub

Private Sub command2_Click()
On Error Resume Next
Dim i, j
Dim p, q

Picture4.Picture = Picture3.Image
p = Picture4.Point(0, 0)
q = Me.BackColor
For i = 0 To stdW
For j = 0 To stdH
If Picture4.Point(i, j) = p Then
Picture4.PSet (i, j), q
End If
Next j
Next i

SavePicture Picture4.Picture, App.Path & "/Fromico.bmp"
End Sub
Private Function CreateMask_viaMemoryDC(Pic1 As PictureBox, Pic2 As PictureBox) As Boolean
On Error GoTo errHandler
CreateMask_viaMemoryDC = False
Dim dx As Long, dy As Long
Dim hdcMono2 As Long, bmpMono2 As Long, bmpMonoTemp2 As Long
dx = Pic1.ScaleWidth
dy = Pic1.ScaleHeight
hdcMono2 = CreateCompatibleDC(0)
If hdcMono2 = 0 Then
GoTo errHandler
End If
bmpMono2 = CreateCompatibleBitmap(hdcMono2, dx, dy)
bmpMonoTemp2 = SelectObject(hdcMono2, bmpMono2)
mresult = BitBlt(hdcMono2, 0, 0, dx, dy, Pic1.hdc, 0, 0, vbSrcCopy)
mresult = BitBlt(Pic2.hdc, 0, 0, dx, dy, hdcMono2, 0, 0, vbSrcCopy)
Call SelectObject(hdcMono2, bmpMonoTemp2)
Call DeleteDC(hdcMono2)
Call DeleteObject(bmpMono2)

CreateMask_viaMemoryDC = True
Exit Function
errHandler:
MsgBox "MakeMask_viaMemoryDC"
End Function
Private Sub ExtractIconComposite(inPic As PictureBox)
On Error Resume Next
Dim ipic As IPicture
Dim icoinfo As ICONINFO
Dim pDesc As pictDesc
Dim hDCWork
Dim hBMOldWork
Dim hNewBM
Dim hBMOldMono
GetIconInfo inPic.Picture, icoinfo
hDCWork = CreateCompatibleDC(0)
hNewBM = CreateCompatibleBitmap(inPic.hdc, stdW, stdH)
hBMOldWork = SelectObject(hDCWork, hNewBM)
hBMOldMono = SelectObject(hdcMono, icoinfo.hBMMask)
BitBlt hDCWork, 0, 0, stdW, stdH, hdcMono, 0, 0, vbSrcCopy
SelectObject hdcMono, hBMOldMono
SelectObject hDCWork, hBMOldWork
With pDesc
.cbSizeofStruct = Len(pDesc)
.picType = PICTYPE_BITMAP
.hImage = hNewBM
End With
OleCreatePictureIndirect pDesc, iGuid, 1, ipic
picMask = ipic
Set ipic = Nothing
pDesc.hImage = icoinfo.hBMColor
OleCreatePictureIndirect pDesc, iGuid, 1, ipic
picImage = ipic
DeleteObject icoinfo.hBMMask
DeleteDC hDCWork
Set hBMOldWork = Nothing
Set hBMOldMono = Nothing
End Sub
Private Sub BuildIcon(inPic As PictureBox)
On Error Resume Next
Dim hOldMonoBM
Dim hDCWork
Dim hBMOldWork
Dim hBMWork
Dim ipic As IPicture
Dim pDesc As pictDesc
Dim icoinfo As ICONINFO
BitBlt hdcMono, 0, 0, stdW, stdH, picMask.hdc, 0, 0, vbSrcCopy
SelectObject hdcMono, bmpMonoTemp
hDCWork = CreateCompatibleDC(0)
With inPic
hBMWork = CreateCompatibleBitmap(inPic.hdc, stdW, stdH)
End With
hBMOldWork = SelectObject(hDCWork, hBMWork)
BitBlt hDCWork, 0, 0, stdW, stdH, picImage.hdc, 0, 0, vbSrcCopy
SelectObject hDCWork, hBMOldWork
With icoinfo
.fIcon = 1
.xHotspot = 16
.yHotspot = 16
.hBMMask = bmpMono
.hBMColor = hBMWork
End With
With pDesc
.cbSizeofStruct = Len(pDesc)
.picType = PICTYPE_ICON
.hImage = CreateIconIndirect(icoinfo)
End With
OleCreatePictureIndirect pDesc, iGuid, 1, ipic
inPic.Picture = LoadPicture()
inPic = ipic
bmpMonoTemp = SelectObject(hdcMono, bmpMono)
DeleteObject icoinfo.hBMMask
DeleteDC hDCWork
Set hBMOldWork = Nothing
End Sub
Sub CreateTransparent(inpicSrc As PictureBox, inpicDest As PictureBox, _
inTrasparentColor As Long)
On Error Resume Next
Dim mMaskDC As Long
Dim mMaskBmp As Long
Dim mTempMaskBMP As Long
Dim mMonoBMP As Long
Dim mMonoDC As Long
Dim mTempMonoBMP As Long
Dim mSrcHDC As Long, mDestHDC As Long
Dim w As Long, h As Long
w = inpicSrc.ScaleWidth
h = inpicSrc.ScaleHeight
mSrcHDC = inpicSrc.hdc
mDestHDC = inpicDest.hdc
mresult = SetBkColor&(mSrcHDC, inTrasparentColor)
mresult = SetBkColor&(mDestHDC, inTrasparentColor)
mMaskDC = CreateCompatibleDC(mDestHDC)
mMaskBmp = CreateCompatibleBitmap(mDestHDC, w, h)
mTempMaskBMP = SelectObject(mMaskDC, mMaskBmp)
mMonoDC = CreateCompatibleDC(mDestHDC)
mMonoBMP = CreateBitmap(w, h, 1, 1, 0)
mTempMonoBMP = SelectObject(mMonoDC, mMonoBMP)
mresult = BitBlt(mMonoDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcCopy)
mresult = BitBlt(mMaskDC, 0, 0, w, h, mMonoDC, 0, 0, vbSrcCopy)
mMonoBMP = SelectObject(mMonoDC, mTempMonoBMP)
mresult = DeleteObject(mMonoBMP)
mresult = DeleteDC(mMonoDC)
mresult = BitBlt(mDestHDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcInvert)
mresult = BitBlt(mDestHDC, 0, 0, w, h, mMaskDC, 0, 0, vbSrcAnd)
BitBlt mDestHDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcInvert
inpicDest.Picture = inpicDest.Image
mMaskBmp = SelectObject(mMaskDC, mTempMaskBMP)
mresult = DeleteObject(mMaskBmp)
mresult = DeleteDC(mMaskDC)
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
SelectObject bmpMono, bmpMonoTemp
DeleteObject bmpMono
DeleteDC hdcMono
End Sub
ok啦!