Hallo, :19:
diese Fehlermeldung bekomme ich nur, wenn die Grafikdatei einen Knacks hat. Wenn Du es über "Einfügen - Bilder einfügen" in Excel reinladen kannst müsst der Code auch klappen.
Super, jetzt funzt es. Vielen Dank allen !!
Eine kleine Frage noch zu dem Makro.
Position bestimmen etc. ist klar, aber wie bekomme ich das JPG etwas vergrößert, dbscale ändern, aber wie ?
DAnke
Alles kloar, hat sich von selber erledigt.
Danke an alle
Jetzt noch einmal eine Frage.
Ich nutze also das Makro von Case. Danke nochmals
Code:
Sub Main()
Dim strPicName As Variant
Dim dblScale As Double
Dim objShape As Shape
On Error Resume Next
ActiveSheet.Shapes("picto").Delete
Err.Clear
On Error GoTo Fin
strPicName = "C:\Temp\Bild1.jpg"
Select Case Right(strPicName, 3)
Case "bmp", "jpg", "tif", "gif", "bmp"
Application.ScreenUpdating = False
With Cells(3, 3)
Set objShape = ActiveSheet.Shapes.AddPicture( _
strPicName, msoFalse, msoTrue, .Left, .Top, -1, -1)
objShape.Top = .Top + 1
objShape.Left = .Left + 1
dblScale = WorksheetFunction.Min(.Width / objShape.Width, .Height / objShape.Height)
objShape.Height = objShape.Height * dblScale
objShape.Name = "picto"
End With
Case Else
MsgBox "Sie haben kein gültiges Bild ausgewählt"
End Select
Fin:
Set objShape = Nothing
Application.ScreenUpdating = True
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Jetzt gibt es aber 9 Piktogramme(Bilder), die ich in mein Tabellenblatt kopieren könnte. max. aber nur 4 gleichzeitig !!
DIe Auswahl etc. ist nicht das Problem, aber wie kann ich das lösen, dass jedes Piktogramm nicht einen festen Platz vorgegeben bekommt, sondern einen dieser 4 Plätze.
Soll heißen ein Pikto.. Platz 1
zwei Pikto Platz 1 und 2 usw..
Ich hoffe das ist verständlich, leider handelt es sich um ein Firmendoku, dass ich nicht wirklich posten kann.
Danke
Zitat:aber wie kann ich das lösen, dass jedes Piktogramm nicht einen festen Platz vorgegeben bekommt,
Hi,
in dem du Zeile 13 anpasst
dort steht:
Das entspricht Zelle C3
definiere die anderen Plätze, bau das in eine Schleife, und schon haste es.
Das ist jetzt aber doch einfach?
ok, hab´s etwas anders gelöst, 9 Piktogramme 9 Plätze. Soweit so gut.
Mit welchem Befehl kann ich meine Pictogramme aber jetzt löschen ?
Activesheet.shapes("picto1").delete
funktioniert aber auch nur wenn ich mein picto aufgerufen habe. Wenn nicht stoppt mein Makro weil nix zum löschen da ist..
Hallo, :19:
Du könntest eine Funktion einsetzen:
Code:
Option Explicit
Sub Main()
If fncShapeEX("picto1", ActiveSheet) Then ActiveSheet.Shapes("picto1").Delete
On Error GoTo Fin
Fin:
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Public Function fncShapeEX(ByVal strShape As String, ByVal wksSheet As Worksheet) As Boolean
On Error Resume Next
fncShapeEX = Not wksSheet.Shapes(strShape) Is Nothing
End Function
Mit "
On Error Resume Next" solltest Du nicht leichtfertig umgehen. Schau dir das mal in der Hilfe an.
Du kannst aber auch über die "
TopLeftCell-Eigenschaft" gehen.
Shape.TopLeftCell-Eigenschaft (Excel)