VBA:Bild einfügen und löschen

[Joe]

Guten Tag liebe Community,

folgende Herausforderungen sind für mich alleine nicht zu bewältigen.
Ich habe eine Maske mit zwei ComboBoxen und beim jeweiligen wählen  der Combobox wird jeweils  ein Bild in jeweiligen Zellen eingefügt. Das hab ich soweit geschafft, aber das Problem ist wenn ich ein anderes Bild wähle löscht er das vorhandene Bild nicht.

Zudem möchte ich auch, dass man das gewählte Bild auch in der Maske sieht.

Damit ihr genau wisst was ich meine hab ich eine Beispieldatei angehängt.

Schöne Grüße Joe

[Steffl]

Hallo Joe,

mal nur der Teil mit dem Löschen (das mit der Maske habe ich überlesen :20: )

Code:

Private Sub cboAuto_Change()

Worksheets("Tabelle1").Range("A1") = Me.cboAuto.Value



Dim shpPicture As Shape
Application.ScreenUpdating = False

For Each shpPicture In ActiveSheet.Shapes
   If shpPicture.TopLeftCell.Address(0, 0) = "A6" Then shpPicture.Delete
Next shpPicture
'Sheets("Tabelle1").Range("A6").ClearContents

'Schleife um alle Bilder im Blatt "Tabelle1" zu löschen
'       Worksheets("Tabelle1").Range("A6").Delete
      
'Bild dessen Namen in Zelle A1 steht kopieren...
Sheets("Tabelle2").Shapes(Sheets("Tabelle1").Range("A1")).Copy
'...und in Zelle A6 einfügen
Sheets("Tabelle1").Range("A6").PasteSpecial Paste:=xlPasteValues
'Setenverhältnis der Grafik ausschalten und Größe verändern
With Selection
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Height = 100 'Bildhöhe
    .ShapeRange.Width = 200  'Bildbreite
End With
Application.ScreenUpdating = True

End Sub

Private Sub cboFormel_Change()

Worksheets("Tabelle1").Range("E1") = Me.cboFormel.Value



Dim shpPicture As Shape
Application.ScreenUpdating = False

For Each shpPicture In ActiveSheet.Shapes
   If shpPicture.TopLeftCell.Address(0, 0) = "E6" Then shpPicture.Delete
Next shpPicture

'Sheets("Tabelle1").Range("E6").ClearContents

'Schleife um alle Formeln im Blatt "Tabelle1" zu löschen
'Worksheets("Tabelle1").Range("E6").Delete

'Bild dessen Namen in Zelle E1 steht kopieren...
Sheets("Tabelle2").Shapes(Sheets("Tabelle1").Range("E1")).Copy
'...und in Zelle E6 einfügen
Sheets("Tabelle1").Range("E6").PasteSpecial Paste:=xlPasteValues
'Setenverhältnis der Grafik ausschalten und Größe verändern
With Selection
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Height = 50 'Bildhöhe
    .ShapeRange.Width = 100  'Bildbreite
End With
Application.ScreenUpdating = True




End Sub

[Joe]

Moin Stefan,

der Code funktioniert nicht .

Oder gibt es da zu meinem Problem eine komplett andere vorangehensweise und wenn ja welche?

Gruß Joe

[Steffl]

Hallo Joe,

befinden sich die Bilder jeweils in A6 bzw. E6? Teste mal, indem Du das Bild markierst und im Direkfenster

Code:

?selection.topleftcell.address

einträgst und auf Return drückst. Was wird dir zurückgegeben?

[Steffl]

Hallo Joe,

ich habe den Code nochmal umgearbeitet.

Code:

Private Sub cboAuto_Change()
Dim shpPicture As Shape

Worksheets("Tabelle1").Range("A1") = Me.cboAuto.Value

Application.ScreenUpdating = False

For Each shpPicture In ActiveSheet.Shapes
   If Not Intersect(Range(shpPicture.TopLeftCell.Address), Cells(5, 1).Resize(3)) Is Nothing Then shpPicture.Delete
Next shpPicture
'Sheets("Tabelle1").Range("A6").ClearContents

'Schleife um alle Bilder im Blatt "Tabelle1" zu löschen
'       Worksheets("Tabelle1").Range("A6").Delete
      
'Bild dessen Namen in Zelle A1 steht kopieren...
Sheets("Tabelle2").Shapes(Sheets("Tabelle1").Range("A1")).Copy
'...und in Zelle A6 einfügen
Sheets("Tabelle1").Range("A6").PasteSpecial Paste:=xlPasteValues
'Setenverhältnis der Grafik ausschalten und Größe verändern
With Selection
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Height = 100 'Bildhöhe
    .ShapeRange.Width = 200  'Bildbreite
End With
Application.ScreenUpdating = True

End Sub

Private Sub cboFormel_Change()
Dim shpPicture As Shape

Worksheets("Tabelle1").Range("E1") = Me.cboFormel.Value

Application.ScreenUpdating = False

For Each shpPicture In ActiveSheet.Shapes
   If Not Intersect(Range(shpPicture.TopLeftCell.Address), Cells(5, 4).Resize(3, 2)) Is Nothing Then shpPicture.Delete
Next shpPicture

'Sheets("Tabelle1").Range("E6").ClearContents

'Schleife um alle Formeln im Blatt "Tabelle1" zu löschen
'Worksheets("Tabelle1").Range("E6").Delete

'Bild dessen Namen in Zelle E1 steht kopieren...
Sheets("Tabelle2").Shapes(Sheets("Tabelle1").Range("E1")).Copy
'...und in Zelle E6 einfügen
Sheets("Tabelle1").Range("E6").PasteSpecial Paste:=xlPasteValues
'Setenverhältnis der Grafik ausschalten und Größe verändern
With Selection
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Height = 50 'Bildhöhe
    .ShapeRange.Width = 100  'Bildbreite
End With
Application.ScreenUpdating = True

End Sub

[Joe]

Hey Stafan,

ich hab dein Code ausprobiert und der funktioniert super, DANKE!

Eine Frage was bedeutet Resize in dem Zusammenhang genau hab den Befehl nachgooglet, aber der Sinn erschließt mir noch nicht ganz.

Gruß Joe

[Joe]

Hey,

ich versuche immernoch ein Bild in der Userform anzuzeigen, aber irgendwie klappt es bei mir nicht.

Code:

With UserForm1
.Image1.Picture = LoadPicture(Worksheets("Tabelle1").Cells(5, 1))
.Image1.PictureSizeMode = fmPictureSizeModeZoom
End With

Was mache ich falsch?

Gruß Joe

[Kuwer]

Eine Frage was bedeutet Resize in dem Zusammenhang genau hab den Befehl nachgooglet, aber der Sinn erschließt mir noch nicht ganz.

Hallo Joe,

da brauchst Du nicht googlen, sondern nur den Cursor darauf setzen und F1 drücken!

Gruß Uwe