内存图像保存

king2003 2008-03-12 02:18:26
http://topic.csdn.net/t/20051011/14/4319306.html
他的这个我一运行就OUT OF MEMORY,不解....
不要那种按截图键保存然后从CLIPBOARD中取数据的那种.
...全文
83 点赞 收藏 16
写回复
16 条回复
切换为时间正序
当前发帖距今超过3年,不再开放新的回复
发表回复
主要是,最近100分又容易答的问题太少啦,哇哈哈哈哈哈哈~~~~~~~~~
回复
zzyong00 2008-03-12
晕,才出不到1小时,这么多回复!
回复
zzyong00 2008-03-12
'借老马的模块用用
Dim pic1 As StdPicture
Set pic1 = CaptureScreen
SavePicture pic1, "e:\1.bmp"
'没用到控件
回复
给我这么多分做什么,我又没答对。
回复
king2003 2008-03-12
我搞定了分给你们分了吧谢谢参与
回复
king2003 2008-03-12
hBmp = SelectObject(hDCMemory, hBmpPrev)
你的为什么要加这样一句话呀
回复
king2003 2008-03-12
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 2008-03-12
我有这个代码的,但是这个你用了控件呀,我不想要这一层工作想直接SAVEPICTURE
回复
king2003 2008-03-12
哦我说错了呵不好意思
回复
服你了.....你那是"设备上下文句柄(hDC)"好不好......什么"内存句柄"!!!

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

我发的代码你也不看.

里面的CaptureWindow是干什么的?
回复
king2003 2008-03-12
其实这个和我发的上面的是一样的,只不过我一运行就出OUT OF MEMORY
回复
king2003 2008-03-12
没有你想的这么复杂吧.应该就几个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
回复
内存句柄?

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

恐怕很难了.

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

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

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

你这100分看来不好挣了.
回复
king2003 2008-03-12
我是后台操作呀不要这种形式的.我想直接通过内存句柄来保存
回复
'马大哈 收集于 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
回复
SavePicture Clipboard.GetData, "d:\0.bmp"
回复
相关推荐
发帖
VB基础类
创建于2007-09-28

7489

社区成员

VB 基础类
申请成为版主
帖子事件
创建了帖子
2008-03-12 02:18
社区公告
暂无公告