المعاينة قبل الطباعة

Private Sub CommandButton2_Click()

UserForm2.Show

End Sub

Private Sub CommandButton5_Click()

UserForm1.Hide

Application.Visible = True



End Sub

'***************************************************************************

'*

'* MODULE NAME:     Paste Picture

'* AUTHOR & DATE:   STEPHEN BULLEN, Office Automation Ltd

'*                  15 November 1998

'*

'* Revisions by JosephP for 64bit compatibility

'*

'* '* DESCRIPTION:     Creates a standard Picture object from whatever is on the clipboard.

'*                  This object can then be assigned to (for example) and Image control

'*                  on a userform.  The PastePicture function takes an optional argument of

'*                  the picture type - xlBitmap or xlPicture.

'*

'*                  The code requires a reference to the "OLE Automation" type library

'*

'*                  The code in this module has been derived from a number of sources

'*                  discovered on MSDN.

'*

'*                  To use it, just copy this module into your project, then you can use:

'*                      Set Image1.Picture = PastePicture(xlPicture)

'*                  to paste a picture of whatever is on the clipboard into a standard image control.

'*

'* PROCEDURES:

'*   PastePicture   The entry point for the routine

'*   CreatePicture  Private function to convert a bitmap or metafile handle to an OLE reference

'*   fnOLEError     Get the error text for an OLE error code

'***************************************************************************



Option Explicit

Option Compare Text

'Declare the GUID Type structure for the IPicture OLE Interface

Private Type GUID

   Data1                      As Long

   Data2                      As Integer

   Data3                      As Integer

   Data4(0 To 7)              As Byte

End Type



'The API Constants needed

Const CF_BITMAP = &H2

Const CF_ENHMETAFILE = &HE

Const CF_METAFILEPICT = &H3

Const CF_PALETTE = &H9

Const IMAGE_BITMAP = &H0

Const IMAGE_ICON = &H1

Const IMAGE_CURSOR = &H2

Const LR_COPYRETURNORG = &H4





#If VBA7 Then

   '=================================='

   ' User-Defined Types for API Calls '

   '=================================='



   'Declare the Picture Description Type structure

Private Type PICTDESC

   Size                       As Long

    Type                       As Long

   hPic                       As LongPtr     'Holds the handle to a .bmp, .emf, .ico, .wmf file

   Data1                      As LongPtr    'For a .bmp this holds the pallete handle hPal. For a .wmf this hold the xExt value.

   Data2                      As LongPtr    'Used only with a .wmf to hold the yExt value.

End Type



'==================================='

' Windows API Function Declarations '

'==================================='



'Does the clipboard contain a bitmap/metafile?

Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" _

        (ByVal wFormat As Long) As Long



'Open the clipboard to read and write data

Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" _

        (ByVal hWnd As LongPtr) As Long



'Get a pointer to the bitmap/metafile

Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" _

        (ByVal wFormat As Long) As LongPtr



'Copy data to the clipboard

Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" _

        (ByVal uFormat As Long, ByVal hData As LongPtr) As LongPtr



'Empty the clipboard

Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long



'Close the clipboard

Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long



'Convert the handle into an OLE IPicture interface.

Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" _

        (ByRef pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, _

         ByRef ppvObj As IPicture) As LongPtr



'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.

Declare PtrSafe Function CopyEnhMetaFile Lib "GDI32.dll" Alias "CopyEnhMetaFileA" _

        (ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr



'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.

Declare PtrSafe Function CopyImage Lib "user32.dll" (ByVal hImage As LongPtr, ByVal uType As Long, _

                                                     ByVal cxDesired As Long, ByVal cyDesired As Long, _

                                                     ByVal fuFlags As Long) As LongPtr





Public Function PastePicture(Optional xlPicType As Long = xlPicture) As IPicture



'Some pointers

   Dim hClip                  As Long

   Dim hCopy                  As LongPtr

   Dim hObj                   As LongPtr

   Dim hPal                   As Long

   Dim hPicAvail              As Long

   Dim PicType                As Long

   Dim RetVal                 As Long



   'Convert the Excel picture type constant to the correct API constant

   PicType = IIf(xlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)



   'Check if the clipboard contains the required format

   hPicAvail = IsClipboardFormatAvailable(PicType)



   If hPicAvail <> 0 Then

      'Get access to the saj clipboard

      hClip = OpenClipboard(0&)



      If hClip > 0 Then

         'Get a handle to the saj object

         hObj = GetClipboardData(PicType)



         'Create a copy of the saj clipboard image in the appropriate format.

         If PicType = CF_BITMAP Then

            hCopy = CopyImage(hObj, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)

         Else

            hCopy = CopyEnhMetaFile(hObj, vbNullString)

         End If



         'Release the saj clipboard to other programs

         RetVal = CloseClipboard



         'If there is a handle to the image, convert it into a Picture object and return it

         If hObj <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, PicType)

      End If

   End If



End Function



Private Function CreatePicture(ByVal hPic As LongPtr, ByVal hPal As LongPtr, ByVal PicType) As IPicture



