jpg-Datei in Excel-Zelle verankern

Option Explicit
Sub TestJPEGEinfuegen()
 
 Dim Zelle As Range
 Dim sDateinameFull As String
 Dim fileToOpen As Variant
 fileToOpen = Application.GetOpenFilename(jpegs (*.jpg; *.jpeg),*.jpg;*.jpeg)
 If fileToOpen = False Then Exit Sub
 
->nur jpg oder jpeg zulassen
 If Not ( _
  (LCase(Right(fileToOpen, 4)) = .jpg) Or _
  (LCase(Right(fileToOpen, 5)) = .jpeg)) Then
  MsgBox Nur .jpg / .jpeg zulässig.
  GoTo AUFRAEUMEN
 End If
  
 sDateinameFull = fileToOpen
 Set Zelle = ActiveCell
 If Not JPGInZelleEinfuegen(sDateinameFull, Zelle) Then GoTo AUFRAEUMEN

AUFRAEUMEN:
 Set Zelle = Nothing
End Sub


Private Function JPGInZelleEinfuegen(sDateinameFull As String, Zelle As Range) As Boolean
  
  Dim ws As Worksheet, s As Shape, p As Object
  Set ws = Zelle.Parent
  
 ->a) Datei vorhanden ?
  If Dir(sDateinameFull, vbNormal) =  Then
   MsgBox JPGInZelle:Bild nicht vorhanden: & vbLf & sDateinameFull
   GoTo AUFRAEUMEN
  End If
  
 ->c) Arbeitsblatt ?
  If TypeName(ws) <> Worksheet Then
   MsgBox JPGInZelle:Range liegt nicht auf Arbeitsblatt. & vbLf & Typ:  & TypeName(ws)
   GoTo AUFRAEUMEN
  End If
  
 ->c) nur eine Zelle ?
  If Zelle.Count <> 1 Then
   MsgBox JPGInZelle:Als Range nur eine Zelle zulässig: & vbLf & Zelle.Address
   GoTo AUFRAEUMEN
  End If
  
 ->d) in Zelle ist noch kein Bild ?
  For Each s In ws.Shapes
   If s.TopLeftCell.Address = Zelle.Address Then
    MsgBox JPGInZelle:es ist bereits Bild in der Zelle: & vbLf & Zelle.Address
    GoTo AUFRAEUMEN
   End If
  Next
  
 ->e) Bild in Zelle einfügen
  Dim dHeight As Double, dWidth As Double
  dWidth = Zelle.Offset(0, 1).Left - Zelle.Left
  dHeight = Zelle.Offset(1, 0).Top - Zelle.Top
  Set p = ws.Pictures.Insert(sDateinameFull)
  p.Left = Zelle.Left
  p.Top = Zelle.Top
  
 ->f) Bild auf Zellgröße skalieren, aber nicht verzerren
  Dim dScW As Double, dScH As Double, dSc As Double
  dScW = dWidth / p.Width
  dScH = dHeight / p.Height
  If dScW < dScH Then dSc = dScW Else dSc = dScH
  p.Width = p.Width * dSc
  p.Height = p.Height * dSc
  
 ->g) Bildeigenschaften setzen:
  p.Placement = xlMoveAndSize-> von Zell-Position und -Größe abhängig
  p.PrintObject = True   -> drucken
 
 JPGInZelleEinfuegen = True
AUFRAEUMEN:
 Set ws = Nothing: Set s = Nothing: Set p = Nothing
End Function