Bild einfügen oder löschen

Hallo.
Ich möchte meinem vorhandenen Code zum Einfügen eines Bildes mit einer MsgBox erweitern, um mit einer Abfrage, ob schon ein Bild vorhanden ist, dem User die Möglichkeit zu geben, entweder das vorhandene Bild zu löschen oder das vorhandene mit dem Öffnen Dialog zu ersetzen. Wenn kein Bild vorhanden ist, dann soll ganz normal der Öffnen Dialog aufgerufen werden.
Das Bild beginnt in Zelle E45 und über den Bereich bis G49 eingefügt.
Bis jetzt habe ich folgenden VBA Code...


Sub BildLaden()
'mit Unterstützung von Beverly aus www.herber.de
Dim sPicture As String, pic As Picture, shaShape As Shape
'Öffnen Dialog zum Auswählen der Grafik
sPicture = Application.GetOpenFilename("Grafik laden (*.png), *.png", , "Wähle deine  _
erstellte Unterschrift aus !")
'wenn keine Grafik vorhanden, dann...
If sPicture  "False" And sPicture  "Falsch" Then
ActiveSheet.Unprotect Password:=""
'Variante 1: wenn 1 Bild enthalten ist, dann dieses löschen
'Variante 2: prüfen, ob sich bereits eine Bild im Blatt befindet, dessen Zelladresse der  _
linken oberen Ecke mit D45 übereinstimmt,
'falls noch weiter Bilder eingefüget werden sollen
'        For Each shaShape In ActiveSheet.Shapes
'        If shaShape.TopLeftCell.Address = "$E$45" Then
'            shaShape.Delete
'            Exit For
'        End If
'        Next shaShape
'        Set shaShape = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, LinkToFile:=msoFalse,  _
_
'            SaveWithDocument:=msoTrue, Left:=Columns(5).Left, Top:=Rows(45).Top, _
'            Width:=Columns("E:G").Width, Height:=Rows("45:49").Height)
'        shaShape.Placement = xlMoveAndSize
Set pic = ActiveSheet.Shapes.AddPicture(sPicture, msoFalse, msoTrue, Cells(45, 5).Left,  _
Cells(49, 7), 50, 30)
Set pic = ActiveSheet.Pictures.Insert(sPicture)
If ActiveSheet.Pictures.Count > 0 Then
If MsgBox("Aktuelles Bild löschen?", vbCritical + vbYesNo, "Bild löschen") = vbYes  _
Then
ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Delete
Exit Sub
Else
With pic
.ShapeRange.LockAspectRatio = msoTrue
.Height = Range("E45:G49").Height
.Width = Range("E45:G49").Width
.Top = Range("E45:G49").Top
.Left = Range("E45:G9").Left
.Placement = xlMoveAndSize
End With
ActiveSheet.Protect Password:=""
Set pic = Nothing
End If
End If
End If
End Sub

Kann mir jemand helfen auf die richtig Spur zu kommen? Ich habe schon einiges ausprobiert, konnte aber keine vernünftige Lösung finden. Oben genannter Code ist mein bisher letzter Versuch.
Vielen Dank für eure Hilfe.
LG
Peer

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub BildLaden() 'mit Unterstützung von Beverly aus www.herber.de Dim sPicture As String, pic As Picture, shaShape As Shape 'Öffnen Dialog zum Auswählen der Grafik sPicture = Application.GetOpenFilename("Grafik laden (*.png), *.png", , "Wähle deine _ erstellte Unterschrift aus !") 'wenn keine Grafik vorhanden, dann... If sPicture "False" And sPicture "Falsch" Then ActiveSheet.Unprotect Password:="" For Each shaShape In ActiveSheet.Shapes If shaShape.TopLeftCell.Address = "$E$45" Then shaShape.Delete Exit For End If Next shaShape Set shaShape = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, LinkToFile:=msoFalse, _ _ SaveWithDocument:=msoTrue, Left:=Columns(5).Left, Top:=Rows(45).Top, _ Width:=Columns("E:G").Width, Height:=Rows("45:49").Height) shaShape.Placement = xlMoveAndSize Else If MsgBox("Bild löschen?", vbQuestion + vbYesNo, "Unterschrift löschen") = vbYes Then ActiveSheet.Shapes(shaShape).Delete End If ActiveSheet.Protect Password:="" End If

Sub BildLaden() 'mit Unterstützung von Beverly aus www.herber.de Dim sPicture As String, pic As Picture, shaShape As Shape 'Öffnen Dialog zum Auswählen der Grafik sPicture = Application.GetOpenFilename("Grafik laden (*.png), *.png", , "Wähle deine _ erstellte Unterschrift aus !") 'wenn keine Grafik vorhanden, dann... If sPicture "False" And sPicture "Falsch" Then ActiveSheet.Unprotect Password:="" For Each shaShape In ActiveSheet.Shapes If shaShape.TopLeftCell.Address = "$E$45" Then If MsgBox("Bild löschen?", vbQuestion + vbYesNo, "Unterschrift löschen") = _ vbYes Then shaShape.Delete Set shaShape = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, _ LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _ Left:=Columns(5).Left, Top:=Rows(45).Top, _ Width:=Columns("E:G").Width, Height:=Rows("45:49").Height) shaShape.Placement = xlMoveAndSize End If Exit For End If Next shaShape ActiveSheet.Protect Password:="" End If End Sub

Sub BildLaden() 'mit Unterstützung von Beverly aus www.herber.de Dim sPicture As String, pic As Picture, shaShape As Shape Dim blnLoeschen As Boolean ActiveSheet.Unprotect Password:="" If ActiveSheet.Shapes.Count > 0 Then For Each shaShape In ActiveSheet.Shapes If shaShape.TopLeftCell.Address = "$E$45" Then ' Abfrage ob löschen: Ja If MsgBox("Bild löschen?", vbQuestion + vbYesNo, "Unterschrift löschen") = _ vbYes Then ' Bild löschen shaShape.Delete Else ' vorhandenes Bild muss später gelöscht werden wenn neues eingefügt wird blnLoeschen = True End If Exit For End If Next shaShape End If ' Bild aussuchen sPicture = Application.GetOpenFilename("Grafik laden (*.png), *.png", , "Wähle deine _ erstellte Unterschrift aus !") If sPicture "False" And sPicture "Falsch" Then ' vorhandenes Bild löschen da es ersetzt werden soll If blnLoeschen Then shaShape.Delete ' neues Bild einfügen Set shaShape = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, _ LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _ Left:=Columns(5).Left, Top:=Rows(45).Top, _ Width:=Columns("E:G").Width, Height:=Rows("45:49").Height) shaShape.Placement = xlMoveAndSize End If ActiveSheet.Protect Password:="" End Sub

Sub BildLaden() 'mit Unterstützung von Beverly aus www.herber.de Dim sPicture As String, pic As Picture, shaShape As Shape Dim blnLoeschen As Boolean ActiveSheet.Unprotect Password:="" If ActiveSheet.Shapes.Count > 0 Then For Each shaShape In ActiveSheet.Shapes If shaShape.TopLeftCell.Address = "$E$45" Then ' Abfrage ob löschen: Ja If MsgBox("Bild löschen?", vbQuestion + vbYesNo, "Unterschrift löschen") = _ vbYes Then ' Bild löschen shaShape.Delete Else sPicture = Application.GetOpenFilename("Grafik laden (*.png), *.png", , "Wä _ hle deine erstellte Unterschrift aus !") If sPicture "False" And sPicture "Falsch" Then ' vorhandenes Bild löschen da es ersetzt werden soll If blnLoeschen Then shaShape.Delete ' neues Bild einfügen Set shaShape = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, _ LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _ Left:=Columns(5).Left, Top:=Rows(45).Top, _ Width:=Columns("E:G").Width, Height:=Rows("45:49").Height) shaShape.Placement = xlMoveAndSize End If End If Exit For End If End If Next shaShape Else: sPicture = Application.GetOpenFilename("Grafik laden (*.png), *.png", , "Wähle deine _ erstellte Unterschrift aus !") If sPicture "False" And sPicture "Falsch" Then ' vorhandenes Bild löschen da es ersetzt werden soll If blnLoeschen Then shaShape.Delete ' neues Bild einfügen Set shaShape = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, _ LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _ Left:=Columns(5).Left, Top:=Rows(45).Top, _ Width:=Columns("E:G").Width, Height:=Rows("45:49").Height) shaShape.Placement = xlMoveAndSize End If End If ' Bild aussuchen End If ActiveSheet.Protect Password:="" End Sub

Hallo Beverly.
Das ist wirklich (nicht ganz) dein Code. Ich habe zwar deine Zeilen benutzt, aber versucht sie anderes anzuordnen, um folgendes zu bewerkstelligen.
Der User soll die Möglichkeit bekommen, das vorhandene Bild zu löschen ohne gleich ein neues einzufügen. Ebenso soll bei fehlenden Bild (auch nach dem Löschen des Bildes) über den Öffnen Dialog ein neues Bild auswählbar sein.
Also kein Bild vorhanden, ohne MsgBox der Öffnen Dialog starten; Bild vorhanden, dann die Auswahl über MsgBox, ob das vorhandene gelöscht werden soll oder nicht. Wenn ja, das Bild löschen und Sub beenden, wenn nein, Öffnen Dialog, um ein anderes Bild auszuwählen.
Das sind meine Vorstellungen. Ich habe keine Ahnung, wie man es sonst lösen könnte. Oder denke ich zu umständlich... ist nicht das erste Mal ;-)
LG
Peer

