vb 压缩保存图片？

想把剪贴板中的图片以压缩的tif保存。。别的格式也可以。黑白的也行。只要压起来文件小。需要怎样的代码？

补充：偶想要黑白的tif的。。

答案：
以下是我在网上找到的代码！你看一下
具体地址是：http://tieba.zhaoxi.net/f?kz=314561243

添加picturebox,commandbutton 

Option Explicit 
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 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 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 If 
End Sub 

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, 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 If 
End Function 
 
 
 

上一个：vb 代码 求翻译
下一个：VB 怎样实现圆角窗体？