Reputation: 1025
I have read an answer from Insert picture into excel cell
However, my Excel is a starter version which does not have "Colors and Lines " under "Format Comment"
I want to put my pictures into column H. Whenever I click on the cell, then the picture will enlarge. Possible?
Note: I have NO vba experience
Upvotes: 0
Views: 2687
Reputation: 136
Put picture to column H by selecting row number from combobox list, and fit picture to cell with align to center point, saving aspectratio
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
Code to enlarge image then clicked to Right of Image, if click anywhere in column A, image should reduce in size. Not tested just as starting point.
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
Upvotes: 1
Reputation: 1717
You add a picture (Name Picture 1) where you want. Add the follow code to the Sheet1:
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
and in a module (inside VBA Alt+F11 -> rightclick on : Sheet1 -> Insert -> module):
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
Assign to the picture the macro Macro1...(right mouse click on the picture -> Assign Macro)
When you click on the picture the picture enlarge, when you click on another cell, the picture reduce.
Upvotes: 1