'saj IPicture requires a reference to "OLE Automation"

   Dim Ref_ID                 As GUID

   Dim IPic                   As IPicture

   Dim PicInfo                As PICTDESC

   Dim RetVal                 As LongPtr



   'OLE Picture types

   Const PICTYPE_UNINITIALIZED = -1

   Const PICTYPE_NONE = 0

   Const PICTYPE_BITMAP = 1

   Const PICTYPE_METAFILE = 2

   Const PICTYPE_ICON = 3

   Const PICTYPE_ENHMETAFILE = 4



   'Create a UDT to hold the reference to the interface ID (riid).

   'IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}

   'StdPicture GUID {0BE35204-8F91-11CE-9DE3-00AA004BB851}

   With Ref_ID

      .Data1 = &H7BF80980

      .Data2 = &HBF32

      .Data3 = &H101A

      .Data4(0) = &H8B

      .Data4(1) = &HBB

      .Data4(2) = &H0

      .Data4(3) = &HAA

      .Data4(4) = &H0

      .Data4(5) = &H30

      .Data4(6) = &HC

      .Data4(7) = &HAB

   End With



   'Fill PicInfo structure

   With PicInfo

      .Size = Len(PicInfo)                                                    ' Length of structure.

      .Type = IIf(PicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)   ' Type of Picture

      .hPic = hPic                                                            ' Handle to image.

      .Data1 = IIf(PicType = CF_BITMAP, hPal, 0&)                             ' Handle to palette (if bitmap).

      .Data2 = 0&

   End With



   'Create the Picture object.

   RetVal = OleCreatePictureIndirect(PicInfo, Ref_ID, True, IPic)



   'Check if an error ocurred

   If RetVal <> 0 Then

      MsgBox "Create Picture Failed - " & GetErrMsg(RetVal)

      Set IPic = Nothing

      Exit Function

   End If



   'Return the new Picture object.

   Set CreatePicture = IPic



End Function

Private Function GetErrMsg(ErrNum As LongPtr) As String



'OLECreatePictureIndirect return values

   Const E_ABORT = &H80004004

   Const E_ACCESSDENIED = &H80070005

   Const E_FAIL = &H80004005

   Const E_HANDLE = &H80070006

   Const E_INVALIDARG = &H80070057

   Const E_NOINTERFACE = &H80004002

   Const E_NOTIMPL = &H80004001

   Const E_OUTOFMEMORY = &H8007000E

   Const E_POINTER = &H80004003

   Const E_UNEXPECTED = &H8000FFFF



   Select Case ErrNum

   Case E_ABORT

      GetErrMsg = " Aborted"

   Case E_ACCESSDENIED

      GetErrMsg = " Access Denied"

   Case E_FAIL

      GetErrMsg = " General Failure"

   Case E_HANDLE

      GetErrMsg = " Bad/Missing Handle"

   Case E_INVALIDARG

      GetErrMsg = " Invalid Argument"

   Case E_NOINTERFACE

      GetErrMsg = " No Interface"

   Case E_NOTIMPL

      GetErrMsg = " Not Implemented"

   Case E_OUTOFMEMORY

      GetErrMsg = " Out of Memory"

   Case E_POINTER

      GetErrMsg = " Invalid Pointer"

   Case E_UNEXPECTED

      GetErrMsg = " Unknown Error"

   End Select



End Function



#Else

   '=================================='

   ' User-Defined Types for API Calls '

   '=================================='



   'Declare the Picture Description Type structure

Private Type PICTDESC

    Size                       As Long

    Type                       As Long

    hPic                       As Long        'Holds the handle to a .bmp, .emf, .ico, .wmf file

    Data1                      As Long       'For a .bmp this holds the pallete handle hPal. For a .wmf this hold the xExt value.

    Data2                      As Long       'Used only with a .wmf to hold the yExt value.

End Type



'==================================='

' Windows API Function Declarations '

'==================================='



'Does the clipboard contain a bitmap/metafile?

Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" _

                                                    (ByVal wFormat As Integer) As Long



'Open the clipboard to read and write data

Private Declare Function OpenClipboard Lib "user32.dll" _

                                       (ByVal hWnd As Long) As Long



'Get a pointer to the bitmap/metafile

Private Declare Function GetClipboardData Lib "user32.dll" _

                                          (ByVal wFormat As Integer) As Long



'Copy data to the clipboard

Private Declare Function SetClipboardData Lib "user32.dll" _

                                          (ByVal uFormat As Long, ByVal hData As Long) As Long



'Empty the clipboard

Private Declare Function EmptyClipboard Lib "user32.dll" () As Long



'Close the clipboard

Private Declare Function CloseClipboard Lib "user32.dll" () As Long



