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
原文地址:https://www.jb51.cc/vb/259282.html
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。