'2 picture boxes one with a .bmp, 1 command button
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (lpString As Any) As Long
Private Declare Function IsBadStringPtrByLong Lib "kernel32" Alias "IsBadStringPtrW" (ByVal lpsz As Long, ByVal ucchMax As Long) As Long
Private Sub Command1_Click()
Dim GpInput As GdiplusStartupInput
'Dim Token As Long
Dim myCLSID As CLSID
Dim myEncoderParameters As EncoderParameters
Dim myEncoder(0) As EncoderParameter
Dim gdiImage As Long
Dim gdiImageTarget As Long
Dim Quality As Long
Dim myGraphics As Long
Dim Token As Long
' New declarations compared to original file-based version of this code
Dim myStream As GdiPlus.IStream ' Use the GDI+ type library's IStream interface
Dim b(4096000) As Byte ' for this example hardcode in a max available stream size of 4Mb
On Error GoTo XXX
' Get and check we have a CLSID for a jpeg codec
If GetEncoderCLSID("image/jpeg", myCLSID) Then
GpInput.GdiplusVersion = 1
If GdiplusStartup(Token, GpInput) <> Ok Then
MsgBox "Error loading GDI+!", vbCritical
Else
myEncoderParameters.Count = 1
myEncoder(0).Guid = GdiPlus.CLSIDFromString(EncoderQuality)
myEncoder(0).Type = EncoderParameterValueTypeLong
myEncoder(0).NumberOfValues = 1
Quality = 25 ' 0 to 100%
myEncoder(0).ValuePtr = VarPtr(Quality)
myEncoderParameters.Parameter = myEncoder(0)
GdipCreateBitmapFromHBITMAP Picture1.Picture.Handle, Picture1.Picture.hPal, gdiImage
Set myStream = CreateStreamOnHGlobal(b(0), True)
' OK save image as a compressed JPG into a stream
GdipSaveImageToStream gdiImage, myStream, myCLSID, VarPtr(myEncoderParameters) ' one change from my previous example, to save to a stream instead of a file
' Extra stuff to show loading the stream into a target picturebox
GdipLoadImageFromStream myStream, gdiImageTarget
' OK we can dispose of stream
Set myStream = Nothing
' Now display, letting GDI+ do all the hard work
GdipCreateFromHDC Picture2.hDC, myGraphics
GdipDrawImage myGraphics, gdiImageTarget, 0, 0
YYY:
' Clean up
GdipDisposeImage gdiImage
GdipDisposeImage gdiImageTarget
GdipDeleteGraphics myGraphics
GdiplusShutdown Token
Set myStream = Nothing
End If
End If
On Error GoTo 0
Exit Sub
XXX:
MsgBox Error & " Fault in Converting", vbCritical, "ERROR"
Resume YYY
End Sub
' helper function to get CLSID of output codec
Private Function GetEncoderCLSID(ByVal strMimeType As String, outCLSID As CLSID) As Long
Dim GpInput As GdiplusStartupInput
'Dim Token As Long
Dim lEncoders As Long
Dim lEncodersBuffer As Long
Dim lp As Long
Dim arrEncoders() As ImageCodecInfo
Dim Token As Long
GpInput.GdiplusVersion = 1
If GdiplusStartup(Token, GpInput) <> Ok Then
MsgBox "Error loading GDI+!", vbCritical
Else
GdipGetImageEncodersSize lEncoders, lEncodersBuffer
ReDim arrEncoders(lEncoders - 1) As ImageCodecInfo
GdipGetImageEncoders lEncoders, lEncodersBuffer, arrEncoders(0)
GdiplusShutdown Token
GetEncoderCLSID = False
For lp = LBound(arrEncoders) To UBound(arrEncoders)
If StringFromPointer(arrEncoders(lp).MimeTypePtr) = strMimeType Then
outCLSID = arrEncoders(lp).CLSID
GetEncoderCLSID = True
Exit For
End If
Next
End If
End Function
' Works for strings that are nullchar terminated
Public Function StringFromPointer(lpString As Long) As String
Dim sRet As String
Dim lret As Long
Dim lMaxLength As Long
Dim lCodec
If lpString = 0 Then
StringFromPointer = ""
Exit Function
End If
lMaxLength = lstrlen(ByVal lpString) * 2
If IsBadStringPtrByLong(lpString, lMaxLength) Then
StringFromPointer = ""
Exit Function
End If
sRet = Space$(lMaxLength)
CopyMemory ByVal sRet, ByVal lpString, Len(sRet)
StringFromPointer = StrConv(sRet, vbFromUnicode) 'sRet
End Function
Private Sub Form_Unload(Cancel As Integer)
Set Form1 = Nothing
End Sub
