Public Sub DesktopToJPG(ByVal filename As String, Optional ByVal Quality As Long = 80, Optional IncludeMouseCursor As Boolean = False)
On Error Resume Next

    Dim tSI As GdiplusStartupInput
    Dim lRes As Long, lGDIP As Long, lBitmap As Long
    Dim X As Long, Y As Long, wide As Long, high As Long
    Dim myDIB As Long, myDC As Long, desktopDC As Long
    Dim bi24BitInfo As BITMAPINFO
    Dim bitmapData() As Byte
    Dim pcin As PCURSORINFO
    Dim piinfo As ICONINFO
    ' Starting position/Size of capture (full screen)
    X = 0: Y = 0
    wide = Screen.Width / Screen.TwipsPerPixelX
    high = Screen.Height / Screen.TwipsPerPixelY
    '
    With bi24BitInfo.bmiHeader
      .biBitCount = 24
      .biCompression = BI_RGB
      .biPlanes = 1
      .biSize = Len(bi24BitInfo.bmiHeader)
      .biWidth = wide
      .biHeight = high
      .biDataSize = ((.biWidth * 3 + 3) And &HFFFFFFFC) * .biHeight
      ReDim bitmapData(0 To .biDataSize - 1)
    End With
    frmscrcontrol.Caption = UBound(bitmapData)
    myDC = CreateCompatibleDC(0)
    myDIB = CreateDIBSection(myDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
    SelectObject myDC, myDIB
    desktopDC = GetDC(0)
    BitBlt myDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, desktopDC, X, Y, vbSrcCopy Or CAPTUREBLT
    ' Include mouse cursor?
    If IncludeMouseCursor = True Then
        pcin.cbSize = Len(pcin)
        GetCursorInfo pcin
        GetIconInfo pcin.hCursor, piinfo
        DrawIcon myDC, pcin.ptScreenPos.X - piinfo.xHotspot, pcin.ptScreenPos.Y - piinfo.yHotspot, pcin.hCursor
        If piinfo.hbmMask Then DeleteObject piinfo.hbmMask
        If piinfo.hbmColor Then DeleteObject piinfo.hbmColor
    End If
    Call GetDIBits(myDC, myDIB, 0, bi24BitInfo.bmiHeader.biHeight, bitmapData(0), bi24BitInfo, DIB_RGB_COLORS)



   ' save as JPG
   '------------
   'Initialize GDI+
   tSI.GdiplusVersion = 1
   lRes = GdiplusStartup(lGDIP, tSI)
   If lRes = 0 Then
      ' Create the GDI+ bitmap from the image handle
      lRes = GdipCreateBitmapFromHBITMAP(myDIB, 0, lBitmap)
      If lRes = 0 Then
         Dim tJpgEncoder As GUID
         Dim tParams As EncoderParameters
         ' Initialize the encoder GUID
         CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
         ' Initialize the encoder parameters
         tParams.Count = 1
         With tParams.Parameter ' Quality
            ' Set the Quality GUID
            CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
            .NumberOfValues = 1
            .Type = 4
            .Value = VarPtr(Quality)
         End With
         ' Save the image
         lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)
         ' Destroy the bitmap
         GdipDisposeImage lBitmap
      End If
      ' Shutdown GDI+
      GdiplusShutdown lGDIP
   End If

   If lRes Then
      Err.Raise 5, ,"Cannot save the image. GDI+ Error:" & lRes
   End If
    ' CLEAN UP
    ReleaseDC 0, desktopDC
    DeleteObject myDIB
    DeleteDC myDC
End Sub

Option Explicit

' Note the parameter type changes...
Private Declare Function GdipSaveImageToStream Lib"gdiplus" (ByVal Image As Long, ByVal Stream As IUnknown, clsidEncoder As Any, encoderParams As Any) As Long
Private Declare Function GdipLoadImageFromStream Lib"gdiplus" (ByVal Stream As IUnknown, Image 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 GetHGlobalFromStream Lib"ole32" (ByVal ppstm As Long, hGlobal 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

Public Function IStreamFromArray(ByVal ArrayPtr As Long, ByVal Length As Long) 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

    ' ArrayPtr: passed like VarPtr(myArray(0))
    ' Length: total bytes to be read from ArrayPtr

    On Error GoTo HandleError
    Dim o_hMem As Long
    Dim o_lpMem  As Long

    If ArrayPtr = 0& Then
        CreateStreamOnHGlobal 0&, 1&, IStreamFromArray
    ElseIf Length <> 0& Then
        o_hMem = GlobalAlloc(&H2&, Length)
        If o_hMem <> 0 Then
            o_lpMem = GlobalLock(o_hMem)
            If o_lpMem <> 0 Then
                CopyMemory ByVal o_lpMem, ByVal ArrayPtr, Length
                Call GlobalUnlock(o_hMem)
                Call CreateStreamOnHGlobal(o_hMem, 1&, IStreamFromArray)
            End If
        End If
    End If

HandleError:
End Function

Public Function IStreamToArray(ByVal hStream As Long, arrayBytes() As Byte) As Boolean

    ' Return the array contained in an IUnknown interface (stream)

    ' hStream: passed as ObjPtr(IStream) where IStream declared as IUnknown
    ' arrayBytes(): an empty byte array; lBound will be zero

    Dim o_hMem As Long, o_lpMem As Long
    Dim o_lngByteCount As Long

    If hStream Then
        If GetHGlobalFromStream(ByVal hStream, 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
                    IStreamToArray = True
                End If
            End If
        End If
    End If

End Function