کدهای زیر را داخل ماژول ذخیره کنید:

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

" GDI functions:
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
" Creates a memory DC
Declare Function CreateCompatibleDC Lib "gdi32" _
   (ByVal hDC As Long) As Long
" Creates a bitmap in memory:
Declare Function CreateCompatibleBitmap Lib "gdi32" _
   (ByVal hDC As Long, _
   ByVal nWidth As Long, ByVal nHeight As Long) As Long
" Places a GDI into DC, returning the previous one:
Declare Function Select Lib "gdi32" _
   (ByVal hDC As Long, ByVal h As Long) As Long
" Deletes a GDI :
Declare Function Delete Lib "gdi32" _
   (ByVal h As Long) As Long

" Clipboard functions:
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 ) As Boolean
Dim lhDC As Long
Dim lhBMP As Long
Dim lhBMPOld As Long
Dim lWidthPixels As Long
Dim lHeightPixels As Long

    " Create a DC compatible with the we"re copying
    " from:
    lhDC = CreateCompatibleDC(objFrom.hDC)
    If (lhDC <> 0) Then
        " Create a bitmap compatible with the we"re
        " copying from:
        lWidthPixels = objFrom.ScaleX( _
                           objFrom.ScaleWidth, _
                           objFrom.ScaleMode, _
                           vbPixels)
        lHeightPixels = objFrom.ScaleY( _
                           objFrom.ScaleHeight, _
                           objFrom.ScaleMode, _
                           vbPixels)
        lhBMP = CreateCompatibleBitmap(objFrom.hDC, _
                   lWidthPixels, lHeightPixels)
        If (lhBMP <> 0) Then
            " Select the bitmap into the DC we have created,
            " and store the old bitmap that was there:
            lhBMPOld = Select(lhDC, lhBMP)
           
            " Copy the contents of objFrom to the bitmap:
            BitBlt lhDC, 0, 0, lWidthPixels, lHeightPixels, _
                objFrom.hDC, 0, 0, SRCCOPY
           
            " Remove the bitmap from the DC:
            Select lhDC, lhBMPOld
                       
            " Now set the clipboard to the bitmap:
            OpenClipboard 0
            EmptyClipboard
            SetClipboardData CF_BITMAP, lhBMP
            CloseClipboard

            " We don"t delete the Bitmap here - it is now owned
            " by the clipboard and Windows will delete it for us
            " when the clipboard changes or the program exits.
        End If
       
        " Clear up the device context we created:
        Delete lhDC
    End If
End Function

طرز استفاده:

CopyEntirePicture Picture1

اگر برای کپی مطالب با مشکل مواجه هستید برای مشاهده مطالب از مرورگر Firefox استفاده نمایید