好久没发言了,今天发个话(贡献:源码→VB压缩图片) - vb吧

吧务

level 10

无聊耍耍酷楼主

最近工作忙,没有太多时间来VB吧逛,今天没有事,来贡献一点点源代码吧,这是VB压缩图片的源代码,很实用一般我们用VB截图(全屏的话至少上M),这下就不用怕了,有了这个就可以把它压缩了,经我测试(2.29M的压缩至71.4K)下面是源代码:添加picturebox,commandbuttonOption ExplicitPrivate Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As ByteEnd TypePrivate Type GdiplusStartupInput GdiplusVersion As Long DebugEventCallback As Long SuppressBackgroundThread As Long SuppressExternalCodecs As LongEnd TypePrivate Type EncoderParameter GUID As GUID NumberOfValues As Long type As Long Value As LongEnd TypePrivate Type EncoderParameters Count As Long Parameter As EncoderParameterEnd TypePrivate Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As LongPrivate Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As LongPrivate Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As LongPrivate Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As LongPrivate Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As LongPrivate Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As LongPrivate Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, Bitmap As Long) As LongPrivate Sub Command1_Click() Dim ret As Boolean Picture1.Picture = LoadPicture("C:\a.bmp") '打开要压缩的图片 ret = PictureBoxSaveJPG(Picture1, "C:\b.jpg") '保存压缩后的图片 If ret = False Then MsgBox "保存失败" End IfEnd SubPrivate 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, 0, 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 IfEnd Function

2008年01月24日 08点01分 1