//摘自http://topic.csdn.net/t/20030317/00/1538596.html  作者zyl910

Private   Declare      GetDIBits   Lib   "gdi32 "   (ByVal   hDC   As   Long,   ByVal   hBitMap   As   Long,   ByVal   nStartScan   As   Long,   ByVal   nNumScans   As   Long,   lpBits   As   Any,   lpBI   As   BITMAPINFOHEADER,   ByVal   wUsage   As   Long)   As   Long
Private   Const   DIB_RGB_COLORS   =   0
Private   Type   BITMAPFILEHEADER
                bfType(0   To   1)   As   Byte
                bfSize   As   Long
                bfReserved1   As   Integer
                bfReserved2   As   Integer
                bfOffBits   As   Long
End   Type
Private   Type   BITMAPINFOHEADER
                biSize   As   Long
                biWidth   As   Long
                biHeight   As   Long
                biPlanes   As   Integer
                biBitCount   As   Integer
                biCompression   As   Long
                biSizeImage   As   Long
                biXPelsPerMeter   As   Long
                biYPelsPerMeter   As   Long
                biClrUsed   As   Long
                biClrImportant   As   Long
End   Type

Private   Declare      GetCurrentObject   Lib   "gdi32 "   (ByVal   hDC   As   Long,   ByVal   uObjectType   As   Long)   As   Long
Private   Const   OBJ_BITMAP   =   7

Private   Declare      GetObject   Lib   "gdi32 "   Alias   "GetObjectA "   (ByVal   hObject   As   Long,   ByVal   nCount   As   Long,   lpObject   As   Any)   As   Long
Private   Type   BITMAP
                bmType   As   Long
                bmWidth   As   Long
                bmHeight   As   Long
                bmWidthBytes   As   Long
                bmPlanes   As   Integer
                bmBitsPixel   As   Integer
                bmBits   As   Long
End   Type

Public      SaveBMP(ByVal   hDC   As   Long,   FileName   As   String)   As   Boolean
        Dim   hBitMap   As   Long
        hBitMap   =   GetCurrentObject(hDC,   OBJ_BITMAP)   '取得位图
        If   hBitMap   =   0   Then   Exit    
       
        Dim   bm   As   BITMAP
        If   GetObject(hBitMap,   Len(bm),   bm)   =   0   Then   Exit      '得到位图信息
       
        Dim   bmih   As   BITMAPINFOHEADER
        bmih.biSize   =   Len(bmih)
        bmih.biWidth   =   bm.bmWidth
        bmih.biHeight   =   bm.bmHeight
        bmih.biBitCount   =   24
        bmih.biPlanes   =   1
        bmih.biSizeImage   =   ((bmih.biWidth   *   3   +   3)   And   &H7FFFFFFC)   *   bmih.biHeight   '计算大小
       
        ReDim   MapData(1   To   bmih.biSizeImage)   As   Byte
        If   GetDIBits(hDC,   hBitMap,   0,   bmih.biHeight,   MapData(1),   bmih,   DIB_RGB_COLORS)   =   0   Then   Exit      '取得位图数据
       
        Dim   hF   As   Integer
        hF   =   FreeFile(1)
       
        On   Error   Resume   Next
        Open   FileName   For   Binary   As   hF
        If   Err.Number   Then   hF   =   -1
        On   Error   GoTo   0
        If   hF   =   -1   Then   Exit    
       
        Dim   bmfh   As   BITMAPFILEHEADER
        bmfh.bfType(0)   =   Asc( "B ")
        bmfh.bfType(1)   =   Asc( "M ")
        bmfh.bfOffBits   =   Len(bmfh)   +   Len(bmih)
        Put   hF,   ,   bmfh         
        Put   hF,   ,   bmih         
        Put   hF,   ,   MapData         
        Close   hF         
        SaveBMP   =   True        
End    


Private   Sub   Picture1_Click()
        SaveBMP   Picture1.hDC,   "c:\Debug.bmp "        
End   Sub