一段vb程序截取的图片的vb代码，请高手帮我看看!

Question

我用这个程序截取的图片用commondialog控件保存时图片大小大于1M，
谁能帮我解决下让图片保存后在100k左右MOdule1.bas文件中的代码如下：Option Explicit
Option Base 0Public Type PALETTEENTRY
   peRed As Byte
   peGreen As Byte
   peBlue As Byte
   peFlags As Byte
End TypePublic Type LOGPALETTE
   palVersion As Integer
   palNumEntries As Integer
   palPalEntry(255) As PALETTEENTRY
End TypePublic Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End TypePublic Const RASTERCAPS As Long = 38
Public Const RC_PALETTE As Long = &H100
Public Const SIZEPALETTE As Long = 104Public Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End TypePublic Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, _
         ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal _
         iCapabilitiy As Long) As Long
Public Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Long, _
         ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries _
         As PALETTEENTRY) As Long
Public Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) _
         As Long
Public Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject _
         As Long) As Long
Public Declare Function BitBlt Lib "GDI32" (ByVal hDCDest As Long, ByVal XDest As _
         Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
         ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop _
         As Long) As Long
Public Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long
Public Declare Function GetForegroundWindow Lib "USER32" () As Long
Public Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette _
         As Long, ByVal bForceBackground As Long) As Long
Public Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long
Public Declare Function GetWindowDC Lib "USER32" (ByVal hWnd As Long) As Long
Public Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Public Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As _
         RECT) As Long
Public Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As _
         Long) As Long
Public Declare Function GetDesktopWindow Lib "USER32" () As LongPublic Type PicBmp
   Size As Long
   Type As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As _
         PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal _
     LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc _
     As Long) As Picture     Dim hDCMemory As Long
     Dim hBmp As Long
     Dim hBmpPrev As Long
     Dim r As Long
     Dim hDCSrc As Long
     Dim hPal As Long
     Dim hPalPrev As Long
     Dim RasterCapsScrn As Long
     Dim HasPaletteScrn As Long
     Dim PaletteSizeScrn As Long
     Dim LogPal As LOGPALETTE     If Client Then
         hDCSrc = GetDC(hWndSrc)
     Else
         hDCSrc = GetWindowDC(hWndSrc)
     End If     hDCMemory = CreateCompatibleDC(hDCSrc)
     hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
     hBmpPrev = SelectObject(hDCMemory, hBmp)     '获得屏幕属性
     RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
     HasPaletteScrn = RasterCapsScrn And RC_PALETTE
     PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)     '如果屏幕对象有调色板则获得屏幕调色板
     If HasPaletteScrn And (PaletteSizeScrn = 256) Then
         '建立屏幕调色板的拷贝
         LogPal.palVersion = &H300
         LogPal.palNumEntries = 256
         r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
         hPal = CreatePalette(LogPal)
         '将新建立的调色板选如建立的内存绘图句柄中
         hPalPrev = SelectPalette(hDCMemory, hPal, 0)
         r = RealizePalette(hDCMemory)
     End If     '拷贝图象
     r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)     hBmp = SelectObject(hDCMemory, hBmpPrev)     If HasPaletteScrn And (PaletteSizeScrn = 256) Then
         hPal = SelectPalette(hDCMemory, hPalPrev, 0)
     End If     '释放资源
     r = DeleteDC(hDCMemory)
     r = ReleaseDC(hWndSrc, hDCSrc)     Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End FunctionPublic Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
   Dim r As Long   Dim Pic As PicBmp
   Dim IPic As IPicture
   Dim IID_IDispatch As GUID   '填充IDispatch界面
   With IID_IDispatch
       .Data1 = &H20400
       .Data4(0) = &HC0
       .Data4(7) = &H46
   End With   '填充Pic
   With Pic
       .Size = Len(Pic)          ' Pic结构长度
       .Type = vbPicTypeBitmap   ' 图象类型
       .hBmp = hBmp              ' 位图句柄
       .hPal = hPal              ' 调色板句柄
   End With   '建立Picture图象
   r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)   '返回Picture对象
   Set CreateBitmapPicture = IPic
End Functionfrom1.frm中的代码如下:Private Sub Command1_Click()
picName = Year(Now()) & Right("0" + CStr(Month(Now())), 2) & Right("0" + CStr(Day(Now())), 2) & Right("0" + CStr(Hour(Now())), 2) & Right("0" + CStr(Minute(Now())), 2) & Right("0" + CStr(Second(Now())), 2)
picName = App.Path & "\" & picName & ".jpg"
 Set Picture1.Picture = CaptureActiveWindow()
 SavePicture Picture1.Picture, picName
 Me.SetFocus
 end sub

Answer 1

