Binaryworld - High quality image scaling ... [ VB -> Graphics ]

Have you ever tried to use StretchBlt to resize image. Yep its easy to use with VB but if you use it without setting correct "Stretch Mode" it wont be a high quality image. To get high quality stretched image you can call SetStretchBltMode and set HALFTONE mode for highest quality image resizing. Following images shows the difference when you stretch image 3 times using normal scale mode and HALFTONE mode.

Step-By-Step Example

- Create a standard exe project
- Add 2 command button controls and 2 picturebox controls on the form1
- Assign image to picture1
- Add the following code in form1

Click here to copy the following block

Private Declare Function SetStretchBltMode Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal nStretchMode As Long) As Long

Private Declare Function StretchBlt Lib "gdi32.dll" ( _
    ByVal hdc 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 nSrcWidth As Long, _
    ByVal nSrcHeight As Long, _
    ByVal dwRop As Long) As Long

Private Declare Function GetStretchBltMode Lib "gdi32.dll" ( _
    ByVal hdc As Long) As Long

Private Const BLACKONWHITE As Long = 1
Private Const COLORONCOLOR As Long = 3
Private Const WHITEONBLACK As Long = 2
Private Const HALFTONE As Long = 4

Dim XScale As Single, YScale As Single
Dim PicWidth As Long, PicHeight As Long
Dim OldMode As Long

Private Sub Command1_Click()

  OldMode = SetStretchBltMode(Picture2.hdc, HALFTONE)
  StretchNow
  SetStretchBltMode Picture2.hdc, OldMode

End Sub

Private Sub Command2_Click()
  Call StretchNow
End Sub

Sub StretchNow()
  Dim sX, sY, sW, sH

  Select Case GetStretchBltMode(Picture2.hdc)
    Case BLACKONWHITE
      MsgBox "BLACKONWHITE StretchBltMode"
    Case COLORONCOLOR
      MsgBox "COLORONCOLOR StretchBltMode"
    Case WHITEONBLACK
      MsgBox "WHITEONBLACK StretchBltMode"
    Case HALFTONE
      MsgBox "HALFTONE StretchBltMode"
    Case Else
      MsgBox "Unknown StretchBltMode"
  End Select

  XScale = 2  '//2 times
  YScale = 2

  sX = 70
  sY = 20
  sW = 70
  sH = 70

  Picture1.Line (sX, sY)-(sX + sW - 1, sY + sH - 1), vbRed, B
  Picture1.Refresh

  Call StretchBlt(Picture2.hdc, 0, 0, sW * XScale, _
      sH * YScale, Picture1.hdc, sX, sY, sW, sH, vbSrcCopy)

  Picture2.Refresh
End Sub

Private Sub Form_Load()
  Command1.Caption = "Stretch"
  Command2.Caption = "Stretch (HALFTONE)"
  'Picture1.Picture = LoadPicture("X:\Path\File.jpg")
  With Picture1
    PicWidth = .ScaleX(.Picture.Width, vbHimetric, vbPixels)
    PicHeight = .ScaleY(.Picture.Height, vbHimetric, vbPixels)
  End With

  Picture1.ScaleMode = vbPixels
  Picture1.AutoRedraw = True
  Picture2.AutoRedraw = True
End Sub