如何在Excel VBA中隐藏图片？

我已经阅读插入图片到Excel单元格的答案

但是，我的Excel是一个初始版本，它没有“格式注释”下的“颜色和线条”

我想把我的照片放入H列。每当我点击单元格时，图片就会放大。 可能？

注意：我没有vba的经验

Answer 1

你想添加一张图片（名字图片1）。 将以下代码添加到Sheet 1：

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Prev Then Dim x x = ActiveCell.Address ActiveSheet.Shapes.Range(Array("Picture 1")).Select Selection.ShapeRange.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft Selection.ShapeRange.ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft Prev = False Range(x).Select End If End Sub 

并在一个模块（在VBA Alt + F11 – >右键单击：工作表1 – >插入 – >模块）：

 Public Prev As Boolean Sub Macro1() ActiveSheet.Shapes.Range(Array("Picture 1")).Select Selection.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft Selection.ShapeRange.ScaleHeight 2, msoFalse, msoScaleFromTopLeft Prev = True End Sub 

为图片分配macrosMacro1 …（在图片上点击鼠标右键→分配macros）
当你点击图片时，图片放大，当你点击另一个单元格时，图片会减less。

Answer 2

通过从ComboBox列表中select行号将图片添加到列H，并将图片与alignment到中心点的单元格进行匹配，节省了比例

 Private Sub ComboBox1_Change() PTstop = Me.ComboBox1.value PicPath = Worksheets("Sheet1").Application.GetOpenFilename("*.jpg,*.png,*.jpeg,*.gif") If PicPath <> False Then With .Pictures.Insert(Filename:=PicPath) With .ShapeRange If .Width > .Height Then If .Height >= Worksheets("Sheet1").Cells(PTstop, 8).Height Then .Height = Worksheets("Sheet1").Cells(PTstop, 8).Height If .Width >= Worksheets("Sheet1").Cells(PTstop, 8).Width Then .Width = Worksheets("Sheet1").Cells(PTstop, 8).Width Else End If Else .Width = Worksheets("Sheet1").Cells(PTstop, 8).Width If .Height >= Worksheets("Sheet1").Cells(PTstop, 8).Height Then .Height = Worksheets("Sheet1").Cells(PTstop, 8).Height Else End If End If Else .Height = Worksheets("Sheet1").Cells(PTstop , 8).Height End If .Top = Worksheets("Sheet1").Cells(PTstop, 8).Top + Worksheets("Sheet1").Cells(PTstop , 8).Height / 2 - .Height / 2 .Left = Worksheets("Sheet1").Cells(PTstop, 8).Left + Worksheets("Sheet1").Cells(PTstop, 8).Width / 2 - .Width / 2 End With End With End If End Sub 

代码放大图像，然后点击右边的图像，如果点击A列的任何地方，图像应该减less大小。 没有testing，只是作为出发点。

 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rangeS As Range, picSelected As Shape, old If Target.Column > 1 Then Set rangeS = Target.Offset(, -1) For Each picSelected In ActiveSheet.Shapes If TypeName(picSelected.OLEFormat.Object) = "Picture" Then If picSelected.TopLeftCell.Address = rangeS.Address Then picSelected.Height = 250 picSelected.Width = 250 End If End If Next picSelected ElseIf Target.Column = 1 Then For Each picSelected In ActiveSheet.Shapes If TypeName(picSelected.OLEFormat.Object) = "Picture" Then With picSelected If .Width > .Height Then If .Height >= Target.Height Then .Height = Target.Height Else .Width = Target.Width If .Height >= Target.Height Then .Height = Target.Height Else End If End If Else .Height = Target.Height End If .Top = Target.Top + Target.Height / 2 - .Height / 2 .Left = Target.Left + Target.Width / 2 - .Width / 2 End With End If Next picSelected End If End Sub