Office: mit Optionsbutton Bild einfügen und entfernen

Hallöchen Zusammen,

ich möchte in Tabelle 1 mit Hilfe einer Checkbox steuern, ob in Tabelle 2 Zelle ("B15") ein bestimmtes Bild aus C:\Excel\ (in bestimmter Höhe und Breite) eingefügt wird oder nicht.

Ist es auch möglich bei De- bzw. Aktivierung etwas unterschiedliches im Kontrollkästchen stehen zu haben?
z.B.: "Mitglied" bei Aktivierung und "Nichtmitglied" bei Deaktivierung.

Ich hoffe, Ihr könnt mir hierbei helfen. - Vielen Dank im voraus. :)

LG
Meike

 

Hi Meike,

was für eine CheckBox verwendest du - Formular-Steuerelement oder ActiveX-Steuerelement im Tabellenblatt oder befindet sie sich auf einem UserForm?
Wann soll das Bild eingefügt werden - bei Aktivieren der CheckBox und soll es wieder gelöscht werden bei Deaktivieren? Oder wird dazu ein extra Steuerelement (z.B. CommandButton) verwendet - also wie soll das alles konkret ablaufen?

Bis später,
Karin

 

Hi Karin,

danke für deine Antwort. Momentan habe ich 2 Formularsteuerelemte "Optionsfeld". Mit "Bild einfügen" und "Bild entfernen". Wenn eins aktiviert ist, ist das andere deaktiviert.

Für Bild einfügen habe ich bisher folgenden Code:

Sub Bild_einfügen()
Sheets("Tabelle2").Select
Range("J42").Select
ActiveSheet.Unprotect Password:="pw"
ActiveSheet.Pictures.Insert("C:\Excel\Logo").Select
Selection.Name = "Bildname"
With Selection
.Width = 100
.Height = 100
End With

On Error Resume Next
Dim ObjektDLG As Dialog
Set ObjektDLG = Aplication.Dialogs(xlDialogInsertPicture)
ObjektDLG.show
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 135.25
Selection.ShapeRange.Weight = 525.5
Selection.ShapeRange.Rotation = 0
Range("B41").Select
ActiveSheet.Protect Password:="pw", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True
Sheets("Tabelle1").Select
ActiveWindow.SmallScroll Down:=-15
Range("D9:G9").Select
End Sub

Mein zweites Optionsfeld mit Bild entfernen:

Sub Bild_entfernen ()
Sheets("Tabelle2").Select
Range("K41").Select

ActiveSheet.Unprotect Password:="pw"

ActiveSheet.Shapes.Range(Array("Bildname")).Select
Selection.Delete

Range("B41").Select

ActiveSheet.Protect Password:="pw", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True

Sheets("Eingabe").Select
Range("D9:G9").Select
End Sub

Ist sicherlich nicht die schönste Variante aber mittlerweile funktioniert es soweit. Für Vorschläge, das Ganze etwas schöner zu gestalten, bin ich aber natürlich offen!

Bei der Anwendung ist mir noch was aufgefallen: Wenn das Optionsfeld "Bild_entfernen" aktiviert ist und man versehentlich nochmal auf denselben Optionsbutton klickt, kommt verständlicherweise Laufzeitfehler 1004 "Das Element mit dem angegebenen Namen wurde nicht gefunden". Kann man das irgendwie in den Code miteinbringen, dass er dann keine Fehlermeldung anzeigen soll, sondern einfach "nichts" machen soll?

Genauso beim Bild_einfügen. Ein zweitesmal versehentlich drauf geklickt, fügt er das Bild auf das andere Bild nochmal ein. Hast du hierzu Vl. noch eine Idee? Also unter dem Motto; wenn das Bild bereits eingefügt oder gelöscht ist, dann nichts machen.

So, ganz viel Text.... Ich hoffe ich konnte mich verständlich ausdrücken. Danke für dein Hilfe.

Liebe Grüße

 

Hi,

wozu rufst du noch einmal das Menü zum Bilder einfügen auf, wenn du bereits zuvor das Bild aus dem Ordner per Code eingefügt hast?

Code:

Sub Bild_Einfuegen()
    Dim picBild As Picture
    Dim blnVorhanden As Boolean
    With Worksheets("Tabelle2")
        .Unprotect Password:="pw"
        For Each picBild In .Pictures
            If picBild.Name = "Bildname" Then
                ' Bild ist schon vorhanden
                blnVorhanden = True
                Exit For
            End If
        Next picBild
        ' nur ausführen wenn Bild noch nicht vorhanden
        If blnVorhanden = False Then
            With .Pictures.Insert(""C:\Excel\Logo.jpg")
                .Name = "Bildname"
                .ShapeRange.LockAspectRatio = msoFalse
                .Width = 100
                .Height = 100
                .Left = Worksheets("Tabelle2").Range("J42").Left
                .Top = Worksheets("Tabelle2").Range("J42").Top
            End With
        End If
        .Protect Password:="pw", DrawingObjects:=True, Contents:=True, Scenarios:=True _
            , AllowFormattingCells:=True
    End With
End Sub

Sub Bild_Entfernen()
    Dim picBild As Picture
    With Worksheets("Tabelle2")
        .Unprotect Password:="pw"
        For Each picBild In .Pictures
            If picBild.Name = "Bildname" Then
                picBild.Delete
                Exit For
            End If
        Next picBild
        .Protect Password:="pw", DrawingObjects:=True, Contents:=True, Scenarios:=True _
            , AllowFormattingCells:=True
    End With
End Sub

Bis später,
Karin

 

Super, die Lösung meines Problems. Ich danke dir herzlich!!

Den gleichen Fehler bekomme ich, wenn ich einen Zelleninhalt in eine andere Tabelle via Schaltfläche (Formularsteuerelement) kopieren möchte.

Sub_copy()
Range("D9:G11").Copy
Sheets("Tabelle2").Activate
ActiveSheet.Unprotect Password:="pw"
Range("I64:L66").PasteSpecial Paste:=xlPasteValues

ActiveSheet.Protect Password:="pw", DrawingObjects:=True, Contents:= True, Scenatios:=True_
Sheets ("Eingabe").Activate
End Sub

....soetwas passiert wenn sich Unerfahrene - wie ich es bin - Ihren Code aus vorhandenem Material zusammenbasteln :) - Wie gut, dass es Euch gibt.

