Excel VBA 在一定范围内调整图片大小

Question

好的，我有一个图像，第三部分软件正在将其放入 excel 文件中。为了获得所需的分辨率，它的大小必须比需要的大得多。它将始终放置在相同的位置并具有特定的大小。我需要调整它的大小。理想情况下，当 excel 文件打开时它会自动执行，但我认为任何 vba 代码最终都会在插入信息之前起作用，但如果有一个小的延迟也会很酷。或者我可以使用一个运行一些代码的按钮。下面的代码有效，但只有当图片被特别命名为 "Picture 179" 时，它才会再次出现，或者至少在计数器回收之前不会出现。

图像具体插入到单元格 A45，但它大致延伸到单元格 AZ60。

这是我得到的但不起作用的方法。

Private Sub Resize_Graph_Click()
   ActiveSheet.Shapes.Range(Array("Picture 179")).Select
   Selection.ShapeRange.Height = 104.4
   Selection.ShapeRange.Width = 486.72
End Sub

Answer 1

您仍然需要弄清楚何时调整图片大小，但下面的示例代码显示了如何具体访问图片的左上角位于给定单元格中的图片。

Option Explicit

Sub TestMe()
    Dim thePicture As Shape
    Set thePicture = GetPictureAt(Range("A45"))
    If Not thePicture Is Nothing Then
        Debug.Print "found it! (" & thePicture.Name & ")"
        With thePicture
            .Height = 75
            .Width = 75
            Debug.Print "resized to h=" & .Height & ", w=" & .Width
        End With
    Else
        Debug.Print "couldn't find the picture!"
    End If

End Sub

Private Function GetPictureAt(ByRef thisCell As Range) As Shape
    Dim thisCellTop As Long
    Dim thisCellBottom As Long
    Dim thisCellLeft As Long
    Dim thisCellRight As Long
    With thisCell
        thisCellTop = .Top
        thisCellLeft = .Left
        thisCellBottom = thisCellTop + .Height
        thisCellRight = thisCellLeft + .Width
    End With

    Dim shp As Variant
    With Sheet1
        For Each shp In .Shapes
            If shp.Type = msoPicture Then
                If (shp.Top >= thisCellTop) And (shp.Top <= thisCellBottom) Then
                    If (shp.Left >= thisCellLeft) And (shp.Left <= thisCellRight) Then
                        Set GetPictureAt = shp
                        Exit Function
                    End If
                End If
            End If
        Next shp
    End With
End Function

Answer 2

这是我的决定。

Private Sub Resize_Graph_Click()

'resize all shapes
Dim s As Shape
Dim ws As Worksheet
Set ws = ActiveSheet

For Each s In ActiveSheet.Shapes
    s.LockAspectRatio = msoFalse
    s.Width = 491.72
    s.Height = 106.56

Next s

'set header shapes and button back to original size
    ActiveSheet.Shapes.Range(Array("Company Label")).Select
    Selection.ShapeRange.Height = 43.92
    Selection.ShapeRange.Width = 131.76
    ActiveSheet.Shapes.Range(Array("Product Label")).Select
    Selection.ShapeRange.Height = 49.68
    Selection.ShapeRange.Width = 134.64
    ActiveSheet.Shapes.Range(Array("Resize_Graph")).Select
    ActiveSheet.Shapes("Resize_Graph").Height = 38.16
    ActiveSheet.Shapes("Resize_Graph").Width = 105.12
'keep button from moving after changing shape back and forth
    ActiveSheet.Shapes.Range(Array("Resize_Graph")).Select
    ActiveSheet.Shapes("Resize_Graph").Left = 380
    ActiveSheet.Shapes("Resize_Graph").Top = 5

ActiveWorkbook.Close Savechanges:=True

End Sub

Excel VBA 在一定范围内调整图片大小

Excel VBA Resize picture in a certain range

excel

vba

resize

image