在两张纸之间进行图像的即时尺寸调整和调整

Question

我有问题。我想在Excel工作表之间复制图像，并立即将其调整到单元格。

到目前为止，我在1张纸上进行了调整，管理得很好

  Sub signature()
  Dim myImage As Shape
  Dim imageWidth As Double
  Dim imageHeight As Double

  Set myImage = ActiveSheet.Shapes("Picture 13")
  imageWidth = 170
  imageHeight = 65

  myImage.LockAspectRatio = msoFalse
  myImage.Width = imageWidth
  myImage.Height = imageHeight

  'x:
  myImage.Left = myImage.Left + 650

  'y:
  myImage.Top = myImage.Top - 70

  End Sub

看起来像这样：

向图像分配了ID，如下所示：

现在，我想将此图像复制到另外两张纸上，可以通过此解决方案完成：

 Sub signature_copy()
   Sheets("Sign Off Sheet").Shapes("Picture 13").Copy
   Sheets("BoQ Civils").Range("C43").PasteSpecial
   Sheets("BoQ Cabling").Range("C37").PasteSpecial

 End Sub

一切都很好，但是我收到的是相同大小的图像。

它必须装有电池。从技术上讲，通过使用上面的代码并将形状ID更改为新的副本，这是可行的。不幸的是，我无法执行此操作，因为我想使用一张图像并使其在所有工作表中即时复制并调整大小。

我应该怎么做才能达到这个目标？

Answer 1

您可以创建一个调整大小的功能

Sub Example2()
SizeToRange ActiveSheet.Pictures("Picture 13"), Range("C43:D43")
End Sub

Function SizeToRange(s, Target As Range)
s.Left = Target.Left
s.Top = Target.Top
s.Width = Target.Width
s.Height = Target.Height
End Function

Answer 2

Sheets（“ Sign Off Sheet”）。Shapes（“ Picture 13”）。Copy

Sheets（“ BoQ Civils”）。Range（“ C43”）。PasteSpecial

使用对象。处理起来会更容易]

尝试一下

Option Explicit

Sub Sample()
    Dim shpA As Shape, shpB As Shape
    Dim rng As Range

    Set shpA = Sheets("Sign Off Sheet").Shapes("Picture 13")
    shpA.Copy

    Set rng = Sheets("BoQ Civils").Range("C43")
    Sheets("BoQ Civils").Paste Destination:=rng

    Set shpB = Sheets("BoQ Civils").Shapes("Picture 13")

    With shpB
        .Top = rng.Top
        .Left = rng.Left
        .Width = rng.Width
        .Height = rng.Height
    End With
End Sub

Answer 3

您可以使用.Scaleheight方法按目标单元格的高度缩放。这将在保持单元格高度的同时保持图片的高宽比。根据图片的外观，目标单元可能比您想要的图片更宽或更窄。

Sub signature_copy()
Dim sh As Shape

    Sh1 Sheets("Sign Off Sheet").Shapes("Picture 13").copy

    Sheets("BoQ Civils").Range("C43").PasteSpecial

    Set sh = Sheets("BoQ Civils").Shapes(Sheet2.Shapes.Count)

    With sh
        .ScaleHeight Factor:=(.TopLeftCell.Height / .Height), RelativeToOriginalSize:=msoTrue
    End With

End Sub