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(mDe

上一个：VB.NET操作ini文件的方法
下一个：在VB中的Timer控件怎么用？