Sub BildLaden() 'mit Unterstützung von Beverly aus www.herber.de Dim sPicture As String, pic As Picture, shaShape As Shape Dim blnLoeschen As Boolean ' ActiveSheet.Unprotect Password:="" If ActiveSheet.Shapes.Count > 0 Then For Each shaShape In ActiveSheet.Shapes If shaShape.TopLeftCell.Address = "$E$45" Then ' Abfrage ob löschen: Ja If MsgBox("Bild löschen?", vbQuestion + vbYesNo, _ "Unterschrift löschen") = vbYes Then ' Bild löschen shaShape.Delete Else ' Bild aussuchen sPicture = Application.GetOpenFilename("Grafik laden (*.png), *.png", , _ "Wähle deine erstellte Unterschrift aus !") If sPicture "False" And sPicture "Falsch" Then ' Bild löschen shaShape.Delete ' neues Bild einfügen Set shaShape = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, _ LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _ Left:=Columns(5).Left, Top:=Rows(45).Top, _ Width:=Columns("E:G").Width, Height:=Rows("45:49").Height) shaShape.Placement = xlMoveAndSize End If End If Exit For End If Next shaShape Else ' Bild aussuchen sPicture = Application.GetOpenFilename("Grafik laden (*.png), *.png", , _ "Wähle deine erstellte Unterschrift aus !") If sPicture "False" And sPicture "Falsch" Then ' neues Bild einfügen Set shaShape = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, _ LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _ Left:=Columns(5).Left, Top:=Rows(45).Top, _ Width:=Columns("E:G").Width, Height:=Rows("45:49").Height) shaShape.Placement = xlMoveAndSize End If End If ' ActiveSheet.Protect Password:="" End Sub

