shape/image su userform

Question

Buongiorno,

ho già rispolto grazie a voi come importare su una Image di una userform un grafico.

Oggi mi servirebbe capire come importare, se si può, una image che si trova già su un foglio di lavoro.

L'ho già fatto sfruttando lo stesso metodo del grafico, ma l'immagine non è chiara come sul foglio quando creo il grafico.

Sarebbe possibile caricare direttamente l'immagine e non il grafico esportato come immagine?

Saluti

Giuseppe

Answer 1

Ciao Giuseppe.

Sfruttando il codice di Stephen Bullen, in un modulo standard, incolla il seguente codice:

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

'*

'* MODULE NAME:     Paste Picture

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

'*                  15 November 1998

'*

'* CONTACT:         ******@oaltd.co.uk

'* WEB SITE:        http://www.oaltd.co.uk

'*

'* 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

''' User-Defined Types for API Calls

'Declare a UDT to store a GUID 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

'Declare a UDT to store the bitmap information

Private Type uPicDesc

    Size As Long

    Type As Long

    hPic As Long

    hPal As Long

End Type

'''Windows API Function Declarations

'Does the clipboard contain a bitmap/metafile?

Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long

'Open the clipboard to read

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

'Get a pointer to the bitmap/metafile

Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

'Close the clipboard

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

'Convert the handle into an OLE IPicture interface.

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic 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" 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" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

'The API format types we're interested in

Const CF_BITMAP = 2

Const CF_PALETTE = 9

Const CF_ENHMETAFILE = 14

Const IMAGE_BITMAP = 0

Const LR_COPYRETURNORG = &H4

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''' Subroutine: PastePicture

'''

''' Purpose:    Get a Picture object showing whatever's on the clipboard.

'''

''' Arguments:  lXlPicType - The type of picture to create.  Can be one of:

'''                          xlPicture to create a metafile (default)

'''                          xlBitmap to create a bitmap

'''

''' Date        Developer           Action

''' --------------------------------------------------------------------------

''' 30 Oct 98   Stephen Bullen      Created

''' 15 Nov 98   Stephen Bullen      Updated to create our own copies of the clipboard images

'''

Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture

'Some pointers

Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long

'Convert the type of picture requested from the xl constant to the API constant

lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)

'Check if the clipboard contains the required format

hPicAvail = IsClipboardFormatAvailable(lPicType)

If hPicAvail <> 0 Then

    'Get access to the clipboard

    h = OpenClipboard(0&)

    If h > 0 Then

        'Get a handle to the image data

        hPtr = GetClipboardData(lPicType)

        'Create our own copy of the image on the clipboard, in the appropriate format.

        If lPicType = CF_BITMAP Then

            hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)

        Else

            hCopy = CopyEnhMetaFile(hPtr, vbNullString)

        End If

        'Release the clipboard to other programs

        h = CloseClipboard

        'If we got a handle to the image, convert it into a Picture object and return it

        If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)

    End If

End If

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''' Subroutine: CreatePicture

'''

''' Purpose:    Converts a image (and palette) handle into a Picture object.

'''

'''             Requires a reference to the "OLE Automation" type library

'''

''' Arguments:  None

'''

''' Date        Developer           Action

''' --------------------------------------------------------------------------

''' 30 Oct 98  Stephen Bullen      Created

'''

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

' IPicture requires a reference to "OLE Automation"

Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture

'OLE Picture types

Const PICTYPE_BITMAP = 1

Const PICTYPE_ENHMETAFILE = 4

' Create the Interface GUID (for the IPicture interface)

With IID_IDispatch

    .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 uPicInfo with necessary parts.

With uPicInfo

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

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

    .hPic = hPic                                                            ' Handle to image.

    .hPal = IIf(lPicType = CF_BITMAP, hPal, 0)                              ' Handle to palette (if bitmap).

End With

' Create the Picture object.

r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)

' If an error occured, show the description

If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)

' Return the new Picture object.

Set CreatePicture = IPic

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''' Subroutine: fnOLEError

'''

''' Purpose:    Gets the message text for standard OLE errors

'''

''' Arguments:  None

'''

''' Date        Developer           Action

''' --------------------------------------------------------------------------

''' 30 Oct 98   Stephen Bullen      Created

