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 Declare Function GdiplusStartup Lib "GDIPlus" (token As Long,inputbuf As GdiplusStartupInput,ByVal outputbuf As Long) 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 GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long,Bitmap As Long) As Long

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 Sub Form_Load()
Dim rFN As String
Dim ret As Boolean
rFN = getFN
Me.Hide
Me.AutoRedraw = True
Picture1.Width = Screen.Width + 30
Picture1.Height = Screen.Height + 30
BitBlt Picture1.hDC,Screen.Width + 30,Screen.Height + 30,GetDC(0),vbSrcCopy
Set Picture1.Picture = Picture1.Image
ret = PictureBoxSaveJPG(Picture1.Picture,Replace(App.Path & "\" & rFN & ".JPG","\\","\"))  '保存压缩后的图片
End
End Sub

Function getFN() As String
Dim dD As String,tT As String
dD = Replace(CStr(Date),"-",""): tT = Replace(CStr(Time),":","")
tT = Replace(tT,"下午","pm"): tT = Replace(tT,"上午","am")
getFN = Replace(dD & tT," ","")
End Function

Private Function PictureBoxSaveJPG(ByVal pict As StdPicture,ByVal filename As String,Optional ByVal quality As Byte = 80) As Boolean
 Dim tSI As GdiplusStartupInput
 Dim lRes As Long
 Dim lGDIP As Long
 Dim lBitmap As Long
  
 '初始化 GDI+
 tSI.GdiplusVersion = 1
 lRes = GdiplusStartup(lGDIP,tSI,0)
  
 If lRes = 0 Then
 '从句柄创建 GDI+ 图像
 lRes = GdipCreateBitmapFromHBITMAP(pict.Handle,lBitmap)
  
 If lRes = 0 Then
 Dim tJpgEncoder As GUID
 Dim tParams As EncoderParameters
  
 '初始化解码器的GUID标识
 CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder
  
 '设置解码器参数
 tParams.Count = 1
 With tParams.Parameter ' Quality
 '得到Quality参数的GUID标识
 CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"),.GUID
 .NumberOfValues = 1
 .type = 4
 .Value = VarPtr(quality)
 End With
  
 '保存图像
 lRes = GdipSaveImageToFile(lBitmap,StrPtr(filename),tJpgEncoder,tParams)
  
 '销毁GDI+图像
 GdipDisposeImage lBitmap
 End If
  
 '销毁 GDI+
 GdiplusShutdown lGDIP
 End If
  
 If lRes Then
 PictureBoxSaveJPG = False
 Else
 PictureBoxSaveJPG = True
 End If
End Function