☰

如何使用 Excel VBA 将一个图像复制到另一个图像

tag-icon • tag-icon microsoft-excel worksheet-function vba
如何使用 Excel VBA 将一个图像复制到另一个图像

我有一张用来制作运动卡片的表格。我的表格中有 15 张卡片，每张卡片上都有一张图片，这些图片是通过“插入 -> 图片”并从我的电脑中选择 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 属性，但无法让它工作，它们都以抛出错误而告终。我看到了一些关于删除图像并重新插入新图像的内容，我可能会尝试一下，但我希望我只是缺少一些可以为我做到这一点的属性。你能帮我提供正确的代码吗？

答案1

ChangeLogo 宏

  • 运行宏后会出现文件对话框。
  • 浏览并选择活动工作表卡片的徽标图像。
  • 新的标志被添加到Shapes系列中。
  • 活动工作表中的每个形状都被视为：
  • 如果不是新添加的徽标形状和
  • 如果形状是图像，那么对于找到的这个图像：
    • 徽标形状重复。
    • 重复的徽标将使用找到的图像的属性进行更新。
    • 然后删除找到的图像。

更改标志

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

答案2

使用复制粘贴，如下所示：

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

答案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

相关内容