CreateCompatibleBitmap的问题

[AmyLin_2001]

为什么调用多次之后就失败了？

[zyl910]

你内存够不够？

[xianyu20001015]

估计是没释放资源，好好看看SDK吧

[AmyLin_2001]

代码如下：

'捕捉整个屏幕图象 hDCD:目标HDC DW:目标宽度，DH:目标高度
Private Sub CaptureScreen(hDCD As Long, DW As Long, DH As Long)
Dim hWndScreen As Long
Dim hDCSrc As Long, hDCMemory As Long, hBmp As Long, hBmpPrev As Long
Dim w As Long, h As Long
Dim retval As Long
'获得桌面的窗口句柄
hWndScreen = GetDesktopWindow()
hDCSrc = GetWindowDC(hWndScreen)
w = Screen.Width / 15
h = Screen.Height / 15

'为了贴一个鼠标上去，我们不得不将桌面窗口的内容复制到一个新的设备场景中,但是这个操作降低了效率
'如果直接在hDCSrc上贴，将导致整个屏幕乱七八糟的都是鼠标
hDCMemory = CreateCompatibleDC(hDCSrc)
hBmp = CreateCompatibleBitmap(hDCSrc, w, h)
hBmpPrev = SelectObject(hDCMemory, hBmp)
retval = BitBlt(hDCMemory, 0, 0, w, h, hDCSrc, 0, 0, vbSrcCopy)
PaintCursor hDCMemory
retval = StretchBlt(Picture2.hDC, 0, 0, DW, DH, hDCMemory, w, 0, -w, h, vbSrcCopy)

'Debug.Print retval
'释放资源
retval = ReleaseDC(hWndScreen, hDCSrc)
retval = DeleteDC(hDCMemory)
retval = DeleteObject(hBmp)
retval = DeleteObject(hBmpPrev)
' Debug.Print retval
End Sub
要做的是一个桌面镜像

[zyl910]

资源释放资源代码有问题！

1.当位图没有被选入DC时才能被释放
2.当DC为初始位图时才能被释放

所以你写的资源释放代码根本没有释放资源

[zyl910]

'释放资源
Call ReleaseDC(hWndScreen, hDCSrc)
Call SelectObject(hDCMemory, hBmpPrev) '当DC为初始位图时才能被释放
Call DeleteDC(hDCMemory)
Call DeleteObject(hBmp) '当位图没有被选入DC时才能被释放

[AmyLin_2001]

Option Explicit
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
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 Integer, ByVal nHeight As Integer) As Integer
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Integer
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function GetCursor Lib "user32" () As Long
Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long

Const DI_MASK = &H1
Const DI_IMAGE = &H2
Const DI_NORMAL = DI_MASK Or DI_IMAGE

Dim flag As Boolean
Private Sub Form_Load()
Picture2.Width = Screen.Width
Picture2.Height = Screen.Height
Picture2.Top = 0
Picture2.Left = 0
Form1.Width = Screen.Width
Form1.Height = Screen.Height
Picture1.Width = Screen.Width
Picture1.Height = Screen.Height
flag = False
End Sub


'捕捉整个屏幕图象 hDCD:目标HDC DW:目标宽度，DH:目标高度
Private Sub CaptureScreen(hDCD As Long, DW As Long, DH As Long)
Dim hWndScreen As Long
Dim hDCSrc As Long, hDCMemory As Long, hBmp As Long, hBmpPrev As Long
Dim w As Long, h As Long
Dim retval As Long
'获得桌面的窗口句柄
hWndScreen = GetDesktopWindow()
hDCSrc = GetWindowDC(hWndScreen)
w = Screen.Width / 15
h = Screen.Height / 15

