Projekt Bilder einfügen
23.11.2018 14:01:36
Vincent
derzeit versuche ich mich VBA mir ein wenig Arbeit zu erleichtern, da ich demnächst sehr viele Daten in Listen aktualisieren/eintragen muss. Da ich aber ehrlich gesagt kaum Ahnung von VBA habe, bin ich derzeit eine CopyCat. Nur leider komme ich derzeit trotz stundenlangem Suchen nicht auf das gewünschte Ergebnis.
Nun soll ich für diverse Listen Bilder und Akten(PDFs) (so um die Tausend) einfügen. Für die Bilder benutze ich derzeit:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
If Target.Row Mod 20 = 0 Then Exit Sub
On Error GoTo son
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture And shp.TopLeftCell.Address = Target.Offset(0, 2).Address Then shp. _
Delete
Next
If Target.Value "" And Dir("C:\Users\l0zkuni\Desktop\Vincent\TEST\" & Target.Value & ".jpg") _
= "" Then
'picture not there!
MsgBox Target.Value & " Doesn't exist!"
End If
ActiveSheet.Pictures.Insert("C:\Users\l0zkuni\Desktop\Vincent\TEST\" & Target.Value & ".jpg"). _
Select
Selection.Top = Target.Offset(0, 2).Top
Selection.Left = Target.Offset(0, 2).Left
With Selection.ShapeRange
.LockAspectRatio = msoFalse
.Height = Target.Offset(0, 2).Height
.Width = Target.Offset(0, 2).Width
.ZOrder msoBringToFront
End With
Target.Offset(1, 0).Select
son:
End Sub
Das funktioniert soweit gut. Schön wäre es noch, wenn in einer Zelle in Spalte B etwas geändert wird, sich das alte Bild von selbst löscht. Das geht aber zur Not manuell.
Nachdem ich das Bild eingefügt habe, verwende ich folgendes Modul, um das Bild zu vergrößern und zu verkleinern.
Sub gross()
With ActiveSheet.Shapes(Application.Caller)
.LockAspectRatio = msoTrue
.Height = .Height / 2
.Width = .Width / 2
.OnAction = "klein"
End With
End Sub
Sub klein()
With ActiveSheet.Shapes(Application.Caller)
.LockAspectRatio = msoTrue
.Height = .Height * 2
.Width = .Width * 2
.OnAction = "gross"
End With
End Sub Das würde ich gerne in Verbindung bringen. Es soll also automatisch jedem eingefügtem Bild das Makro zugewiesen werden. Hab mich schon mit if, with und call daran versucht, bekomme aber mit meinem begrenzten Wissen keine vernünftigen Bezüge hin.
Vielen Dank schon Mal im Voraus für eure Hilfe und Zeit :)
Besten Gruß,
Vincent