Schönes Wochenende. Grüßle

 

Hi,

Welchen "gleichen Fehler"?

Ich würde das Kopieren ja so lösen:

Code:

Sub Kopieren()
    Range("D9:G11").copy
    With Worksheets("Tabelle2")
        .Unprotect Password:="pw"
        .Range("I64:L66").PasteSpecial Paste:=xlPasteValues
        .Protect Password:="pw", DrawingObjects:=True, Contents:=True, Scenarios:=True _
            , AllowFormattingCells:=True
    End With
End Sub

Was mir allerdings bei deinem Code aufgefallen ist - ein Teil des Codes beim Setzen des Passwortes fehlt.

Bis später,
Karin

 

Hi Karin,
Danke für deine Antwort. Mit "Fehler" meinte ich, wenn der Inhalt bereits eingefügt ist und ich ein zweitesmal auf den Button klicke, kommt ebenfalls der "Laufzeitfehler 1004 - Die PasteSpecial-Methode des Range-Objektes konnte nicht ausgeführt werden." Ich habe versucht, dass ähnlich wie bei "Bild einfügen", mit einer If-Bedingung zu kombinieren - kam aber leider nicht auf die richtige Lösung.

Sub Kopieren()
Range("D9:G11").copy
With Worksheets("Tabelle2")
.Unprotect Password:="pw"
If
.Range("I64:L66").PasteSpecial Paste:=xlPasteValues
.Protect Password:="pw", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True
End With
End Sub

Hast du hierfür noch einen Vorschlag?

Eine zweite (ähnliche) Frage hätte ich noch zu meinem "Pdf-Erstell-Button": Ist die PDF noch in der Voransicht und drücke ich nochmal auf den Button kommt Laufzeitfehler '2147018887 (80071779) - Das Dokument wurde nicht gespeichert. Könnte man hier dem Benutzer die Meldung einspielen: "Pdf ist bereits geöffnet" ?

Sub ErzeugePDF()
Dim DtTxt As String, UserTxt As String

DtTxt = Format(Date, "YYYY-MM-DD")
UserTxt = Application.UserName

If Not Ermittle_Blatt() Then GoTo Err_Makro3_PDF2
If Not Ermittle_PFadDatei() Then GoTo Err_Makro3_PDF1
Call Ermittle_Seiten_Anzeigen

Ws.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Pfad & Datei & ".pdf", _
From:=SeiteVon, To:=SeiteBis, OpenAfterPublish:=Anzeigen, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintareas:=False
Exit Sub

Err_Makro3_PDF2:
MsgBox Prompt:="Das Arbeitsblatt '" & Blatt$ & "' existiert nicht!" & vbNewLine & vbNewLine & _
"Daher keine Speicherung der PDF-Datei --> Abbruch!", _
Buttons:=vbCritical + vbOKOnly, _
Title:="Falsches Arbeitsblatt"
Exit Sub
Err_Makro3_PDF1:
MsgBox Prompt:="Der Pfad '" & Pfad & "' zum Speichern der PDF-Datei existiert nicht!" & vbNewLine & vbNewLine & _
"Daher keine Speicherung der PDF-Datei --> Abbruch!", _
Buttons:=vbCritical + vbOKOnly, _
Title:="Falscher Dateipfad"
End Sub

Ich hoffe ich sprenge mit meinen Fragen nicht den Rahmen.

Vorab schonmal vielen Dank.

Grüße

 

Hi,

Thema Fehler beim Kopieren - ändere den Code wie folgt:

Code:

Sub Kopieren()
    With Worksheets("Tabelle2")
        .Unprotect Password:="pw"
        Range("D9:G11").Copy
        .Range("I64:L66").PasteSpecial Paste:=xlPasteValues
        .Protect Password:="pw", DrawingObjects:=True, Contents:=True, Scenarios:=True _
            , AllowFormattingCells:=True
    End With
    Application.CutCopyMode = False
End Sub

Zu deiner anderen Frage: diese hat nichts mit diesem Problem zu tun, eröffne deshalb bitte ein neues Thema - sonst wird das zu unübersichtlich.

Bis später,
Karin