AnyToBMP的教程

vb的ListImages控件把bmp转成ico的代码

按如下操作可以实现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 LongPrivate Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, _ByVal nWidth As Long, ByVal nHeight As Long) As LongPrivate 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 LongPrivate 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 LongPrivate Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, _icoinfo As ICONINFO) As LongPrivate Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, _ByVal crColor As Long) As LongPrivate 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 LongPrivate Type ICONINFOfIcon As LongxHotspot As LongyHotspot As LonghBMMask As LonghBMColor As LongEnd TypePrivate Type GuidData1 As LongData2 As IntegerData3 As IntegerData4(7) As ByteEnd TypePrivate Type pictDesccbSizeofStruct As LongpicType As LonghImage As LongxExt As LongyExt As LongEnd TypeConst PICTYPE_BITMAP = 1Const PICTYPE_ICON = 3Dim iGuid As GuidDim hdcMonoDim bmpMonoDim bmpMonoTempConst stdW = 32Const stdH = 32Dim mresultPrivate Sub Form_Load()hdcMono = CreateCompatibleDC(hdc)bmpMono = CreateCompatibleBitmap(hdcMono, stdW, stdH)bmpMonoTemp = SelectObject(hdcMono, bmpMono)With iGuid.Data1 = &H20400.Data4(0) = &HC0.Data4(7) = &H46End WithEnd SubPrivate Sub command1_Click()On Error Resume NextDim mtransp As LongpicImage.BackColor = Picture1.BackColormtransp = Picture1.Point(0, 0)CreateTransparent Picture1, picImage, mtranspCreateMask_viaMemoryDC picImage, picMaskmresult = 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 Picture2SavePicture Picture2.Picture, App.Path & "/Frombmp.ico"End SubPrivate Sub command2_Click()On Error Resume NextDim i, jDim p, qPicture4.Picture = Picture3.Imagep = Picture4.Point(0, 0)q = Me.BackColorFor i = 0 To stdWFor j = 0 To stdHIf Picture4.Point(i, j) = p ThenPicture4.PSet (i, j), qEnd IfNext jNext iSavePicture Picture4.Picture, App.Path & "/Fromico.bmp"End SubPrivate Function CreateMask_viaMemoryDC(Pic1 As PictureBox, Pic2 As PictureBox) As BooleanOn Error GoTo errHandlerCreateMask_viaMemoryDC = FalseDim dx As Long, dy As LongDim hdcMono2 As Long, bmpMono2 As Long, bmpMonoTemp2 As Longdx = Pic1.ScaleWidthdy = Pic1.ScaleHeighthdcMono2 = CreateCompatibleDC(0)If hdcMono2 = 0 ThenGoTo errHandlerEnd IfbmpMono2 = 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 = TrueExit FunctionerrHandler:MsgBox "MakeMask_viaMemoryDC"End FunctionPrivate Sub ExtractIconComposite(inPic As PictureBox)On Error Resume NextDim ipic As IPictureDim icoinfo As ICONINFODim pDesc As pictDescDim hDCWorkDim hBMOldWorkDim hNewBMDim hBMOldMonoGetIconInfo inPic.Picture, icoinfohDCWork = 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, vbSrcCopySelectObject hdcMono, hBMOldMonoSelectObject hDCWork, hBMOldWorkWith pDesc.cbSizeofStruct = Len(pDesc).picType = PICTYPE_BITMAP.hImage = hNewBMEnd WithOleCreatePictureIndirect pDesc, iGuid, 1, ipicpicMask = ipicSet ipic = NothingpDesc.hImage = icoinfo.hBMColorOleCreatePictureIndirect pDesc, iGuid, 1, ipicpicImage = ipicDeleteObject icoinfo.hBMMaskDeleteDC hDCWorkSet hBMOldWork = NothingSet hBMOldMono = NothingEnd SubPrivate Sub BuildIcon(inPic As PictureBox)On Error Resume NextDim hOldMonoBMDim hDCWorkDim hBMOldWorkDim hBMWorkDim ipic As IPictureDim pDesc As pictDescDim icoinfo As ICONINFOBitBlt hdcMono, 0, 0, stdW, stdH, picMask.hdc, 0, 0, vbSrcCopySelectObject hdcMono, bmpMonoTemphDCWork = CreateCompatibleDC(0)With inPichBMWork = CreateCompatibleBitmap(inPic.hdc, stdW, stdH)End WithhBMOldWork = SelectObject(hDCWork, hBMWork)BitBlt hDCWork, 0, 0, stdW, stdH, picImage.hdc, 0, 0, vbSrcCopySelectObject hDCWork, hBMOldWorkWith icoinfo.fIcon = 1.xHotspot = 16.yHotspot = 16.hBMMask = bmpMono.hBMColor = hBMWorkEnd WithWith pDesc.cbSizeofStruct = Len(pDesc).picType = PICTYPE_ICON.hImage = CreateIconIndirect(icoinfo)End WithOleCreatePictureIndirect pDesc, iGuid, 1, ipicinPic.Picture = LoadPicture()inPic = ipicbmpMonoTemp = SelectObject(hdcMono, bmpMono)DeleteObject icoinfo.hBMMaskDeleteDC hDCWorkSet hBMOldWork = NothingEnd SubSub CreateTransparent(inpicSrc As PictureBox, inpicDest As PictureBox, _inTrasparentColor As Long)On Error Resume NextDim mMaskDC As LongDim mMaskBmp As LongDim mTempMaskBMP As LongDim mMonoBMP As LongDim mMonoDC As LongDim mTempMonoBMP As LongDim mSrcHDC As Long, mDestHDC As LongDim w As Long, h As Longw = inpicSrc.ScaleWidthh = inpicSrc.ScaleHeightmSrcHDC = inpicSrc.hdcmDestHDC = inpicDest.hdcmresult = 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, vbSrcInvertinpicDest.Picture = inpicDest.ImagemMaskBmp = SelectObject(mMaskDC, mTempMaskBMP)mresult = DeleteObject(mMaskBmp)mresult = DeleteDC(mMaskDC)End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)SelectObject bmpMono, bmpMonoTempDeleteObject bmpMonoDeleteDC hdcMonoEnd Sub