Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long

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


Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long

Private Const CAPTUREBLT As Long = &H40000000 ' capture layered windows also!
Private Const BI_RGB As Long = 0
Private Const DIB_RGB_COLORS As Long = 0

Private Type BitmapFileHeader
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

Private Type BitmapInfoHeader
  biSize As Long
  biWidth As Long
  biHeight As Long
  biPlanes As Integer
  biBitCount As Integer
  biCompression As Long
  biDataSize As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type

Private Type RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgbReserved As Byte
End Type

Private Type BITMAPINFO
  bmiHeader As BitmapInfoHeader
  bmiColors As RGBQUAD
End Type

' mouse cursor
Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As Long
End Type

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type PCURSORINFO
    cbSize As Long
    Flags As Long
    hCursor As Long
    ptScreenPos As POINTAPI
End Type

Private Declare Function GetCursorInfo Lib "user32.dll" (ByRef pci As PCURSORINFO) As Long
Private Declare Function GetIconInfo Lib "user32.dll" (ByVal hIcon As Long, ByRef PICONINFO As ICONINFO) As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long

' gdi+
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




Public Sub DesktopToJPG(ByVal FileName As String, Optional ByVal Quality As Long = 80, Optional IncludeMouseCursor As Boolean = False)
    
    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
        
        
    On Error Resume Next
    
'    DPI = 1
'    DPI = 1 + RegRead("HKCU\Control Panel\Desktop\PerMonitorSettings\ACI27F4BBLMTF016120_2C_07DB_E8^B94DCAF1BB48BB1AA4C409073022BEE7\DpiValue") * 0.25
'DPI = 1 + 1 * 0.25
DPI = ScreenDPI(True) / 96
    
    ' Starting position/Size of capture (full screen)
    X = 0: Y = 0
    wide = (Screen.Width / Screen.TwipsPerPixelX) * DPI
    high = (Screen.Height / Screen.TwipsPerPixelY) * DPI
    '
    
    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
    
    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



Public Function ScreenDPI(Optional ByVal Actual As Boolean) As Single
    If Actual Then
        Dim hDC As Long: hDC = GetDC(0)
        ScreenDPI = GetDeviceCaps(hDC, 118) / (Screen.Width / Screen.TwipsPerPixelX)
        ReleaseDC 0, hDC
        If ScreenDPI = 1 Then
            ScreenDPI = 1440! / Screen.TwipsPerPixelX
        Else
            ScreenDPI = ScreenDPI * 96!
        End If
    Else
        ScreenDPI = 1440! / Screen.TwipsPerPixelX
    End If
End Function