VBA Excel 1 zelfde foto invoegen in meerdere sheets

[royb73]

Beste,

Ik ben bezig om een VBA code te maken om 1 zelfde foto toe te voegen in alle sheets, behalve in sheets "Gegevens" en "settings". De foto moet in zelfde formaat en positie ingevoegd worden. Zie bijlage.

Locatie van foto is: C:\Temp\*.jpg. Het is de bedoeling dat de code eerst zoekt of er een foto aanwezig is of niet. Zo niet, dan zal ik dit met een message box aangeven dat dit ontbreekt.

Ik heb geprobeerd met range("foto") (=naamvak/ referentie) in de sheet toe te kennen, echter gaat dit bij 1 blad goed en de rest pakt ie niet.

Hoop dat jullie mij kunnen helpen.

Met vriendelijke groet,

Roy

Bekijk bijlage Kantoren1.xlsm

 

[OctaFish]

Ik zie geen code?

 

[royb73]

Beste Octafish,

Bijgaand de code. Sorry, vergat deze in de Excel document toe te voegen.

Sub TestInsertPictureInRange()
    InsertPictureInRange "C:\Temp\detail.jpg", _
        Range("foto")
End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Gegevens" And "Settings" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    ' determine positions
    With TargetCells
        t = .Top
        l = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
        .Width = w
        .Height = h
    End With
    Set p = Nothing
End Sub

 

[OctaFish]

Je range is gepind op één werkblad, en als je steeds naar dezelfde range verwijst, wordt de foto dus elke keer weer op dezelfde sheet geplakt. Ik vermoed dat je dan ook meer dan één exemplaar van je afbeelding krijgt te zien, maar dan op elkaar gestapeld. Ik zou dus een aparte range definiëren die het adres uit de foto range haalt en dat gebruikt.

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
Dim rng As Range
Dim ws As Worksheet, wb As Workbook

    Set wb = ActiveWorkbook
    Set rng = Range(TargetCells.AddressLocal)
        
    For Each ws In wb.Worksheets
        If Not ws.Name = "Gegevens" And Not ws.Name = "Settings" Then
            If Dir(PictureFileName) = "" Then Exit Sub
            ' import picture
            Set p = ws.Pictures.Insert(PictureFileName)
            ' determine positions
            With rng
                t = .Top
                l = .Left
                w = .Offset(0, .Columns.Count).Left - .Left
                h = .Offset(.Rows.Count, 0).Top - .Top
            End With
            ' position picture
            With p
                .Top = t
                .Left = l
                .Width = w
                .Height = h
            End With
        End If
    Next ws
    Set p = Nothing
End Sub

 

[royb73]

Beste Michel,

Ik krijg een foutmelding: Methode Range van object_Worksheet is mislukt.

Ik ben een beginner wat VBA betreft.

Mvg

Roy.

 

[OctaFish]

Waarschijnlijk bestaat de range "Foto" niet in je bestand. Hij ontbrak in ieder geval ook in jouw bestand, dus dat zou kunnen. Ik heb in de bijlage een werkende versie gezet, dus die zou bij jou ook moeten werken.

 

[royb73]

Perfect Michel.

Het werkt nu wel. Alleen hoe krijg ik de foto op de plaats van de bestaande foto en zelfde formaat?

Mvg

Roy

 

[royb73]

Michel,

indien ik de code 2 keren run, dan krijg ik 2 keren de foto's op elkaar. Hoe kan ik een code toevoegen, die de eerste foto verwijderd?

Mvg
Roy