Option Explicit
 
' Zunächst die nötigen Deklarationen
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
 
Private Type GdiplusStartupInput
  GdiplusVersion As Long
  DebugEventCallback As Long
  SuppressBackgroundThread As Long
  SuppressExternalCodecs As Long
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 As EncoderParameter
End Type
 
Private Declare Function GdiplusStartup Lib "GDIPlus" ( _
  token As Long, _
  inputbuf As GdiplusStartupInput, _
  Optional ByVal outputbuf As Long = 0) As Long
 
Private Declare Function GdiplusShutdown Lib "GDIPlus" ( _
  ByVal token As Long) As Long
 
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" ( _
  ByVal hbm As Long, _
  ByVal hpal As Long, _
  Bitmap As Long) As Long
 
Private Declare Function GdipDisposeImage Lib "GDIPlus" ( _
  ByVal Image As Long) As Long
 
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" ( _
  ByVal Image As Long, _
  ByVal filename As Long, _
  clsidEncoder As GUID, _
  encoderParams As Any) As Long
 
Private Declare Function CLSIDFromString Lib "ole32" ( _
  ByVal str As Long, _
  id As GUID) As Long
 
Public Sub Save_JPG(PictureBoxObjekt As PictureBox, ByVal filename As String, _
  Optional ByVal quality As Byte = 200)
 
  Dim tSI As GdiplusStartupInput
  Dim lRes As Long
  Dim lGDIP As Long
  Dim lBitmap As Long
 
  Dim pict As New StdPicture
  Set pict = PictureBoxObjekt.Picture
 
  ' GDI+ initalisieren
  tSI.GdiplusVersion = 1
  lRes = GdiplusStartup(lGDIP, tSI)
 
  If lRes = 0 Then
    '  Erstelle GDI+ Bitmap aus dem Image Handler
    lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
 
    If lRes = 0 Then
      Dim tJpgEncoder As GUID
      Dim tParams As EncoderParameters
 
      ' Initialiseren des Encoders
      CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), _
        tJpgEncoder
 
      ' Nun die Parametrierung...
      tParams.Count = 1
      With tParams.Parameter ' Quality
        ' Quality GUID festlegen
        CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
        .NumberOfValues = 1
        .type = 4
        .Value = VarPtr(quality)
      End With
 
      ' Speichern des Bildes
      lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, _
        tParams)
 
      ' Zerstören des Bildes
      GdipDisposeImage lBitmap
    End If
 
    ' GDI+ deinitalisieren
    GdiplusShutdown lGDIP
  End If
 
  If lRes Then
  Exit Sub
  End If
End Sub