Hola este post viene a continuación de
este post en donde
Yvan preguntaba como redimensionar a una imagen teniendo el array de bits de la misma (esto era por la necesidad de guardar esta imagen en una Base de Datos) y luego mostrarla en el ucImagen.
Pongo una respuesta en un nuevo hilo ya cambiar el tamaño de una imagen suele ser una pregunta frecuente.
El siguiente modulo bas contiene una función publica llamada
ResizeImagenStream en donde contiene cuatro parámetros, el primero es de entrada en el cual pasamos el array de bits original de la imagen, el segundo es un parámetro de entrada y salida en el cual ingresamos un array y si la función tiene éxito nos devolverá el array de bits de una imagen con otras dimensiones, el segundo corresponde a la dimensión que queramos que tenga esta como máximo, y el cuarto es opcional para la calidad del jpg de salida (de 0 a 100, por defecto 80) , si la función tiene éxito retornara True del o contrario False.
Dentro de la función
ResizeImagenStream comente dos opciones o formas de lograr dicha rutina, la primera es rápida pero con poca calidad (deshabilitada), la segunda es más lenta pero tiene mejor calidad (por defecto habilitada) según el caso les venga mejor a ustedes la cambian.
Option Explicit
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToStream Lib "gdiplus" (ByVal Image As Long, ByVal Stream As IUnknown, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal Stream As Any, ByRef Image 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 GdipGetImageThumbnail Lib "GdiPlus.dll" (ByVal mImage As Long, ByVal mThumbWidth As Long, ByVal mThumbHeight As Long, ByRef mThumbImage As Long, ByRef mcallback As Long, ByRef mcallbackData As Long) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, BITMAP As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal Image As Long, ByRef Graphics As Long) As Long
Private Declare Function GdipDrawImageRect Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mImage As Long, ByVal mX As Single, ByVal mY As Single, ByVal mWidth As Single, ByVal mHeight As Single) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal Graphics As Long) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GetHGlobalFromStream Lib "ole32" (ByVal ppstm As Long, hGlobal As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Type RECTF
nLeft As Single
nTop As Single
nWidth As Single
nHeight As Single
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter(15) As EncoderParameter
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Const EncoderParameterValueTypeLong As Long = 4
Private Const PixelFormat24bppRGB As Long = &H21808
Private Const UnitPixel As Long = &H2&
Private Const ImageCodecJPG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const ImageCodecPNG As String = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Public Function ResizeImagenStream(ByRef InStream() As Byte, ByRef OutStream() As Byte, ByVal ThumbnailScale As Long, Optional ByVal JPG_Quality As Long = 80) As Boolean
Dim GDIsi As GdiplusStartupInput
Dim gToken As Long
Dim tRect As RECTF
Dim ReqWidth As Long, ReqHeight As Long
Dim HScale As Double, VScale As Double
Dim MyScale As Double
Dim hImage As Long
Dim hThumbImage As Long
GDIsi.GdiplusVersion = 1&
GdiplusStartup gToken, GDIsi
If gToken Then
If StreamToImage(InStream, hImage) Then
GdipGetImageBounds hImage, tRect, UnitPixel
HScale = ThumbnailScale / tRect.nWidth
VScale = ThumbnailScale / tRect.nHeight
MyScale = IIf(VScale >= HScale, HScale, VScale)
ReqWidth = tRect.nWidth * MyScale
ReqHeight = tRect.nHeight * MyScale
'-------------------Opción 1 (Menor calidad de imagen, pero mas rapido)
'If GdipGetImageThumbnail(hImage, ReqWidth, ReqHeight, hThumbImage, 0&, 0&) = 0 Then
' If ImageToStream(hThumbImage, OutStream, JPG_Quality) Then
' ResizeImagenStream = True
' End If
' GdipDisposeImage hThumbImage
'End If
'--------------------------
'-------------------Opción 2 (Mayor calidad de imagen, pero mas lento)
If GdipCreateBitmapFromScan0(ReqWidth, ReqHeight, 0&, PixelFormat24bppRGB, ByVal 0&, hThumbImage) = 0 Then
Dim hGraphics As Long
If GdipGetImageGraphicsContext(hThumbImage, hGraphics) = 0 Then
If GdipDrawImageRect(hGraphics, hImage, 0, 0, ReqWidth, ReqHeight) = 0 Then
If ImageToStream(hThumbImage, OutStream, JPG_Quality) Then
ResizeImagenStream = True
End If
End If
GdipDeleteGraphics hGraphics
End If
GdipDisposeImage hThumbImage
End If
'------------------------------
GdipDisposeImage hImage
End If
GdiplusShutdown gToken
End If
End Function
Private Function ArrayFromStream(Stream As IUnknown, arrayBytes() As Byte) As Boolean
' Purpose: Return the array contained in an IUnknown interface
Dim o_hMem As Long, o_lpMem As Long
Dim o_lngByteCount As Long
If Not Stream Is Nothing Then
If GetHGlobalFromStream(ByVal ObjPtr(Stream), o_hMem) = 0 Then
o_lngByteCount = GlobalSize(o_hMem)
If o_lngByteCount > 0 Then
o_lpMem = GlobalLock(o_hMem)
If o_lpMem <> 0 Then
ReDim arrayBytes(0 To o_lngByteCount - 1)
CopyMemory arrayBytes(0), ByVal o_lpMem, o_lngByteCount
GlobalUnlock o_hMem
ArrayFromStream = True
End If
End If
End If
End If
End Function
Private Function ImageToStream(ByVal hImage As Long, ByRef OutStream() As Byte, ByVal JPG_Quality As Long) As Boolean
Dim tEncoder As GUID
Dim tParams As EncoderParameters
Dim IStream As IUnknown
Erase OutStream
If hImage = 0 Then Exit Function
Set IStream = CreateStream(OutStream)
If Not IStream Is Nothing Then
CLSIDFromString StrPtr(ImageCodecJPG), tEncoder
With tParams
.Count = 1
.Parameter(0).NumberOfValues = 1
.Parameter(0).type = EncoderParameterValueTypeLong
.Parameter(0).Value = VarPtr(JPG_Quality)
CLSIDFromString StrPtr(EncoderQuality), .Parameter(0).GUID
End With
If GdipSaveImageToStream(hImage, IStream, tEncoder, tParams) = 0& Then
ImageToStream = ArrayFromStream(IStream, OutStream())
End If
Set IStream = Nothing
End If
End Function
Public Function StreamToImage(ByRef InStream() As Byte, ByRef hImage As Long) As Boolean
Dim IStream As IUnknown
If iparseIsArrayEmpty(VarPtrArray(InStream)) = 0& Then Exit Function
Set IStream = CreateStream(InStream())
If Not IStream Is Nothing Then
If GdipLoadImageFromStream(IStream, hImage) = 0 Then
StreamToImage = hImage <> 0
End If
Set IStream = Nothing
End If
End Function
Private Function iparseIsArrayEmpty(FarPointer As Long) As Long
' test to see if an array has been initialized
CopyMemory iparseIsArrayEmpty, ByVal FarPointer, 4&
End Function
Private Function CreateStream(byteContent() As Byte, Optional byteOffset As Long = 0&) As stdole.IUnknown
' Purpose: Create an IStream-compatible IUnknown interface containing the
' passed byte aray. This IUnknown interface can be passed to GDI+ functions
' that expect an IStream interface -- neat hack
On Error GoTo HandleError
Dim o_lngLowerBound As Long
Dim o_lngByteCount As Long
Dim o_hMem As Long
Dim o_lpMem As Long
If iparseIsArrayEmpty(VarPtrArray(byteContent)) = 0& Then ' create a growing stream as needed
Call CreateStreamOnHGlobal(0, 1, CreateStream)
Else ' create a fixed stream
o_lngByteCount = UBound(byteContent) - byteOffset + 1
o_hMem = GlobalAlloc(&H2&, o_lngByteCount)
If o_hMem <> 0 Then
o_lpMem = GlobalLock(o_hMem)
If o_lpMem <> 0 Then
CopyMemory ByVal o_lpMem, byteContent(byteOffset), o_lngByteCount
Call GlobalUnlock(o_hMem)
Call CreateStreamOnHGlobal(o_hMem, 1, CreateStream)
End If
End If
End If
HandleError:
End Function
Un ejemplo para tener mas claro todo (agregan una imagen grandes dimenciónes en el path del proyecto con el nombre "Original.jpg")
En un formulario
Option Explicit
Private Sub Form_Load()
Dim hFile As Long
Dim ArrImagen() As Byte
Dim ArrResize() As Byte
Dim SrcPath As String
Dim DestPath As String
SrcPath = App.Path & "\Original.jpg"
DestPath = App.Path & "\Resize.jpg"
hFile = FreeFile
Open SrcPath For Binary As #hFile
ReDim ArrImagen(LOF(hFile) - 1)
Get #hFile, , ArrImagen
Close #hFile
If ResizeImagenStream(ArrImagen, ArrResize, 500, 80) Then
If Len(Dir(DestPath)) Then Kill DestPath
hFile = FreeFile
Open DestPath For Binary As #hFile
Put #hFile, , ArrResize
Close #hFile
Else
MsgBox "Error!"
End If
End Sub
