VB如何编写BMP转换ICO的程序

发布网友发布时间：2022-07-10 14:07

共1个回答

热心网友时间：2022-07-12 22:23

按如下操作可以实现BMP、ICO互转。首先，建立如下工程picture控件:picImage picMaskbackcolor属性分别为黑色和白色其他四个picture控件从上到下,从左到右名称依次为默认值按键从左到右为Command1和Command2在form1中输入以下代码:Option ExplicitPrivate 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 LongPrivate 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 LongPrivate Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Declare Function CreateIconIndirect Lib "user32" (icoinfo As ICONINFO) As LongPrivate 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 TypePrivate Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End TypePrivate Type pictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End TypeConst 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