Office: Bilder Hinzufügen, verkleinern und löschen

deko · 19. September 2018

Servus Zusammen,

hoffentlich eine kurze Frage ;D

Ich habe eine Liste mit insg. 4 "Bild-Feldern".

siehe Screenshot (2 abgebildet):

Das die Bilder über die Schaltfläche daneben eingefügt werden habe ich hinbekommen.

Relativ simpel:

Code:

Sub Bild1()
Dim varBild As Variant
Dim objImg As Object
varBild = Application.GetOpenFilename(Title:="Test")
If varBild = False Then Exit Sub
With Tabelle1.Image1
.PictureSizeMode = fmPictureSizeModeStretch
.Object.Picture = LoadPicture(varBild)
End With
End Sub

Sub Bild2()
Dim varBild As Variant
Dim objImg As Object
varBild = Application.GetOpenFilename(Title:="Test")
If varBild = False Then Exit Sub
With Tabelle1.Image2
.PictureSizeMode = fmPictureSizeModeStretch
.Object.Picture = LoadPicture(varBild)
End With
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Jetzt bräuchte ich das ganze aber so, dass die Bilder nicht in Originalgröße eingefügt werden. Wenn ich aktuell ein 5MB Bild einfüge, wird die Datei direkt um 5 MB Größer.

UND Wenn ich z.B. an der ersten Stelle dann ein anderes Bild einfüge, wird das alte nicht gelöscht, dann habe ich schon 10 MB mehr.

Cool wäre dafür ein Button zum löschen, ODER was mir besser gefallen würde, immer wenn ich ein neuen Bild hinzufüge, wird das alte gelöscht.

Hoffe ihr könnt mir helfen *biggrin.gif*

p.s.

Zusatzaufgabe (aber nicht so wichitg) Die Mappe erste speichern können wenn mindesten Bild 1-3 eingefügt sind.

Aktuell löse ich das über die gelbe Zelle daneben, wenn da nichts als Bild Beschreibung drin ist kann nicht gespeichert werden:

Code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim c As Range

For Each c In Worksheets("prüfprotokollnsw").Range("O289,O303")
If c = "" Then
MsgBox "Bild Typenschild & Metrologie-Kennzeichnung, sowie Bild Sicherungsmarke(n) muss eingefügt und im gelben Feld ausgewählt sein!"
Cancel = True
If Range("O289") = "" Then Range("O289").Activate
If Range("O303") = "" Then Range("O303").Activate
Exit For
End If
Next c
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

:)

MisterBurns · 20. September 2018

Wie wäre es mit Bild verlinken? Dann wird deine Datei gar nicht größer...

deko · 20. September 2018

Achso,
sorry habe ich nicht dabei geschrieben.

Das ganze wird nachher als pdf gespeichert und per Mail verschickt.

Die Bilder müssten als angezeigt werden.

MisterBurns · 20. September 2018

Nein, du hast mich falsch verstanden. Du kannst die Bilder verknüpfen (sorry, verlinken war ungeschickt gewählt) statt einbetten, d.h. sie werden ganz normal in der Exceldatei angezeigt, sind aber nicht wirklich drin vorhanden (nicht "physisch" wenn man so möchte).
Gerade wenn es dann als pdf weiterversendet wird, ist das ideal.

Code:

Sub Bild1()
Dim varBild As Variant
Dim Zelle As Range
Dim ScaleA As Double

Set Zelle = Range("B4") 'hier wird das Bild eingefügt
varBild = Application.GetOpenFilename(Title:="Test")

If varBild = False Then Exit Sub
ActiveSheet.Pictures.Insert(varBild).Select
With Selection.ShapeRange
.Top = Zelle.Top
.Left = Zelle.Left
' ScaleA = WorksheetFunction.Min(Zelle.Width / .Width, Zelle.Height / .Height)
' .Height = .Height * ScaleA
End With
Selection.Placement = xlMoveAndSize
Selection.PrintObject = True

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Die beiden auskommentierten Zeilen würden das Bild noch an die jeweilige Zelle anpassen.

Die Bilder bzw. Verknüpfung wieder zu löschen geht so:
Code:

Sub loeschen()
Dim Bild As Shape

For Each Bild In ActiveSheet.Shapes
If Not Intersect(Bild.TopLeftCell, Range("B4")) Is Nothing Then
Bild.Delete
End If
Next
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Muller2 · 20. September 2018

