内存图像保存

'借老马的模块用用

Dim pic1 As StdPicture

Set pic1 = CaptureScreen

SavePicture pic1, "e:\1.bmp"

'没用到控件

'马大哈 收集于 2005-8-22

'

'

Option Explicit



Private Type POINTAPI

    x As Long

    y As Long

End Type



Private Type PALETTEENTRY

    peRed As Byte

    peGreen As Byte

    peBlue As Byte

    peFlags As Byte

End Type



Private Type LOGPALETTE

    palVersion As Integer

    palNumEntries As Integer

    palPalEntry(255) As PALETTEENTRY

End Type



Private Type GUID

    Data1 As Long

    Data2 As Integer

    Data3 As Integer

    Data4(7) As Byte

End Type



Private Const RASTERCAPS As Long = 38

Private Const RC_PALETTE As Long = &H100

Private Const SIZEPALETTE As Long = 104



Private Type RECT

    left As Long

    top As Long

    right As Long

    bottom As Long

End Type



Private Type PicBmp

    Size As Long

   Type As Long

    hBmp As Long

    hPal As Long

    Reserved As Long

End Type



Private Const SM_CXSCREEN = 0

Private Const SM_CYSCREEN = 1



Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long

Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long

Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long

Private 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

Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function GetForegroundWindow Lib "user32" () As Long

Private Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long

Private Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long

Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Private Declare Function GetDesktopWindow Lib "user32" () As Long



Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long



Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture

Dim r As Long

Dim Pic As PicBmp

    ' IPicture requires a reference to "Standard OLE Types."

Dim IPic As IPicture

Dim IID_IDispatch As GUID



    ' Fill in with IDispatch Interface ID.

    With IID_IDispatch

        .Data1 = &H20400

        .Data4(0) = &HC0

        .Data4(7) = &H46

    End With



    ' Fill Pic with necessary parts.

    With Pic

        .Size = Len(Pic)    ' Length of structure.

        .Type = vbPicTypeBitmap    ' Type of Picture (bitmap).

        .hBmp = hBmp    ' Handle to bitmap.

        .hPal = hPal    ' Handle to palette (may be null).

    End With



    ' Create Picture object.

    r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)



    ' Return the new Picture object.

    Set CreateBitmapPicture = IPic

End Function



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)    ' Raster

    

    HasPaletteScrn = RasterCapsScrn And RC_PALETTE    ' Palette

    

    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)    ' Size of

    

    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 Function



Public Function CaptureScreen() As Picture

Dim hWndScreen As Long



Dim Wwidth As Long

Dim Wheight As Long



    Wwidth = GetSystemMetrics(SM_CXSCREEN)

    Wheight = GetSystemMetrics(SM_CYSCREEN)

    hWndScreen = GetDesktopWindow()

    

    Set CaptureScreen = CaptureWindow(hWndScreen, True, 0, 0, Wwidth, Wheight)

End Function