Pfad

Option Explicit
Sub Bild_einfuegen_umbenennen()
'Selektiertes Shape-Object umbenennen
Dim objShape As Object, objShape2 As Shape
Dim Zelle As Range
Dim strAuswahl As String, strMsgText As String, NameOld As String
On Error GoTo Fehler
Set Zelle = Application.InputBox(prompt:="Bitte Einfügezelle für kopiertes Bild wählen", _
Title:="Bild kopieren", Default:=ActiveCell.Address, Type:=8)
Application.GoTo Reference:=Zelle, Scroll:=False
ActiveSheet.Paste
Set objShape = Selection
objShape.Top = Zelle.Top + 1
objShape.Left = Zelle.Left + 1
NameOld = objShape.Name
strMsgText = "Bitte Namen des selektierten Bildes anpassen" & vbLf _
& "Aktueller Name: " & NameOld
Eingabe:
strAuswahl = VBA.InputBox(strMsgText, Title:="Bild umbenennen", Default:=NameOld)
If strAuswahl  "" Then
For Each objShape2 In ActiveSheet.Shapes
If LCase(objShape2.Name) = LCase(strAuswahl) Then
strMsgText = "Der eingegebene Name ist bereits vorhanden." & vbLf _
& "Bitte Namen des eingefügten Bildes anpassen" & vbLf _
& "Aktueller Name: " & NameOld
GoTo Eingabe
End If
Next
objShape.Name = strAuswahl
End If
Fehler:
If Err.Number  0 Then
If Err.Number = 424 Then
'Zellselektion wurde abgebrochen
Else
MsgBox "Fehler-Nr.: " & Err.Number & vbLf & Err.Description & vbLf _
& "Vor Start des Makros muss ein Bild kopiert werden!", _
vbInformation, _
"Makro - ChangeName_of_SelectedShape"
End If
End If
End Sub