Got to playing with different methods of resizing.
Hands down winner: GDI+ bicubic. Below is what you need. I'm afraid
it's in bits. One function opens a file and loads it, resizes, then
paints the bitmap. If you take the loading path and combine it
with the saving part from the second half of the second function,
you'll have a load, resize, save as JPG that's better than other
options. If you use bicubic (4 as interpolation mode) then you
get a beter image than bilinear in about the same time.
Public Enum gdiplusStatus '-- returned by gdip* methods
Ok = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
ProfileNotFound = 21
End Enum
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type RECTF
nLeft As Single
nTop As Single
nWidth As Single
nHeight As Single
End Type
Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Const UnitPixel As Long = 2
Public Enum InterpolationConstants
InterpolationModeDefault = 0
InterpolationModeLowQuality = 1
InterpolationModeHighQuality = 2
InterpolationModeBilinear = 3
InterpolationModeBicubic = 4
InterpolationModeNearestNeighbor = 5
InterpolationModeHighQualityBilinear = 6
InterpolationModeHighQualityBicubic = 7
End Enum
Private Declare Function GdiplusStartup Lib "GdiPlus" (token As Long,
inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As
Long
Private Declare Function GdipLoadImageFromFile Lib "GdiPlus.dll" (ByVal
mFilename As Long, ByRef mImage As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal
mGraphics As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "GdiPlus" (ByVal hdc As Long,
hGraphics As Long) As Long
Private Declare Function GdipDisposeImage Lib "GdiPlus" (ByVal Image As
Long) As Long
Private Declare Sub GdiplusShutdown Lib "GdiPlus" (ByVal token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll"
(ByVal hbm As Long, ByVal hPal As Long, ByRef pBitmap As Long) As Long
Private Declare Function GdipGetImageBounds Lib "GdiPlus.dll" (ByVal nImage
As Long, srcRect As RECTF, srcUnit As Long) As Long
Private Declare Function GdipSetInterpolationMode Lib "GdiPlus" (ByVal
hGraphics As Long, ByVal Interpolation As Long) As Long
Private Declare Function GdipDrawImageRectRectI Lib "GdiPlus" (ByVal
hGraphics As Long, ByVal hImage As Long _
, ByVal dstX As Long, ByVal dstY As Long, ByVal
dstWidth As Long, ByVal dstHeight As Long _
, ByVal SrcX As Long, ByVal SrcY As Long, ByVal
srcWidth As Long, ByVal srcHeight As Long _
, ByVal srcUnit As Long, Optional ByVal
imageAttributes As Long = 0 _
, Optional ByVal Callback As Long = 0, Optional
ByVal callbackData As Long = 0) As Long
Public Declare Function GdipSaveImageToFile Lib "GdiPlus" (ByVal Image As
Long, ByVal sFilePath As Long, clsidEncoder As GUID, encoderParams As Any)
As Long
'-- used with GDIP:
Public Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id
As GUID) As Long
'--resize an image in proportion to original and paint.
Public Function ResizeAndPaintGDIP(FileName As String, DesthDC As Long,
DestW As Long, Interpolation As Long) As Long
Dim GDIsi As GdiplusStartupInput
Dim gToken As Long, hGraphics As Long, hBitmap As Long, LRet As Long
Dim ImRect As RECTF
Dim DestH As Long
On Error Resume Next
GDIsi.GdiplusVersion = 1&
LRet = GdiplusStartup(gToken, GDIsi)
If LRet <> 0 Then ResizeAndPaintGDIP = LRet: Exit Function
LRet = GdipCreateFromHDC(DesthDC, hGraphics)
If hGraphics <> 0 Then
LRet = GdipLoadImageFromFile(StrPtr(FileName), hBitmap)
If hBitmap <> 0 Then
LRet = GdipGetImageBounds(hBitmap, ImRect, UnitPixel)
LRet = GdipSetInterpolationMode(hGraphics, Interpolation)
DestH = CLng(ImRect.nHeight * (DestW / ImRect.nWidth))
LRet = GdipDrawImageRectRectI(hGraphics, hBitmap, 0, 0, DestW,
DestH, 0, 0, ImRect.nWidth, ImRect.nHeight, UnitPixel, 0&, 0&, 0&)
GdipDisposeImage hBitmap
ResizeAndPaintGDIP = LRet
End If
GdipDeleteGraphics hGraphics
End If
GdiplusShutdown gToken
End Function
Public Function WriteJPG(sPath As String, ByVal Quality As Long) As Long
'11-11
Dim hdc As Long, LRet As Long, LRet2 As Long
Dim hGDIPBitmap As Long 'handle to GDI+ bitmap.
Dim BBits() As Byte
Dim GUIDEncodeJPG As GUID
Dim EncodeParams As EncoderParameters
Const EncoderValueType As Long = &H4
On Error Resume Next
ReDim BBits(BMPInfo.bmiHeader.biHeight * BytesPerScanLine) As Byte
hdc = CreateCompatibleDC(0&)
LRet = GetDIBits(hdc, CurPic, 0, Abs(BMPInfo.bmiHeader.biHeight),
BBits(0), BMPInfo, DIB_RGB_COLORS)
LRet2 = DeleteDC(hdc)
If (LRet = 0) Then
WriteJPG = 1
Exit Function
End If
GdipCreateBitmapFromGdiDib BMPInfo, ByVal VarPtr(BBits(0)), hGDIPBitmap
If hGDIPBitmap <> 0 Then
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"),
GUIDEncodeJPG
' Initialize the encoder parameters
EncodeParams.Count = 1
With EncodeParams.Parameter ' Quality
CLSIDFromString
StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
.NumberOfValues = 1
.Type = EncoderValueType
.Value = VarPtr(Quality)
End With
LRet = GdipSaveImageToFile(hGDIPBitmap, StrPtr(sPath),
GUIDEncodeJPG, EncodeParams)
GdipDisposeImage hGDIPBitmap ' Destroy the bitmap
Else
LRet = 2 'set error code.
End If
WriteJPG = LRet
End Function