'''

Private Function fnOLEError(lErrNum 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

Const S_OK = &H0

Select Case lErrNum

Case E_ABORT

    fnOLEError = " Aborted"

Case E_ACCESSDENIED

    fnOLEError = " Access Denied"

Case E_FAIL

    fnOLEError = " General Failure"

Case E_HANDLE

    fnOLEError = " Bad/Missing Handle"

Case E_INVALIDARG

    fnOLEError = " Invalid Argument"

Case E_NOINTERFACE

    fnOLEError = " No Interface"

Case E_NOTIMPL

    fnOLEError = " Not Implemented"

Case E_OUTOFMEMORY

    fnOLEError = " Out of Memory"

Case E_POINTER

    fnOLEError = " Invalid Pointer"

Case E_UNEXPECTED

    fnOLEError = " Unknown Error"

Case S_OK

    fnOLEError = " Success!"

End Select

End Function

'<<=========

Crea una Userform con un controllo Image (Image1). Nel modulo di codice della Userform, incolla il seguente codice:

'=========>>

Option Explicit

'--------->>

Private Sub UserForm_Initialize()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim MyShape As Shape

    Set WB = ThisWorkbook

    Set SH = WB.Sheets("Foglio1")                                           '<<=== Modifica

    Set MyShape = SH.Shapes("Picture 2")                               '<<=== Modifica

    MyShape.Copy

    With Me

        .Caption = "DemoShape To Picture"

        Set .Image1.Picture = PastePicture(xlPicture)

    End With

End Sub

'<<=========

Per provare il codice, ho creato un  oggetto Shape nominato miaTabella con una tabella presa da un recente file. Potresti scaricare il mio file di prova Giuseppe20160305.xlsm a:

https://www.dropbox.com/s/rhozpfbhhgix1lj/Giuseppe20160305.xlsm?dl=0

===

Regards,

Norman

Answer 2

Eccola qui.

___________________________________________

Sub IncollaProspetto()

Dim Shp As Shape

Sheets("gif").Select

    For Each Shp In ActiveSheet.Shapes

    Shp.Delete

    Next Shp

    Sheets("Prospetto").Select

    Range("A1:AN14").Select

    Selection.Copy

    Sheets("gif").Select

    Range("A1").Select

    ActiveSheet.Pictures.Paste.Select

For Each Shp In ActiveSheet.Shapes

Range("Q1") = Shp.Name

Next Shp

End Sub

Da qui in poi o la salvo come immagine o la importo in una userform.

Questo è ciò che mi servirebbe

Grazie

Giuseppe

Answer 3

Ciao Giuseppe,

Praticamente ho una tabella dati che vorrei importare su una userform, ho registrato una macro che mi copia ed incolla questa tabella su un altro foglio sotto forma di shape. Con una routine individuo il nome della shape perchè ogni volta che copio ed incollo il numero della shape aumenta.

Possiamo vedere la tua macro?

===

Regards,

Norman

Answer 4

Ciao Norman,

grazie della immediata risposta ma io l'immagine l'ho già su un foglio excel.

Pertanto volevo sapere se fosse possibile caricare su una userform1.image1 una immagine già presente sul foglio di lavoro oppure devo fare l'export?

Se devo per forza esportarla dal foglio excel, come si esporta in formato JPG o BMP ?

Praticamente ho una tabella dati che vorrei importare su una userform, ho registrato una macro che mi copia ed incolla questa tabella su un altro foglio sotto forma di shape. Con una routine individuo il nome della shape perchè ogni volta che copio ed incollo il numero della shape aumenta.

Adesso sono arrivato anche a selezionare la shape creata ma non so ne importarla direttamente sulla userform ne tantomeno esportarla come immagine per poi caricarla sulla userform.

C'è un modo per fare una delle due azioni?

Saluti

Giuseppe

Answer 5

Ciao Giuseppe,

ho già rispolto grazie a voi come importare su una Image di una userform un grafico.

Oggi mi servirebbe capire come importare, se si può, una image che si trova già su un foglio di lavoro.

L'ho già fatto sfruttando lo stesso metodo del grafico, ma l'immagine non è chiara come sul foglio quando creo il grafico.

Sarebbe possibile caricare direttamente l'immagine e non il grafico esportato come immagine?

Prova qualcosa del genere:

Sulla Userform, inserisci un controllo Image (Image1) e nell modulo di codice della Userform, incolla il seguente codice:

'=========>>

Option Explicit

'--------->>

Private Sub UserForm_Initialize()

    Dim sPath As String

    Dim sStr As String

    Const sPercorsoImagine As String = _

              "C:\Users\NDJ\Pictures"                                         '<<=== Modifica

    Const sImagine As String = "Pippo.jpg"                                 '<<=== Modifica

    sStr = Application.PathSeparator

    If Right(sPercorsoImagine, 1) = sStr Then

        sPath = sPercorsoImagine

    Else

        sPath = sPercorsoImagine & sStr

    End If

    Me.Image1.Picture = LoadPicture(sPercorsoImagine & sImagine)

End Sub

'<<=========

===

Regards,

Norman