redimension de imagen, pierde calidad

[izar]

al hacer un resize de una imagen a un tamaño menor, pierde calidad.

Este es mi funcion

Podeis echarme un cable

gracias

Código:

  Public Sub RedimensionarImagen(ByVal imagen As String, ByVal DimensionMax As Integer, Optional ByVal SubCarpeta As String = "", Optional ByVal ImagenPeq As Boolean = False)
        Dim original As System.Drawing.Image = System.Drawing.Image.FromFile(imagen)
        Dim imgPhoto As System.Drawing.Image = System.Drawing.Image.FromFile(imagen)

        'Establecemos las nuevas medidas
        Dim ancho, alto As Integer
        If original.Width > original.Height Then
            alto = DimensionMax * original.Height / original.Width
            ancho = DimensionMax
        Else
            alto = DimensionMax
            ancho = DimensionMax * original.Width / original.Height
        End If

        Dim bmPhoto As New Bitmap(ancho, alto, PixelFormat.Format24bppRgb)
        Dim grPhoto As Graphics = Graphics.FromImage(bmPhoto)

        With grPhoto

         
            .SmoothingMode = SmoothingMode.AntiAlias
            .InterpolationMode = InterpolationMode.HighQualityBicubic
            .CompositingQuality = CompositingQuality.HighQuality
            .PixelOffsetMode = PixelOffsetMode.HighQuality
            .DrawImage(imgPhoto, New Rectangle(0, 0, ancho, alto), New Rectangle(0, 0, original.Width, original.Height), GraphicsUnit.Pixel)
        End With

        'Generamos el nombre para el fichero redimensionado
        Dim nuevoFic As String = Path.GetDirectoryName(imagen)
        If nuevoFic.EndsWith(Path.DirectorySeparatorChar) = False Then
            nuevoFic &= Path.DirectorySeparatorChar
        End If
        'Solo si se necesita una imagen nueva
        If ImagenPeq Then
            nuevoFic &= Path.GetFileNameWithoutExtension(imagen) & "_peq" & Path.GetExtension(imagen)
        Else
            nuevoFic &= Path.GetFileNameWithoutExtension(imagen) & Path.GetExtension(imagen)
        End If

        'se libera para que no haya problemas con el GDI
        original.Dispose()
        imgPhoto.Dispose()
        'Grabamos la nueva foto una vez que liberamos de la memoria la imagen por si no se renombra
        bmPhoto.Save(nuevoFic, Imaging.ImageFormat.Jpeg)
        'si hay subcarpeta se mueve a ella
        grPhoto.Dispose()
        bmPhoto.Dispose()

        'si existe la subcarpeta se mueve a esta subcarpeta
        If Len(SubCarpeta) > 0 Then
            SubCarpeta = Path.GetDirectoryName(imagen) & "\" & SubCarpeta & "\" & Path.GetFileNameWithoutExtension(imagen) & "_peq" & Path.GetExtension(imagen)
            File.Move(nuevoFic, SubCarpeta)
        End If

    End Sub