bmp2icon.frm

一款漂亮的控件。 快

VERSION 5.00
Begin VB.Form frmBmp2Icon 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "BMP to ICO, ICO to BMP"
   ClientHeight    =   4410
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4395
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   294
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   293
   StartUpPosition =   3  '窗口缺省
   Begin VB.PictureBox picImage 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H00000000&
      ForeColor       =   &H80000008&
      Height          =   540
      Left            =   3030
      ScaleHeight     =   34
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   34
      TabIndex        =   11
      Top             =   30
      Visible         =   0   'False
      Width           =   540
   End
   Begin VB.PictureBox picMask 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   540
      Left            =   3630
      ScaleHeight     =   34
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   34
      TabIndex        =   10
      Top             =   30
      Visible         =   0   'False
      Width           =   540
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Ico to Bmp"
      Height          =   345
      Left            =   2640
      TabIndex        =   9
      Top             =   3630
      Width           =   1185
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Bmp to Ico"
      Height          =   345
      Left            =   330
      TabIndex        =   8
      Top             =   3630
      Width           =   1185
   End
   Begin VB.PictureBox Picture4 
      BackColor       =   &H80000005&
      Height          =   540
      Left            =   2850
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   3
      Top             =   2610
      Width           =   540
   End
   Begin VB.PictureBox Picture3 
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      Height          =   540
      Left            =   2850
      Picture         =   "Bmp2Icon.frx":0000
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   2
      Top             =   1080
      Width           =   540
   End
   Begin VB.PictureBox Picture2 
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      Height          =   540
      Left            =   660
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   1
      Top             =   2610
      Width           =   540
   End
   Begin VB.PictureBox Picture1 
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      Height          =   540
      Left            =   630
      Picture         =   "Bmp2Icon.frx":0442
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   0
      Top             =   1110
      Width           =   540
   End
   Begin VB.Label Label5 
      Caption         =   "这里以32x32像素示例"
      Height          =   195
      Left            =   90
      TabIndex        =   12
      Top             =   30
      Width           =   3285
   End
   Begin VB.Line Line1 
      X1              =   142
      X2              =   142
      Y1              =   48
      Y2              =   264
   End
   Begin VB.Label Label4 
      Caption         =   "新位图 (saved in file ""Fromico.bmp"")"
      Height          =   600
      Left            =   2400
      TabIndex        =   7
      Top             =   2100
      Width           =   1575
   End
   Begin VB.Label Label3 
      Caption         =   "源图片(.ico)"
      Height          =   450
      Left            =   2670
      TabIndex        =   6
      Top             =   690
      Width           =   855
   End
   Begin VB.Label Label2 
      Caption         =   "新图标ico (saved in file  ""Frombmp.ico"")"
      Height          =   600
      Left            =   300
      TabIndex        =   5
      Top             =   2070
      Width           =   1485
   End
   Begin VB.Label Label1 
      Caption         =   "源图片(.bmp)"
      Height          =   450
      Left            =   480
      TabIndex        =   4
      Top             =   690
      Width           =   975
   End
End
Attribute VB_Name = "frmBmp2Icon"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
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()
    ' Create monochrome hDC and bitmap
    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
      ' Let us select a background color here (just a matter of choice)
    picImage.BackColor = Picture1.BackColor
      ' Area having the following color is to be transparent
    mtransp = Picture1.Point(0, 0)
      ' Create transparent part
    CreateTransparent Picture1, picImage, mtransp
      ' Create a mask
    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
    
'--------------------------------------------------------
'NB This following is only a matter of variation, not a must.

'   Let us select the form's color as background color here
'   and replace the existing one with it.
'--------------------------------------------------------
    p = Picture4.Point(0, 0)
    q = Me.BackColor
      ' Paint the desired color as if backgound
    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
     
      ' Create memory device context (0 is screen, as we want the new
      ' DC compatible with the screen).
     hdcMono2 = CreateCompatibleDC(0)
     If hdcMono2 = 0 Then
         GoTo errHandler
     End If
      ' Create monochrome bitmap, of a wanted size
     bmpMono2 = CreateCompatibleBitmap(hdcMono2, dx, dy)
      ' Get a monohrome bitmap by default after putting in the
      ' above created bitmap into the DC.
     bmpMonoTemp2 = SelectObject(hdcMono2, bmpMono2)
      ' Copy bitmap of Pic1 to memory DC to create mono mask of the color bitmap.
     mresult = BitBlt(hdcMono2, 0, 0, dx, dy, Pic1.hdc, 0, 0, vbSrcCopy)
      ' Copy mono memory mask to a picture box, as wanted in this case
     mresult = BitBlt(Pic2.hdc, 0, 0, dx, dy, hdcMono2, 0, 0, vbSrcCopy)
     
      ' Clean up
     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
      ' Third parameter set to 1 (true) to let picture be destroyed automatically
    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            ' Doesn't matter here
        .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
    
     ' Set back color of source pic and dest pic to the desired transparent color
    mresult = SetBkColor&(mSrcHDC, inTrasparentColor)
    mresult = SetBkColor&(mDestHDC, inTrasparentColor)
    
    ' Create a mask DC compatible with dest image
    mMaskDC = CreateCompatibleDC(mDestHDC)
    ' and a bitmap of its size
    mMaskBmp = CreateCompatibleBitmap(mDestHDC, w, h)
    ' Move that bitmap into mMaskDC
    mTempMaskBMP = SelectObject(mMaskDC, mMaskBmp)
    
    ' Meanwhile create another DC for mono bitmap
    mMonoDC = CreateCompatibleDC(mDestHDC)
    '  and its bitmap, a mono one (by setting nPlanes and nbitcount
    '  both to 1)
    mMonoBMP = CreateBitmap(w, h, 1, 1, 0)
    mTempMonoBMP = SelectObject(mMonoDC, mMonoBMP)
    
    ' Copy source image to mMonoDC
    mresult = BitBlt(mMonoDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcCopy)
        
    ' Copy mMonoDC into mMaskDC
    mresult = BitBlt(mMaskDC, 0, 0, w, h, mMonoDC, 0, 0, vbSrcCopy)

    'We don't need mMonoBMP any longer
    mMonoBMP = SelectObject(mMonoDC, mTempMonoBMP)
    mresult = DeleteObject(mMonoBMP)
    mresult = DeleteDC(mMonoDC)
    
    'Now copy source image to dest image with XOR
    mresult = BitBlt(mDestHDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcInvert)
    
    'Copy the mMaskDC to dest image with AND
    mresult = BitBlt(mDestHDC, 0, 0, w, h, mMaskDC, 0, 0, vbSrcAnd)
    
    'Copy source image to dest image with XOR
    BitBlt mDestHDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcInvert
    'Picture is there to stay
    inpicDest.Picture = inpicDest.Image
     
    ' We don't need these
    mMaskBmp = SelectObject(mMaskDC, mTempMaskBMP)
    mresult = DeleteObject(mMaskBmp)
    mresult = DeleteDC(mMaskDC)
End Sub



' Last clear up
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    SelectObject bmpMono, bmpMonoTemp
    DeleteObject bmpMono
    DeleteDC hdcMono
End Sub

Private Sub picImage_Click()

End Sub

Private Sub picMask_Click()

End Sub