导入图片并再次单击即可缩小/扩大答案

【问题标题】：Importing a picture and being able to shrink/expand with another click导入图片并再次单击即可缩小/扩大
【发布时间】：2020-02-06 16:19:24
【问题描述】：

我正在尝试使用宏在 Excel 工作表中导入图片，但我希望将图片压缩得较小。导入后我希望能够点击图片放大，再次点击缩小。我找到了以下两个宏，但我是 VBA 的新手，在组合它们时遇到了麻烦。提前致谢

Sub CompressPicture()
Dim fName As String
Dim pic As Picture
Dim r As Range

fName = Application.GetOpenFilename( _
        FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
        Title:="Please select an image...")
If fName = "False" Then Exit Sub

Set r = ActiveCell
Set pic = Worksheets("Sheet1").Pictures.Insert(fName)

With pic
    .ShapeRange.LockAspectRatio = msoFalse
    .Left = r.Left
    .Top = r.Top
    .Width = r.Width
    .Height = r.Height
    .Select
End With

If TypeName(Selection) = "Picture" Then
    Application.SendKeys "%a~"
    Application.CommandBars.ExecuteMso "PicturesCompress"
End If
End Sub

Sub Picture2_Click()
Dim shp As Shape
    Dim big As Single, small As Single
    Dim shpDouH As Double, shpDouOriH As Double
    big = 5
    small = 1
    On Error Resume Next
    Set shp = ActiveSheet.Shapes(Application.Caller)
    With shp
        shpDouH = .Height
        .ScaleHeight 1, msoTrue, msoScaleFromTopLeft
        shpDouOriH = .Height

        If Round(shpDouH / shpDouOriH, 2) = big Then
            .ScaleHeight small, msoTrue, msoScaleFromTopLeft
            .ScaleWidth small, msoTrue, msoScaleFromTopLeft
            .ZOrder msoSendToBack
        Else
            .ScaleHeight big, msoTrue, msoScaleFromTopLeft
            .ScaleWidth big, msoTrue, msoScaleFromTopLeft
            .ZOrder msoBringToFront
        End If
    End With
End Sub

【问题讨论】：

标签： excel vba

【解决方案1】：

你可以这样试试。

将单个文件夹中的多张图像导入 Excel 中的单元格。

Sub InsertPics()
Dim fPath As String, fName As String
Dim r As Range, rng As Range

Application.ScreenUpdating = False
fPath = "C:\Users\ryans\OneDrive\Desktop\Briefcase\Digital Pics\8th Wedding Anniversary\"
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
i = 1
For Each r In rng
    fName = Dir(fPath)
    Do While fName <> ""
            With ActiveSheet.Pictures.Insert(fPath & fName)
                .ShapeRange.LockAspectRatio = msoTrue
                Set px = .ShapeRange
                If .ShapeRange.Width > Rows(i).Columns(2).Width Then .ShapeRange.Width = Columns(2).Width
                    With Cells(i, 2)
                        px.Top = .Top
                        px.Left = .Left
                        .RowHeight = px.Height
                    End With
            End With
            i = i + 1
        fName = Dir
    Loop
Next r
Application.ScreenUpdating = True
End Sub

现在，像这样增加和减少图像大小。

Sub IncreaseSize()
Dim shp As Shape
Dim big As Single, small As Single
Dim shpDouH As Double, shpDouOriH As Double
big = 3
small = 1
On Error Resume Next
Set shp = ActiveSheet.Shapes(Application.Caller)
With shp
    shpDouH = .Height
    .ScaleHeight 1, msoTrue, msoScaleFromTopLeft
    shpDouOriH = .Height

    If Round(shpDouH / shpDouOriH, 2) = big Then
        .ScaleHeight small, msoTrue, msoScaleFromTopLeft
        .ScaleWidth small, msoTrue, msoScaleFromTopLeft
        .ZOrder msoSendToBack
    Else
        .ScaleHeight big, msoTrue, msoScaleFromTopLeft
        .ScaleWidth big, msoTrue, msoScaleFromTopLeft
        .ZOrder msoBringToFront
    End If
End With
End Sub

这两个宏都应该分配给事件。查看下面的链接以了解如何执行此操作。

https://www.extendoffice.com/documents/excel/4380-excel-click-to-enlarge-image.html

【讨论】：