内存图像保存

Question

http://topic.csdn.net/t/20051011/14/4319306.html
他的这个我一运行就OUT OF MEMORY,不解....
不要那种按截图键保存然后从CLIPBOARD中取数据的那种.

Answer 1

SavePicture Clipboard.GetData, "d:\0.bmp"

Answer 2

'马大哈 收集于 2005-8-22
'
'
Option ExplicitPrivate Type POINTAPI
    x As Long
    y As Long
End TypePrivate Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End TypePrivate Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY
End TypePrivate Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End TypePrivate Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104Private Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End TypePrivate Type PicBmp
    Size As Long
   Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End TypePrivate Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1Private 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 LongPrivate Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As LongPublic 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 FunctionPublic 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 FunctionPublic Function CaptureScreen() As Picture
Dim hWndScreen As LongDim 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使用:set picture1.picture=CaptureScreen

Answer 3

没有你想的这么复杂吧.应该就几个API的问题我不会呀
Public Sub SaveDC(Obj As CPlotFunction, FileName As String)
    Dim IID_IDispatch   As GUID
    Dim hBitmap         As Handle
    Dim hBmpPrev        As Handle
    Dim bitmap          As PictDesc
    Dim Picture         As IPicture    hBitmap = CreateCompatibleBitmap( _
        Obj.m_Drawing.DC, _
        Obj.m_Drawing.Width, _
        Obj.m_Drawing.Height _
    )
    hBmpPrev = SelectObject(Obj.m_Drawing.DC, hBitmap)
    Call Obj.Render
    hBitmap = SelectObject(Obj.m_Drawing.DC, hBmpPrev)
    
    bitmap.hImage = hBitmap
    bitmap.picType = vbPicTypeBitmap
    bitmap.cbSizeofStruct = LenB(bitmap)
    
    IID_IDispatch.Data1 = &H20400
    IID_IDispatch.Data4(0) = &HC0
    IID_IDispatch.Data4(7) = &H46
    
    Call OleCreatePictureIndirect( _
        bitmap, IID_IDispatch, 1, Picture _
    )
    
    Call SavePicture(Picture, FileName)
End Sub

Answer 4

其实这个和我发的上面的是一样的,只不过我一运行就出OUT OF MEMORY

Answer 5

服你了.....你那是"设备上下文句柄(hDC)"好不好......什么"内存句柄"!!!先把概念搞清楚再说吧!!!我发的代码你也不看.里面的CaptureWindow是干什么的?

Answer 6

Public Function CreateBitmapPicture(ByVal hBmp As Long, _
    ByVal hPal As Long) As Picture    On Error GoTo ErrorRoutineErr    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
    'Length of structure
        .Size = Len(pic)
    'Type of Picture (bitmap)
        .bitMapType = vbPicTypeBitmap
    'Handle to bitmap
        .hBmp = hBmp
    'Handle to palette (may be null)
        .hPal = hPal
    End With    'Create Picture object
    r = OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic)    'Return the new Picture object
    Set CreateBitmapPicture = IPicErrorRoutineResume:
    Exit Function
ErrorRoutineErr:
    MsgBox "Project1.Module1.CreateBitmapPicture" & Err & Error
    Resume Next
 SavePicture CreateBitmapPicture(hDCMemory, 0), App.Path & "\zhao.bmp"这代码我都有的

Answer 7

hBmp = SelectObject(hDCMemory, hBmpPrev)
你的为什么要加这样一句话呀

Answer 8

'借老马的模块用用
Dim pic1 As StdPicture
Set pic1 = CaptureScreen
SavePicture pic1, "e:\1.bmp"
'没用到控件