如何把在PictureBox里绘制的图片复制到剪贴板??大侠救命>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

[seehill]

在网上找到的源码,不知道为什么不好用?


模块:
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

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 Const SRCCOPY = &HCC0020 ' (DWORD) dest = source

Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long '创建一个memory DC

Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long '在memory中建立一个位图：

Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long '把一个GDI对象放入DC，返回原先的那个

Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long '删除GDI对象：
Private Declare Function OpenClipboard Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "USER32" () As Long
Private Declare Function SetClipboardData Lib "USER32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "USER32" () As Long
Private Const CF_BITMAP = 2
Public Function CopyEntirePicture(ByRef objFrom As Object) As Boolean
Dim lhDC As Long
Dim lhBMP As Long
Dim lhBMPOld As Long

lhDC = CreateCompatibleDC(objFrom.hDC) '在内存中建立一个指向我们将要复制对象的DC

If (lhDC <> 0) Then
Debug.Print objFrom.ScaleWidth
Debug.Print objFrom.ScaleHeight

lhBMP = CreateCompatibleBitmap(objFrom.hDC, objFrom.ScaleWidth \ Screen.TwipsPerPixelX, objFrom.ScaleHeight \ Screen.TwipsPerPixelY) '建立一张指向将要复制对象的位图：
If (lhBMP <> 0) Then
lhBMPOld = SelectObject(lhDC, lhBMP) '把位图选入我们刚才建立的DC中，并贮存原先在那里的老位图
BitBlt lhDC, 0, 0, objFrom.ScaleWidth \ Screen.TwipsPerPixelX, objFrom.ScaleHeight \ Screen.TwipsPerPixelY, objFrom.hDC, 0, 0, SRCCOPY '把objFrom的内容复制到建立的位图里
SelectObject lhDC, lhBMPOld '恢复DC中的内容
EmptyClipboard
OpenClipboard 0
SetClipboardData CF_BITMAP, lhBMP
CloseClipboard '把位图装入剪贴板
End If
DeleteObject lhDC '清除刚才建立的DC
End If
End Function

调用:

Private Sub BtnCopyToClip_Click()
CopyEntirePicture PicRange
End Sub

调用后,剪贴板里有一个图片,但是只是特别小,而且是空白的一点
请问要使用上面的代码,对picturebox的属性有什么要求吗?
scalemode?
大侠指教
谢谢!!!!!!!!!!!!!!

[射天狼]

Clipboard.SetData Picture1.Image '将图形内容拷贝到剪贴板

[BlueBeer]

只要这么一句就行了啊
Clipboard.SetData Picture1.Image

[BlueBeer]

晕~

[uxuan]

Clipboard.SetData Picture1.Picture
'将图形内容拷贝到剪贴板中

[kmzs]

Clipboard.SetData Picture1.Image

[seehill]

To thirdapple(陨落雕.:RNPA:.) 大侠:
变量没有赋值,只复制到剪贴板1*1象素的图
完整一点的代码有吗?谢谢!!!!

[seehill]

各位谢谢,有别的控件的可以吗?比如label

[thirdapple]

Public Function CopyData(mWidth As Long, mHeight As Long, iDC As Long) As Boolean
Dim lhDC As Long, lhBitmap As Long
Dim hBMPOld As Long

lhDC = CreateCompatibleDC(0)
If lhDC <> 0 Then
lhBitmap = CreateCompatibleBitmap(GetDC(0), mWidth, mHeight)
If lhBitmap <> 0 Then
hBMPOld = SelectObject(lhDC, lhBitmap)
BitBlt lhDC, 0, 0, mWidth, mHeight, iDC, 0, 0, vbSrcCopy
SelectObject lhDC, hBMPOld
OpenClipboard 0
EmptyClipboard
SetClipboardData CF_BITMAP, lhBitmap
CloseClipboard
CopyData = True
End If
DeleteObject lhDC
End If
End Function
这是我一个类里面的代码，你赋值一下idc和长宽试试

[seehill]

或者是图像大于控件的??

[seehill]

哦,谢谢,终于解决了!结贴,是不是快了点???

[BlueBeer]

晕，我在3楼的是回复慢了。。。。

现在我声明，这题我不要分了，我楼下与我答案相同的也。。。。

[thirdapple]

ScaleMode = vbPixel
然后赋值ScaleWidth和ScaleHeight

[liujiayu10]

Clipboard.SetData Picture1.Image

[seehill]

哪位大侠再给讲讲,用API的复制到剪贴板代码有什么优点吗?既然一句就可以了,那为什么还有这么麻烦的呢?
谢谢!是菜鸟的说

[artoksxb]

哦。帮你顶一下，有分吗

[thirdapple]

可以选择复制是DIB位图还是DDB位图，关键是我的程序里面没用PictureBox控件，所以只有用API复制了：（

[seehill]

是不是可以复制任何控件上的图啊?包括form,frame什么的?

to thirdapple(陨落雕.:RNPA:.) 大侠:
能不能给讲一下长宽的赋值方法?前面的代码好像就是在长宽上面出了问题,复制过去的图的大小有问题.
谢谢了!!!!!
真的想把这里搞明白,谢谢!!!!1

[圣骑士]

除非VB程序不能实现或者实现此功能特别麻烦，采用API，否则就像此题目，用pictureClip控件就可以轻松搞定。

[Baalwhat]

应该可以的

[chenli48]

这个贴现在还可以回复吗？