Как скопировать одно изображение в другое с помощью Excel VBA

Question

У меня есть лист, который я использую для создания спортивных карт. На моем листе 15 карточек, каждая с изображением, созданным с помощью «INSERT -> Picture» и выбирающим PNG или JPG на моем компьютере.

Однако, так как этот лист является шаблоном, используемым для многих команд, я хотел бы иметь возможность создавать некоторый код, который позволяет мне выбрать одно изображение, изменить его на новый логотип и скопировать это изображение в оставшиеся 14 одним щелчком мыши. кнопка. Я пробовал несколько разных вещей, все из некоторых вариаций, как это:

Dim setLogo As Picture
Dim logo1 As Picture
Set setLogo = Sheets("Team Cards").Images("LOGO_SET")
Set logo1 = Sheets("Team Cards").Images("LOGO1")
logo1.Picture = setLogo.Picture ' also tried UserPicture

Я гуглял вокруг, но я не могу найти код, который сделает это. Я тоже возился со свойством PictureData, но не смог заставить его работать, все они заканчивались ошибкой. Я видел некоторые вещи об удалении изображения и повторной вставке нового, который я мог бы попробовать позже, но я надеюсь, что мне просто не хватает какого-то свойства, которое делает это для меня. Можете ли вы помочь с правильным кодом?

Answer 1

Макрос ChangeLogo

• Запустите макрос и появится диалоговое окно файла.
• Найдите и выберите изображение логотипа для карточек активного листа.
• Новый логотип добавлен в коллекцию Shapes.
• Каждая фигура в Активном Листе считается:
• Если это не недавно добавленная форма логотипа и
• Если фигура является изображением, то для этого найденного изображения:
  • Форма логотипа продублирована.
  • Дубликат логотипа обновляется в соответствии со свойствами найденного изображения.
  • Затем найденное изображение будет удалено.

ChangeLogo

Option Explicit
'
' ChangeLogo: File Dialogue Prompts user for Image.
'   The selected image replaces all the images on the Active Worksheet
'
Private Const GetDirStartIn = "" ' "CurDir" (Default), "ActiveWorkbook.Path", "/Specified/Path"
Private Const ImageFileExt = "*.gif; *.jpg; *.jpeg; *.png" ' FileFilter Format
'
' More than one Shape can have the same name. Consider naming all images "Card Logo"
'    Rename: Home (tab) | Editing (section) | Find & Select | Selection Pane...
' TODO implement
' Leave Picture Blank "" to replace all on active sheet.
'Private Const BaseName = "Picture"
'Private Const FirstNumber = 1 ' Name is BaseName & " " Number
'Private Const LastNumber = 4

Public Sub ChangeLogo()
    Dim fname As String
    Dim shp As Shape
    Dim logo As Shape
    Dim l As Shape
    Dim newLogoShapeName As String
    newLogoShapeName = "newLogoShapeName_Temp_DeleteMe"

    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = " Card Logo - Select Image for Sheet"
        .ButtonName = "Select"
        If GetDirStartIn = "CurDir" Or GetDirStartIn = "" Then 'Default
            .InitialFileName = CurDir & Application.PathSeparator
        ElseIf GetDirStartIn = "ActiveWorkbook.Path" Then
            .InitialFileName = ActiveWorkbook.path & Application.PathSeparator
        Else
            .InitialFileName = GetDirStartIn & Application.PathSeparator
        End If
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Images", ImageFileExt, 1
        .Filters.Add "All files", "*.*"
        .FilterIndex = 1
        If .Show = -1 Then
            fname = .SelectedItems(1)
        Else
            End 'Exit Subroutine and Execution Call Stack
        End If
    End With
    Set logo = ActiveSheet.Shapes.AddPicture(fname, msoFalse, msoTrue, 1, 1, -1, -1)
    logo.Name = newLogoShapeName

    For Each shp In ActiveSheet.Shapes
        With shp
            If .Type = msoPicture Then
                ' More Logic based on template image shape names
                If .Name <> logo.Name Then
                    Set l = logo.Duplicate
                    l.Name = .Name
                    l.Top = .Top
                    l.Left = .Left
                    ' Deal here with letter boxing VS stretching to fit.
                    'l.LockAspectRatio = msoFalse
                    'l.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
                    'l.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue
                    l.Height = .Height
                    l.Width = .Width

                    .Delete
                End If
            End If
        End With
    Next shp
    logo.Delete
End Sub

Answer 2

Используйте copy-paste, вот так:

Cells(1, "A").Copy
Cells(2, "A").select
activesheet.paste

Answer 3

Вот кусок кода, который я использую, чтобы копировать изображения с одного листа на другой, изменяя размеры и располагая их на новом листе. wsData - исходный лист, а wsCharts - целевой лист.

  iChartCount = wsData.ChartObjects.Count()
  If Not (iChartCount > 0) Then
    MsgBox "No charts in Data sheet to copy"
  End If
  For iChart = 1 To iChartCount
    Application.StatusBar = "CopyCharts: " & iChart & " of " & iChartCount & " " & Format(iChart / iChartCount, "0%")
    wsData.ChartObjects(iChart).Activate
    Set oChart = ActiveChart
    Set oChartObject = oChart.Parent

    lngChartHeight = oChartObject.Height
    lngChartWidth = oChartObject.Width

    oChart.ChartArea.Copy

    wsCharts.Select
    wsCharts.Paste
    wsCharts.ChartObjects(iChart).Activate
    Set oChartObject = ActiveChart.Parent
    lngChartTop = Int((iChart - 1) / 2) * lngChartHeight

    oChartObject.Top = lngChartTop
    ievenodd = iChart Mod 2
    If ievenodd = 1 Then
      oChartObject.Left = 0
    Else
      oChartObject.Left = lngChartWidth
    End If

  Next iChart