Hallo,

...und das kriegen wir sogar ohne Select hin...*tongue.gif* *cool.gif*
Code:

With ActiveSheet.Pictures.Insert(varBild)
.Top = Zelle.Top
.Left = Zelle.Left
' ScaleA = WorksheetFunction.Min(Zelle.Width / .Width, Zelle.Height / .Height)
' .Height = .Height * ScaleA
.Placement = xlMoveAndSize
.PrintObject = True
End With
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Gruß, Muller2

MisterBurns · 20. September 2018

Hm, ich dachte, das wäre einer der wenigen Fälle, wo das select notwendig ist. WWG...

Muller2 · 20. September 2018

Hallo Berni,

keine Sorge ging mir zunächst auch so *tongue.gif* , liegt wohl daran, daß das Picture-Objekt im Objektkatalog ausgeblendet ist, die Insert-Methode liefert nämlich genau das zurück und das Objekt besitzt alle nötigen Eigenschaften....

Gruß, Muller2

deko · 23. September 2018

Vielen Dank Euch allen!

Klappt bis jetzt sehr gut *biggrin.gif*

Eine Frage allerdings noch.

Ab und an (wirklich nicht immer) bekomm ich beim löschen allerdings diese Meldung (siehe Bild).

Die Range von dem Bild habe ich auf

Code:

Set Zelle = Range("B287", "U308")
varBild = Application.GetOpenFilename(Title:="Test")
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

geändert, da ich sonst mit der Größe nicht hinkomme.

MfG

deko · 26. September 2018

So, ich muss es jetzt noch einmal aus der Versenkung holen *biggrin.gif*

Hinbekommen habe ich jetzt alles so weit.

Eine Sache allerdings noch:

Es soll jetzt nicht gespeichert werden können solange die Bilder nicht angehangen worden sind.

Ist das Machbar?

Mein aktueller Code fürs einfügen ist:

Code:

Sub Bild1()
Dim varBild As Variant
Dim Zelle As Range
Dim ScaleA As Double

Set Zelle = Range("B318", "U339")
varBild = Application.GetOpenFilename(Title:="Test")

If varBild = False Then Exit Sub
ActiveSheet.Pictures.Insert(varBild).Select
With Selection.ShapeRange
.Top = Zelle.Top
.Left = Zelle.Left
ScaleA = WorksheetFunction.Min(Zelle.Width / .Width, Zelle.Height / .Height)
.Height = .Height * ScaleA
End With
Selection.Placement = xlMoveAndSize
Selection.PrintObject = True

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Sprich das Bild kommt in Zelle B318 (klappt auch *biggrin.gif*) und wenn da kein Bild ist, soll auch nicht gespeichjert werden können.

Momentan löse ich das wie folgt:

Code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim c As Range

For Each c In Worksheets("prüfprotokollswe").Range("K315")
If c = "" Then
MsgBox "Bild einfügen!"
Cancel = True
If Range("K315") = "" Then Range("K315").Activate
Exit For
End If
Next c
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Wie ihr seht, steht da K315.

K315 ist aber einfach nur eine Zelle für den Namen des Bildes.

Nicht sehr elegant das darüber abzufangen.

Cool wäre also eine Möglichkeit zu kontrollieren ob an der angegebenen Stelle ein Bild ist, oder nicht.

Danke schon mal *biggrin.gif*

MfG

Office: Bilder Hinzufügen, verkleinern und löschen

Bilder Hinzufügen, verkleinern und löschen

Bilder Hinzufügen, verkleinern und löschen

Bilder Hinzufügen, verkleinern und löschen

Bilder Hinzufügen, verkleinern und löschen

Bilder Hinzufügen, verkleinern und löschen - Similar Threads - Bilder Hinzufügen verkleinern

Hinzufügen oder Entfernen von Rahmen für Textfelder, Bilder und Formen

Video: Hinzufügen von Bildern

Bilder hinzufügen

Hinzufügen desselben Bilds oder Wasserzeichens auf jeder Folie

Hinzufügen eines Logos oder eines anderen Bilds

Hinzufügen von Bildern zu einer Kopf- oder Fußzeile

Hinzufügen von Bilder oder Dateien in Teams Meetings wo auch Gäste teilnehmen