内存图像保存

[king2003]

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

[用户 昵称]

SavePicture Clipboard.GetData, "d:\0.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

使用:

set picture1.picture=CaptureScreen

[king2003]

我是后台操作呀不要这种形式的.我想直接通过内存句柄来保存

[嗷嗷叫的老马]

内存句柄?

你要从一段内存里面分析出图象再还原为位图?

恐怕很难了.

先要知道那块内存里面有什么格式的图象,然后再分析其格式,并转换为位图~~

还有,搜索内存也是一个很麻烦的过程.

并且,内存里面的图象也应该不是完整的文件格式,你要有一套算法来知道某段内存是不是一副图象.

你这100分看来不好挣了.

[king2003]

没有你想的这么复杂吧.应该就几个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

[king2003]

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

[嗷嗷叫的老马]

服你了.....你那是"设备上下文句柄(hDC)"好不好......什么"内存句柄"!!!

先把概念搞清楚再说吧!!!

我发的代码你也不看.

里面的CaptureWindow是干什么的?

[king2003]

哦我说错了呵不好意思

[king2003]

我有这个代码的，但是这个你用了控件呀，我不想要这一层工作想直接ＳＡＶＥＰＩＣＴＵＲＥ

[king2003]

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 = IPic

ErrorRoutineResume:
Exit Function
ErrorRoutineErr:
MsgBox "Project1.Module1.CreateBitmapPicture" & Err & Error
Resume Next


SavePicture CreateBitmapPicture(hDCMemory, 0), App.Path & "\zhao.bmp"

这代码我都有的

[king2003]

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

[king2003]

我搞定了分给你们分了吧谢谢参与

[用户 昵称]

给我这么多分做什么，我又没答对。

[zzyong00]

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

[zzyong00]

晕，才出不到1小时，这么多回复!

[嗷嗷叫的老马]

主要是,最近100分又容易答的问题太少啦,哇哈哈哈哈哈哈~~~~~~~~~