Sub BildLaden() 'mit Unterstützung von Beverly aus www.herber.de Dim sPicture As String, pic As Picture, shaShape As Shape Dim blnVorhanden As Boolean Dim blnLoeschen As Boolean ActiveSheet.Unprotect Password:="" For Each shaShape In ActiveSheet.Shapes On Error GoTo ErrorHandler If Not IsError(shaShape.TopLeftCell.Address) Then If shaShape.TopLeftCell.Address = "$E$45" Then blnVorhanden = True Exit For End If End If ErrorHandler: On Error GoTo 0 Next shaShape If blnVorhanden Then ' Abfrage ob löschen: Ja If MsgBox("Bild löschen?", vbQuestion + vbYesNo, _ "Unterschrift löschen") = vbYes Then ' Bild löschen shaShape.Delete Exit Sub Else blnLoeschen = True End If End If If blnVorhanden = False Then ' Bild war vorhanden deshalb löschen If blnLoeschen Then shaShape.Delete ' Bild aussuchen sPicture = Application.GetOpenFilename("Grafik laden (*.png), *.png", , _ "Wähle deine erstellte Unterschrift aus !") If sPicture "False" And sPicture "Falsch" Then ' neues Bild einfügen Set shaShape = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, _ LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _ Left:=Columns(5).Left, Top:=Rows(45).Top, _ Width:=Columns("E:G").Width, Height:=Rows("45:49").Height) shaShape.Placement = xlMoveAndSize End If End If ActiveSheet.Protect Password:="" End Sub