其他统统不说,使用SAVEPICTURE得到的只能是位图,也就是BMP,既然是BMP,那么文件大小就不会小.你可以计算出一个大概来,假设你的显示器设置是1024*768,16位色:
1024*768*2=1572864,也就是1.5M
SAVEPICTURE并不是说你把保存文件的名字改成JPG就变成JPG格式了,它实际上还是一个BMP,不信你用ACDSEE打开看看,它会表明这个图片的格式的.
完全用VB写JPG格式转换比较麻烦,建议你看一下GDI+,可以很简单快速地转换图片格式.

Answer 2

SavePicture Picture1.Picture, picName
'保存的图片实际上是bmp格式，减小图片大小需要另外用算法转化压缩调整图片质量

Answer 3

'建一模块，加入下面代码，使用SavePic函数转换格式，SavePic函数参数可以设定图片质量大小'[名称] 把图象保存为JPG?TIFF?PNG?GIF?BMP格式Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End TypePrivate Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End TypePrivate Type EncoderParameter
    GUID As GUID
    NumberOfValues As Long
    Type As Long
    Value As Long
End TypePrivate Type EncoderParameters
    count As Long
    Parameter As EncoderParameter
End Type
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 Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As LongPublic Sub SavePic(ByVal pict As StdPicture, ByVal FileName As String, PicType As String, _
                    Optional ByVal Quality As Byte = 80, _
                    Optional ByVal TIFF_ColorDepth As Long = 24, _
                    Optional ByVal TIFF_Compression As Long = 6)   Screen.MousePointer = vbHourglass
   Dim tSI As GdiplusStartupInput
   Dim lRes As Long
   Dim lGDIP As Long
   Dim lBitmap As Long
   Dim aEncParams() As Byte
   On Error GoTo ErrHandle:
   tSI.GdiplusVersion = 1   ' 初始化 GDI+
   lRes = GdiplusStartup(lGDIP, tSI)
   If lRes = 0 Then     ' 从句柄创建 GDI+ 图像
      lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
      If lRes = 0 Then
         Dim tJpgEncoder As GUID
         Dim tParams As EncoderParameters    '初始化解码器的GUID标识
         Select Case PicType
         Case ".jpg"
            CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
            tParams.count = 1                               ' 设置解码器参数
            With tParams.Parameter ' Quality
               CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID    ' 得到Quality参数的GUID标识
               .NumberOfValues = 1
               .Type = 4
               .Value = VarPtr(Quality)
            End With
            ReDim aEncParams(1 To Len(tParams))
            Call CopyMemory(aEncParams(1), tParams, Len(tParams))
        Case ".png"
             CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
             ReDim aEncParams(1 To Len(tParams))
        Case ".gif"
             CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
             ReDim aEncParams(1 To Len(tParams))
        Case ".tiff"
             CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
             tParams.count = 2
             ReDim aEncParams(1 To Len(tParams) + Len(tParams.Parameter))
             With tParams.Parameter
                .NumberOfValues = 1
                .Type = 4
                 CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .GUID    ' 得到ColorDepth参数的GUID标识
                .Value = VarPtr(TIFF_Compression)
            End With
            Call CopyMemory(aEncParams(1), tParams, Len(tParams))
            With tParams.Parameter
                .NumberOfValues = 1
                .Type = 4
                 CLSIDFromString StrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"), .GUID    ' 得到Compression参数的GUID标识
                .Value = VarPtr(TIFF_ColorDepth)
            End With
            Call CopyMemory(aEncParams(Len(tParams) + 1), tParams.Parameter, Len(tParams.Parameter))
        Case ".bmp"                                               '可以提前写保存为BMP的代码，因为并没有用GDI+
            SavePicture pict, FileName
            Screen.MousePointer = vbDefault
            Exit Sub
        End Select
         lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, aEncParams(1))           '保存图像
         GdipDisposeImage lBitmap       ' 销毁GDI+图像
      End If
      GdiplusShutdown lGDIP              '销毁 GDI+
   End If
   Screen.MousePointer = vbDefault
   Erase aEncParams
   Exit Sub
ErrHandle:
    Screen.MousePointer = vbDefault
    MsgBox "在保存图片的过程中发生错误:" & vbCrLf & vbCrLf & "错误号:  " & Err.Number & vbCrLf & "错误描述:  " & Err.Description, vbInformation Or vbOKOnly, "错误"
End Sub

Answer 4

那个savepic函数的参数怎么传递
我用SavePic Picture1.Picture, picName提示参数不可显我用 savepic picture1.picture,"1.jpg",1 提示在保存图片的过程中发生错误  错误号: 9  错误描述: 下标越界

Answer 5

'图片类型jpg，图片压缩质量90%(压缩比率越大图片尺寸越大）
savepic picture1.picture, picName,".jpg",90