Option Explicit
Private Sub Afbeelding1()
Dim aCell As Variant
Dim aPicture As Variant
Dim bUpRight As Boolean
Dim dPictureDiagonal As Double
Dim lOrientation As Long
Dim lZoom As Long
Dim vPath As Variant
vPath = Application.GetOpenFilename(Title:="Selecteer Afbeelding")
If vPath = False Then
Exit Sub
Else
Application.ScreenUpdating = False
lZoom = ActiveWindow.Zoom
ActiveWindow.Zoom = 100 'when not 100, picture fits not nice in cell
With ActiveSheet.Shapes(Application.Caller).TopLeftCell.MergeArea
aCell = Array(.Left, .Top, .Width, .Height)
End With
With CreateObject("WIA.ImageFile")
.LoadFile vPath
lOrientation = .Properties("Orientation") - 1
End With
With ActiveSheet.Shapes.AddPicture(vPath, False, True, 0, 0, -1, -1)
.LockAspectRatio = msoTrue
aPicture = Array(.Width, .Height)
dPictureDiagonal = Sqr(aPicture(0) ^ 2 + aPicture(1) ^ 2)
.IncrementLeft (dPictureDiagonal - aPicture(0)) / 2 - 1 'when corner rotates through negative values, unpridictable results
.IncrementTop (dPictureDiagonal - aPicture(1)) / 2 - 1
If (lOrientation And 4) Then
.IncrementRotation 90
.Flip msoFlipHorizontal
End If
If (lOrientation And 2) Then
.IncrementRotation 180
End If
If (lOrientation And 1) Then
.Flip msoFlipHorizontal
End If
bUpRight = lOrientation < 4
If aPicture(1) * aCell(3 + bUpRight) < aPicture(0) * aCell(2 - bUpRight) Then
.Width = aCell(3 + bUpRight)
Else
.Height = aCell(2 - bUpRight)
End If
.IncrementLeft aCell(0) + (aCell(2) - .Width) / 2 - .Left
.IncrementTop aCell(1) + (aCell(3) - .Height) / 2 - .Top
End With
End If
ActiveWindow.Zoom = lZoom
Application.ScreenUpdating = True
End Sub