'为了贴一个鼠标上去，我们不得不将桌面窗口的内容复制到一个新的设备场景中,但是这个操作降低了效率
'如果直接在hDCSrc上贴，将导致整个屏幕乱七八糟的都是鼠标
hDCMemory = CreateCompatibleDC(hDCSrc)
hBmp = CreateCompatibleBitmap(hDCSrc, w, h)
hBmpPrev = SelectObject(hDCMemory, hBmp)
retval = BitBlt(hDCMemory, 0, 0, w, h, hDCSrc, 0, 0, vbSrcCopy)
PaintCursor hDCMemory
retval = StretchBlt(Picture2.hDC, 0, 0, DW, DH, hDCMemory, w, 0, -w, h, vbSrcCopy)


'释放资源
retval = DestroyCursor(hBmp)
Call ReleaseDC(hWndScreen, hDCSrc)
Call SelectObject(hDCMemory, hBmpPrev) '当DC为初始位图时才能被释放
Call SelectObject(hDCMemory, hBmp)
Call DeleteDC(hDCMemory)
Call DeleteObject(hBmp) '当位图没有被选入DC时才能被释放
Call DeleteObject(hBmpPrev)

' Debug.Print retval
End Sub

Private Sub PaintCursor(hDCD As Long)
Dim CursorPos As POINTAPI
Dim CursorPic As StdPicture
Dim hwndCursor As Long
GetCursorPos CursorPos
hwndCursor = GetCursor
DrawIconEx hDCD, CursorPos.x, CursorPos.y, hwndCursor, 0, 0, 0, 0, DI_NORMAL
'StretchBlt Picture2.hdc, 0, CursorPos.Y, 32, 32, Picture3.hdc, 32, 0, -32, 32, vbSrcCopy
End Sub


Private Sub Timer1_Timer()
CaptureScreen Picture2.hDC, Picture2.Width / 15, Picture2.Height / 15
End Sub
上面是我所有的代码

[AmyLin_2001]

我后来又加了一句 retval = DestroyCursor(hBmp)

你有QQ OR ＭＳＮ吗？

[AmyLin_2001]

我试了还是不行，这是为什么？
用了如下的代码？

'捕捉整个屏幕图象 hDCD:目标HDC DW:目标宽度，DH:目标高度
Private Sub CaptureScreen(hDCD As Long, DW As Long, DH As Long)
Dim hWndScreen As Long
Dim hDCSrc As Long, hDCMemory As Long, hBmp As Long, hBmpPrev As Long
Dim w As Long, h As Long
Dim retval As Long
'获得桌面的窗口句柄
hWndScreen = GetDesktopWindow()
hDCSrc = GetWindowDC(hWndScreen)
w = Screen.Width / 15
h = Screen.Height / 15

'为了贴一个鼠标上去，我们不得不将桌面窗口的内容复制到一个新的设备场景中,但是这个操作降低了效率
'如果直接在hDCSrc上贴，将导致整个屏幕乱七八糟的都是鼠标
hDCMemory = CreateCompatibleDC(hDCSrc)
hBmp = CreateCompatibleBitmap(hDCSrc, w, h)
hBmpPrev = SelectObject(hDCMemory, hBmp)
retval = BitBlt(hDCMemory, 0, 0, w, h, hDCSrc, 0, 0, vbSrcCopy)
PaintCursor hDCMemory
retval = StretchBlt(Picture2.hDC, 0, 0, DW, DH, hDCMemory, w, 0, -w, h, vbSrcCopy)


'释放资源
Call ReleaseDC(hWndScreen, hDCSrc)
Call SelectObject(hDCMemory, hBmpPrev) '当DC为初始位图时才能被释放
Call DeleteDC(hDCMemory)
Call DeleteObject(hBmp) '当位图没有被选入DC时才能被释放


' Debug.Print retval
End Sub

[zyl910]

基本上你的代码没有问题
看看是不是其他地方的原因


Private Sub CaptureScreen(hDCD As Long, DW As Long, DH As Long)
……
'retval = StretchBlt(Picture2.hDC, 0, 0, DW, DH, hDCMemory, w, 0, -w, h, vbSrcCopy)
retval = StretchBlt(hDCD, 0, 0, DW, DH, hDCMemory, w, 0, -w, h, vbSrcCopy)
……