Binaryworld - How to use CopyImage API to create a resized monochrome image from the ... [ VB -> Bitmap ]

In some situation you can find CopyImage API very useful. CopyImage can create a new resized monochrome bitmap using single API call.

Step-By-Step Example

- Create a standard exe project
- Place two picturebox controls and two command buttons
- Place the following code in form1

Click here to copy the following block

Const IMAGE_BITMAP = 0&
Const LR_MONOCHROME = &H1
Const LR_COPYRETURNORG = &H4

Private Declare Function CopyImage Lib "user32" ( _
    ByVal hImage As Long, _
    ByVal uType As Long, _
    ByVal cxDesired As Long, _
    ByVal cyDesired As Long, _
    ByVal fuFlags 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 DeleteObject Lib "gdi32" ( _
    ByVal hObject As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" ( _
    ByVal hdc As Long) As Long

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 Sub Command1_Click()
  Picture1.Picture = LoadPicture(Text1)

  Picture1.Width = ScaleX(Picture1.Picture.Width)
  Picture1.Height = ScaleY(Picture1.Picture.Height)
End Sub

Private Sub Command2_Click()
  Dim hDcNew, hBmpNew As Long, hBmpOld As Long
  hDcNew = CreateCompatibleDC(0&)

  '//Resize image to exact same size of destination picturebox
  With Picture2
    thumbwid = .ScaleWidth
    thumbhgt = .ScaleHeight
  End With

  '//CopyImage returns handle to resized bitmap
  hBmpNew = CopyImage(Picture1.Picture.Handle, _
      IMAGE_BITMAP, thumbwid, thumbhgt, LR_MONOCHROME)

  '//or Directly Load resized image from the file

  'hBmpNew = CopyImage(LoadPicture(Text1), _
  '    IMAGE_BITMAP, thumbwid, thumbhgt, LR_MONOCHROME)

  hBmpOld = SelectObject(hDcNew, hBmpNew)

  '//Draw resized bitmap on destination DC
  BitBlt Picture2.hdc, 0, 0, thumbwid, thumbhgt, hDcNew, 0, 0, vbSrcCopy

  Picture2.Refresh

  '//Select old bitmap back into the DC
  SelectObject hDcNew, hBmpOld

  '//Clean Up
  DeleteObject hBmpNew
  DeleteDC hDcNew
End Sub

Private Sub Form_Load()
  Picture2.ScaleMode = 3
  Picture2.AutoRedraw = True
  Text1.Text = App.Path & "\test.jpg"
  Command1.Caption = "Load Image File"
  Command2.Caption = "Do Copy Image"
End Sub