Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/bmp2ico/bmp2icon.frm

Visual Basic Form | 1999-10-12 | 19.1 KB | 527 lines

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  'Windows Default
   Begin VB.PictureBox Picture2
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      Height          =   540
      Left            =   690
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   14
      Top             =   2640
      Width           =   540
   End
   Begin VB.PictureBox Picture1
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      Height          =   540
      Left            =   660
      Picture         =   "Bmp2Icon.frx":0000
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   13
      Top             =   1080
      Width           =   540
   End
   Begin VB.CommandButton Command4
      Height          =   345
      Left            =   3930
      TabIndex        =   11
      ToolTipText     =   "Clear display of new bmp"
      Top             =   3630
      Width           =   135
   End
   Begin VB.CommandButton Command3
      Height          =   345
      Left            =   1620
      TabIndex        =   10
      ToolTipText     =   "Clear display of new ico"
      Top             =   3630
      Width           =   135
   End
   Begin VB.PictureBox picImage
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H00000000&
      ForeColor       =   &H80000008&
      Height          =   540
      Left            =   3750
      ScaleHeight     =   34
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   34
      TabIndex        =   9
      Top             =   30
      Visible         =   0   'False
      Width           =   540
   End
   Begin VB.PictureBox picMask
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   540
      Left            =   3750
      ScaleHeight     =   34
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   34
      TabIndex        =   8
      Top             =   600
      Visible         =   0   'False
      Width           =   540
   End
   Begin VB.CommandButton Command2
      Caption         =   "Ico to Bmp"
      Height          =   345
      Left            =   2640
      TabIndex        =   7
      Top             =   3630
      Width           =   1185
   End
   Begin VB.CommandButton Command1
      Caption         =   "Bmp to Ico"
      Height          =   345
      Left            =   330
      TabIndex        =   6
      Top             =   3630
      Width           =   1185
   End
   Begin VB.PictureBox Picture4
      BackColor       =   &H80000005&
      Height          =   540
      Left            =   2850
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   1
      Top             =   2610
      Width           =   540
   End
   Begin VB.PictureBox Picture3
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      Height          =   540
      Left            =   2850
      Picture         =   "Bmp2Icon.frx":0282
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   0
      Top             =   1080
      Width           =   540
   End
   Begin VB.Label Label5
      Caption         =   "(Size of examples here is 32x32 pixels)"
      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         =   "New bmp (saved in file ""Fromico.bmp"")"
      Height          =   405
      Left            =   2400
      TabIndex        =   5
      Top             =   2100
      Width           =   1575
   End
   Begin VB.Label Label3
      Caption         =   "Original ico"
      Height          =   285
      Left            =   2670
      TabIndex        =   4
      Top             =   690
      Width           =   855
   End
   Begin VB.Label Label2
      Caption         =   "New ico (saved in file  ""Frombmp.ico"")"
      Height          =   465
      Left            =   300
      TabIndex        =   3
      Top             =   2070
      Width           =   1485
   End
   Begin VB.Label Label1
      Caption         =   "Original bmp"
      Height          =   285
      Left            =   480
      TabIndex        =   2
      Top             =   690
      Width           =   975
   End
Attribute VB_Name = "frmBmp2Icon"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' Bmp2Ico.frm
' By Herman Liu
' To show how to make an icon file out of a bitmap, and vice versa.
' Sometimes you see a nice bitmap picture, or part of it, and want to make it as an icon.
' You can do what you want now (Just add "file open" and "file save" functions to open the
' bmp/ico file and save the ico/bmp file respectively. That is, for example, instead of
' using the existing image in Picture1, load your own. When it is converted into an icon in
' Picture2, save it to a file name you want.  Of course, in this case, you may want to fix
' the size of the image first).
' Notes: If you have a copy of my "IconEdit", and you want to give yourself a challenge, you
' can incorporate this code into it. This will be fairly easy. (Basically, you only need to
' add a few menu items, as almost all the APIs here are already there, so are all major
' procedures).  In "IconEdit" I have left out many functions, since I don't want to blur the
' essentials.  For example, if I open up just the Region function, there would be
' implications on Flip/Rotate/Invert and I have to allow region dragging and so on.)
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 Declare Function ExtFloodFill Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, _
      ByVal Y As Long, ByVal crColor As Long, ByVal wFillType As Long) 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
      ' Just to make sure
    picImage.AutoRedraw = True
    picMask.AutoRedraw = True
End Sub
Private Sub command1_click()
    On Error Resume Next
    picImage.Picture = LoadPicture()
    picMask.Picture = LoadPicture()
    Picture2.Picture = LoadPicture()
    '------------------------------------------------
    ' As the main aim of this program is for learning,
    ' variations are advanced for your own study.
    '------------------------------------------------
    '-------------------
    ' Alternative 1
    ' For general use
    '-------------------
    command1_Alternative
    Exit Sub
    '-------------------
    ' Alternative 2
    ' If you have a known use at a particular place
    '-------------------
        ' Let us select a background color here (just a matter of choice
        ' e.g. form1.backcolor, vbGray, so that the transparent part will
        ' blend in the surrounding backcolor when loaded)
'    picImage.BackColor = Picture1.BackColor
        ' Area having the following color is to be left out as it is meant
        ' to be transparent
'    Dim mtransp As Long
'    mtransp = Picture1.Point(0, 0)
        ' Create transparent part
'    CreateTransparent Picture1, picImage, mtransp
        ' Make sure no Autoredraw for picMask with this alternative
'    picMask.AutoRedraw = False
        ' 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 command1_Alternative()
    picImage.Line (0, 0)-(stdW - 1, stdH - 1), vbBlack, BF
    picMask.Line (0, 0)-(stdW - 1, stdH - 1), vbWhite, BF
    Dim mtransp As Long
      ' Area having the following color is to be left out
      ' as it is meant to be transparent
    mtransp = Picture1.Point(0, 0)
    Dim i, j
    For i = 0 To stdW - 1
        For j = 0 To stdH - 1
            If Picture1.Point(i, j) <> mtransp Then
                 picImage.PSet (i, j), Picture1.Point(i, j)
                 picMask.PSet (i, j)
            End If
        Next j
    Next i
    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
'--------------------------------------------------------
'  Alternatively
'  To open the following, close above and uncomment API first
'--------------------------------------------------------
'    Picture4.FillColor = q
'    Picture4.FillStyle = vbFSSolid
'    mresult = ExtFloodFill(Picture4.hdc, 0, 0, p, 1)
'       'Another line is required only because the fill area
'       'is broken by the tip point of the flap of envelope.
'    mresult = ExtFloodFill(Picture4.hdc, stdW - 1, stdH - 1, p, 1)
'--------------------------------------------------------
    SavePicture Picture4.Picture, App.Path & "/Fromico.bmp"
End Sub
' To let you see it again and again.
Private Sub Command3_Click()
    Picture2.Picture = LoadPicture()
End Sub
Private Sub Command4_Click()
    Picture4.Picture = LoadPicture()
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