Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type
''''GDI函数: 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 ''''创建一个memory DC: Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long ''''在memory中建立一个位图: Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long ''''把一个GDI对象放入DC,返回原先的那个: Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long ''''删除GDI对象: Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
''''剪贴板函数: 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
''''在内存中建立一个指向我们将要复制对象的DC: lhDC = CreateCompatibleDC(objFrom.hDC) If (lhDC <> 0) Then ''''建立一张指向将要复制对象的位图: lhBMP = CreateCompatibleBitmap(objFrom.hDC, objFrom.ScaleWidth \ Screen.TwipsPerPixelX, objFrom.ScaleHeight \ Screen.TwipsPerPixelY) If (lhBMP <> 0) Then ''''把位图选入我们刚才建立的DC中,并贮存原先在那里的老位图: lhBMPOld = SelectObject(lhDC, lhBMP)
''''我们在这里不用删除建立的位图—— ''''它现在属于剪贴板,当剪贴板变化时,Windows将为我们删除它。 End If
''''清除刚才建立的DC: DeleteObject lhDC End If End Function
为了试验这个方法,把这些代码加入窗体:
Private Sub Command1_Click() CopyEntirePicture Picture1 End Sub
Private Sub Form_Load() Dim i As Long ''''在PictureBox中画些东西: With Picture1.Font .Name = "Arial" .Bold = True .Size = 12 End With For i = 1 To 20 Picture1.ForeColor = QBColor(i Mod 15) Picture1.Print "http://www.archtide.com" Next i End Sub