导入图片并能够通过再次单击缩小/展开

Question

我正在尝试使用宏在 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

Answer 1

你可以这样尝试。

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

Sub InsertPics()
Dim fPath As String, fName As String
Dim r As Range, rng As Range
Application.ScreenUpdating = False
fPath = "C:UsersryansOneDriveDesktopBriefcaseDigital Pics8th 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