excel - Automate copy chart from sheet and paste in userform label.picture - Stack Overflow

admin管理员组

文章数量:1401469

Manually I can copy a chart from a sheet and paste it in a label.picture property (userform). Doing so I do not need to save the image and load it.

Is there a way to automate this with VBA code?

Manually I can copy a chart from a sheet and paste it in a label.picture property (userform). Doing so I do not need to save the image and load it.

Is there a way to automate this with VBA code?

• excel
• vba

Share Improve this question Follow edited Mar 25 at 9:28 HarriersArmy 544 bronze badges asked Mar 25 at 8:45 RyanRyan 3111 silver badge99 bronze badges

Add a comment  | 

1 Answer 1

Sorted by: Reset to default 0

You can place the chart into the Picture property of a label control (lets call it Label1) on your UserForm by leveraging the clipboard. I've slightly edited and adapted the solution below from here.

Place the following in a new standard module (Module1):

Option Explicit

Public Enum vbaPictureFormat
  vbabitmap = 2
  vbaPicture = -4147
End Enum

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Private Type uPicDesc
  Size As Long
  Type As Long
  hPic As LongPtr
  hPal As LongPtr
End Type

#If VBA7 Then
  Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
  Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
  Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
  Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
  Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (ByRef lpPictDesc As uPicDesc, ByRef riid As GUID, ByVal fPictureOwnsHandle As Long, ByRef IPic As IPicture) As Long
  Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
  Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
#Else
  Private Enum LongPtr
  [_]
  End Enum
  Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
  Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
  Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
  Private Declare Function CloseClipboard Lib "user32" () As Long
  Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (ByRef lpPictDesc As uPicDesc, ByRef riid As GUID, ByVal fPictureOwnsHandle As Long, ByRef IPic As IPicture) As Long
  Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
  Private Declare Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
#End If

Private Const CF_BITMAP             As Long = 2
Private Const CF_PALETTE            As Long = 9
Private Const CF_ENHMETAFILE        As Long = 14
Private Const IMAGE_BITMAP          As Long = 0
Private Const LR_COPYRETURNORG      As Long = &H4

Public Function PastePicture(Optional ByVal SelectedPictureType As vbaPictureFormat = vbabitmap) As IPicture
  Dim hPicAvail As LongPtr, hPtr As LongPtr, hPal As LongPtr, hCopy As LongPtr, Result As Long, lPicType As Long
  lPicType = IIf(SelectedPictureType = vbabitmap, CF_BITMAP, CF_ENHMETAFILE)
  hPicAvail = IsClipboardFormatAvailable(lPicType)
  If hPicAvail <> 0 Then
    OpenClipboard (0&)
    hPtr = GetClipboardData(lPicType)
    If lPicType = CF_BITMAP Then
      hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    Else
      hCopy = CopyEnhMetaFile(hPtr, vbNullString)
    End If
    Result = CloseClipboard
    If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, lPicType)
  End If
End Function

Private Function CreatePicture(ByVal hPic As LongPtr, Optional ByVal lPicType) As IPicture
  Dim r As Long, uPicinfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
  Const PICTYPE_BITMAP = 1
  Const PICTYPE_ENHMETAFILE = 4
  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
  With uPicinfo
    .Size = LenB(uPicinfo)
    .Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
    .hPic = hPic
    .hPal = 0
  End With
  r = OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, IPic)
  If r <> 0 Then Debug.Print "CreatePicture: " & r
  Set CreatePicture = IPic
End Function

Put the following code in your UserForm with the label control (Label1):

Private Sub Label1_Click()
  Dim ChartPicture As Object
  Set ChartPicture = ActiveSheet.Shapes(1)
  ChartPicture.CopyPicture xlScreen, xlBitmap
  Set Me.Label1.Picture = PastePicture
End Sub

When you click the label, it will look to find the chart on your ActiveSheet. It assumes that the chart is the first 'shape' on your ActiveSheet. It is entirely possible that it is not, though, so you will need to adjust the code accordingly. For example, if the chart you want to copy is the secnod shape on worksheet "Profit", you will need to adjust the key line of code to:

  Set ChartPicture = ActiveWorkbook.Sheets("Profit").Shapes(2)

and so on. Let me know if you have any problems with the above.

本文标签： excelAutomate copy chart from sheet and paste in userform labelpictureStack Overflow