per Makro jpg einfügen

[Case]

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.

[Wexel]

Super, jetzt funzt es. Vielen Dank allen !!

[Wexel]

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

[Wexel]

Alles kloar, hat sich von selber erledigt.

Danke an alle

[Wexel]

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

[Wastl]

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:

Code:

With Cells(3, 3)

Das entspricht Zelle C3

definiere die anderen Plätze, bau das in eine Schleife, und schon haste es.
Das ist jetzt aber doch einfach?

[Wexel]

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..

[Case]

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)

[Wexel]

Spitze, Danke