'Convert the handle into an OLE IPicture interface.

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _

                                                  (ByRef pPictDesc As PICTDESC, ByRef riid As GUID, _

                                                   ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long



'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.

Declare Function CopyEnhMetaFile Lib "GDI32.dll" Alias "CopyEnhMetaFileA" _

                                 (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long



'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.

Declare Function CopyImage Lib "user32.dll" (ByVal hImage As Long, _

                                             ByVal uType As Long, ByVal cxDesired As Long, _

                                             ByVal cyDesired As Long, ByVal fuFlags As Long) As Long



Public Function PastePicture(Optional xlPicType As Long = xlPicture) As IPicture



'Some pointers

   Dim hClip                  As Long

   Dim hCopy                  As Long

   Dim hObj                   As Long

   Dim hPal                   As Long

   Dim hPicAvail              As Long

   Dim PicType                As Long

   Dim RetVal                 As Long



   'Convert the Excel picture type constant to the correct API constant

   PicType = IIf(xlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)



   'Check if the clipboard contains the required format

   hPicAvail = IsClipboardFormatAvailable(PicType)



   If hPicAvail <> 0 Then

      'Get access to the clipboard

      hClip = OpenClipboard(0&)



      If hClip > 0 Then

         'Get a handle to the object

         hObj = GetClipboardData(PicType)



         'Create a copy of the clipboard image in the appropriate format.

         If PicType = CF_BITMAP Then

            hCopy = CopyImage(hObj, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)

         Else

            hCopy = CopyEnhMetaFile(hObj, vbNullString)

         End If



         'Release the clipboard to other programs

         RetVal = CloseClipboard



         'If there is a handle to the image, convert it into a Picture object and return it

         If hObj <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, PicType)

      End If

   End If



End Function



Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal PicType) As IPicture



'saj IPicture requires a reference to "OLE Automation"

   Dim Ref_ID                 As GUID

   Dim IPic                   As IPicture

   Dim PicInfo                As PICTDESC

   Dim RetVal                 As Long



   'OLE Picture types

   Const PICTYPE_UNINITIALIZED = -1

   Const PICTYPE_NONE = 0

   Const PICTYPE_BITMAP = 1

   Const PICTYPE_METAFILE = 2

   Const PICTYPE_ICON = 3

   Const PICTYPE_ENHMETAFILE = 4



   'Create a UDT to hold the reference to the interface ID (riid).

   'IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}

   'StdPicture GUID {0BE35204-8F91-11CE-9DE3-00AA004BB851}

   With Ref_ID

      .Data1 = &H7BF80980

      .Data2 = &HBF32

      .Data3 = &H101A

      .Data4(0) = &H8B

      .Data4(1) = &HBB

      .Data4(2) = &H0

      .Data4(3) = &HAA

      .Data4(4) = &H0

      .Data4(5) = &H30

      .Data4(6) = &HC

      .Data4(7) = &HAB

   End With



   'Fill PicInfo structure

   With PicInfo

      .Size = Len(PicInfo)                                                    ' Length of structure.

      .Type = IIf(PicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)   ' Type of Picture

      .hPic = hPic                                                            ' Handle to image.

      .Data1 = IIf(PicType = CF_BITMAP, hPal, 0&)                             ' Handle to palette (if bitmap).

      .Data2 = 0&

   End With



   'Create the Picture object.

   RetVal = OleCreatePictureIndirect(PicInfo, Ref_ID, True, IPic)



   'Check if an error ocurred

   If RetVal <> 0 Then

      MsgBox "Create Picture Failed - " & GetErrMsg(RetVal)

      Set IPic = Nothing

      Exit Function

   End If



   'Return the new Picture object.

   Set CreatePicture = IPic



End Function



Private Function GetErrMsg(ErrNum As Long) As String



'OLECreatePictureIndirect return values

   Const E_ABORT = &H80004004

   Const E_ACCESSDENIED = &H80070005

   Const E_FAIL = &H80004005

   Const E_HANDLE = &H80070006

   Const E_INVALIDARG = &H80070057

   Const E_NOINTERFACE = &H80004002

   Const E_NOTIMPL = &H80004001

   Const E_OUTOFMEMORY = &H8007000E

   Const E_POINTER = &H80004003

   Const E_UNEXPECTED = &H8000FFFF



   Select Case ErrNum

   Case E_ABORT

      GetErrMsg = " Aborted"

   Case E_ACCESSDENIED

      GetErrMsg = " Access Denied"

   Case E_FAIL

      GetErrMsg = " General Failure"

   Case E_HANDLE

      GetErrMsg = " Bad/Missing Handle"

   Case E_INVALIDARG

      GetErrMsg = " Invalid Argument"

   Case E_NOINTERFACE

      GetErrMsg = " No Interface"

   Case E_NOTIMPL

      GetErrMsg = " Not Implemented"

   Case E_OUTOFMEMORY

      GetErrMsg = " Out of Memory"

   Case E_POINTER

      GetErrMsg = " Invalid Pointer"

   Case E_UNEXPECTED

      GetErrMsg = " Unknown Error"

   End Select



End Function



#End If

Sub زر1_انقر()

Application.Visible = False

UserForm1.Show

    

    

End Sub