Bilder an bestimmeter Stelle in VBA einfügen
11.09.2024 17:22:57
Theo
heute bin ich mir wieder mal nicht sicher ob Excel oder vielleicht doch mein Gehirn einen Bug hat. Mir geht es um das Sub InsertPictureToRange, das andere Macro simuliert nur den Aufruf. Die Idee ist nacheinander Bilder aus unterschiedlichen Links in einen bestimmten Bereich einzufügen.
In meinem "echten" Macro funktioniert das (speziell wenn ich das Debugge) wie erwartet. Läuft das Macro "unbeaufsichtitg" wird jedes Bild immer ein stück zu hoch eingefügt.
Je mehr Durchläufe stattfinden, desto mehr verschiebt sich die Position.
Der Range wird korrekt ermittelt, denn ich mache in meinem "echten" Makro sogar noch einen Rahmen um den Einfügebereich.
Ich habe auch schon propbiert eine kurze Pause nach dem Insert einzufügen, aber das macht auch keinen wirklichen Unterschied.
Hat jemand eine bessere Idee?
Danke
Theo
Sub BilderNacheinanderEinfügen()
Dim EinfuegeRng As Range
Dim Nummernlink As String
Dim HausNummer As Integer
Dim i As Long
Dim wsTest As Worksheet
Set wsTest = ActiveSheet
For i = 10 To 1000 Step 10
Set EinfuegeRng = wsTest.Range(wsTest.Cells(i + 2, 2), wsTest.Cells(i + 8, 4))
HausNummer = i / 10
wsTest.Range("A" & i).Value = "Hausnummer " & HausNummer
Nummernlink = "https://www.xyz.de/No/" & HausNummer
InsertPictureToRange Nummernlink, EinfuegeRng
Next i
Set EinfuegeRng = Nothing
Set wsTest = Nothing
End Sub
Sub InsertPictureToRange(PicLink As String, PasteRng As Range)
Dim PreView As Picture
Dim ws As Worksheet
'----------------------------------------------------------------------------------------------
'--- Füge Bild in PasteRng ein
'----------------------------------------------------------------------------------------------
Set ws = PasteRng.Worksheet
On Error Resume Next
Set PreView = ws.Pictures.Insert(PicLink)
On Error GoTo 0
'----------------------------------------------------------------------------------------------
'--- Höhe und Position Festlegen
'----------------------------------------------------------------------------------------------
If Not PreView Is Nothing Then
With PreView
.ShapeRange.LockAspectRatio = msoTrue
.Height = 0.98 * PasteRng.Height
.Top = PasteRng.Top + 0.01 * PasteRng.Height
.Left = PasteRng.Left + 0.01 * PasteRng.Width
.Placement = xlMoveAndSize
End With
End If
Set ws = Nothing
Set PreView = Nothing
End SubAnzeige