Sub BildLaden() 'mit Unterstützung von Beverly aus www.herber.de Dim sPicture As String, pic As Picture, shaShape As Shape Dim blnVorhanden As Boolean Dim blnLoeschen As Boolean ActiveSheet.Unprotect Password:="" For Each shaShape In ActiveSheet.Shapes On Error GoTo ErrorHandler If Not IsError(shaShape.TopLeftCell.Address) Then If shaShape.TopLeftCell.Address = "$E$45" Then blnVorhanden = True Exit For End If End If ErrorHandler: On Error GoTo 0 Next shaShape If blnVorhanden Then ' Abfrage ob löschen: Ja If MsgBox("Bild löschen?", vbQuestion + vbYesNo, _ "Unterschrift löschen") = vbYes Then ' Bild löschen shaShape.Delete Exit Sub Else blnLoeschen = True blnVorhanden = False End If End If If blnVorhanden = False Then ' Bild war vorhanden deshalb löschen If blnLoeschen Then shaShape.Delete ' Bild aussuchen sPicture = Application.GetOpenFilename("Grafik laden (*.png), *.png", , _ "Wähle deine erstellte Unterschrift aus !") If sPicture "False" And sPicture "Falsch" Then ' neues Bild einfügen Set shaShape = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, _ LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _ Left:=Columns(5).Left, Top:=Rows(45).Top, _ Width:=Columns("E:G").Width, Height:=Rows("45:49").Height) shaShape.Placement = xlMoveAndSize End If End If ActiveSheet.Protect Password:="" End Sub

Also kein Bild vorhanden, ohne MsgBox der Öffnen Dialog starten; Bild vorhanden, dann die Auswahl über MsgBox, ob das vorhandene gelöscht werden soll oder nicht. Wenn ja, das Bild löschen und Sub beenden, wenn nein, Öffnen Dialog, um ein anderes Bild auszuwählen.

Sub BildLaden() 'mit Unterstützung von Beverly aus www.herber.de Dim sPicture As String, pic As Picture, shaShape As Shape Dim blnVorhanden As Boolean Dim blnLoeschen As Boolean ActiveSheet.Unprotect Password:="" For Each shaShape In ActiveSheet.Shapes If shaShape.name = "Unterschrift" Then blnVorhanden = True Exit For End If Next shaShape If blnVorhanden Then ' Abfrage ob löschen: Ja If MsgBox("Bild löschen?", vbQuestion + vbYesNo, _ "Unterschrift löschen") = vbYes Then ' Bild löschen shaShape.Delete Exit Sub Else blnLoeschen = True blnVorhanden = False End If End If If blnVorhanden = False Then sPicture = Application.GetOpenFilename("Grafik laden (*.png), *.png", , _ "Wähle deine erstellte Unterschrift aus !") If sPicture "False" And sPicture "Falsch" Then If blnLoeschen Then ActiveSheet.Shapes("Unterschrift").Delete ' neues Bild einfügen Set shaShape = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, _ LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _ Left:=Columns(5).Left, Top:=Rows(45).Top, _ Width:=Columns("E:G").Width, Height:=Rows("45:49").Height) shaShape.Placement = xlMoveAndSize shaShape.name = "Unterschrift" End If End If ActiveSheet.Protect Password:="" End Sub

Beliebteste Forumthreads (12 Monate)

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread