Attribute VB_Name = "ScreenCap"
'===================================================================
'=============================Mr.3amo الحقوق محفوظة لاهلها عمو=========
'===================================================================

Option Explicit
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc 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 Type POINTAPI
    x As Long
    y As Long
End Type
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Dim pt As POINTAPI
Declare Function GetCursor Lib "user32" () 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
Private Declare Function PaintDesktop Lib "user32" (ByVal hdc As Long) As Long
Private Declare Sub keybd_event Lib "user32" (ByVal bvk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

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 Const SRCCOPY = &HCC0020

Public Sub SaveJPG(ByVal pict As StdPicture, ByVal FileName As String, Optional ByVal Quality As Integer)

Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
'==================
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI)

If lRes = 0 Then
    lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
    
    If lRes = 0 Then
        Dim tJpgEncoder As guid
        Dim tParams As EncoderParameters
        '===============================
        CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
        tParams.Count = 1
        
        With tParams.Parameter
            CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .guid
            .NumberOfValues = 1
            .Type = 4
            .Value = VarPtr(Quality)
        End With
        
        lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, tParams)
        GdipDisposeImage lBitmap
    End If
    
    GdiplusShutdown lGDIP
End If

If lRes Then
    Err.Raise 5, , "Cannot save the image. GDI+ Error:" & lRes
End If

End Sub

Public Function Screenshot_DesktopWindow(RetPictureBox As PictureBox, SaveFilePath As String, Optional JPGImageQuality As Byte = 1)
Dim desktop_rect As RECT
Dim desktop_win As Long
Dim desktop_dc As Long
Dim desktop_wid As Long
Dim desktop_hgt As Long
Dim x As Long
Dim y As Long
Dim wid As Long
Dim hgt As Long

desktop_win = GetDesktopWindow()
desktop_dc = GetDC(desktop_win)
GetWindowRect desktop_win, desktop_rect
desktop_wid = desktop_rect.Right
desktop_hgt = desktop_rect.Bottom

x = 0
wid = desktop_wid
y = 0
hgt = desktop_hgt

RetPictureBox.Width = RetPictureBox.ScaleX(wid, vbPixels, vbTwips)
RetPictureBox.Height = RetPictureBox.ScaleY(hgt, vbPixels, vbTwips)

StretchBlt RetPictureBox.hdc, x, y, wid, hgt, desktop_dc, 0, 0, desktop_wid, desktop_hgt, vbSrcCopy
GetCursorPos pt
DrawIcon RetPictureBox.hdc, pt.x, pt.y, GetCursor
RetPictureBox.Picture = RetPictureBox.Image
ReleaseDC desktop_win, desktop_dc


SaveJPG RetPictureBox, SaveFilePath, JPGImageQuality
End Function
