foto vanuit excel naar word

[mrnico]

Hallo ik ben aan het probeer een deel uit een excel lijst automatische naar word te zetten.
echter loop ik tegen een uitdaging aan.
de foto werkt momenteel alleen als PAD plaats van rechtsteeks de foto uit de cel.
en de foto's kommen allemaal boven aan te staan plaats van in de regel die gecopieerd word

Sub ZetLijstEnFotoNaarWord()
    Dim wdApp As Object, wdDoc As Object
    Dim ws As Worksheet
    Dim laatsteRij As Long, i As Long
    Dim fotoPad As String
    


    Set ws = ThisWorkbook.Sheets("Lijst met punten")
    laatsteRij = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Start Word
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True
    Set wdDoc = wdApp.Documents.Add

    ' Lus door de Excel lijst (start bij rij 2, na de koptekst)
    For i = 2 To laatsteRij
        ' Tekst toevoegen
        wdDoc.Content.InsertAfter ws.Cells(i, 1).Value & vbCrLf
        wdDoc.Content.InsertAfter ws.Cells(i, 3).Value & vbCrLf
        wdDoc.Content.InsertAfter ws.Cells(i, 4).Value & vbCrLf
      

            
    
        

        ' Foto invoegen op basis van bestandspad in kolom 5 (E)

        fotoPad = ws.Cells(i, 5).Value
        If fotoPad <> "" And Dir(fotoPad) <> "" Then
            wdDoc.Content.InlineShapes.AddPicture Filename:=fotoPad, _
                LinkToFile:=False, SaveWithDocument:=True, Range:=wdDoc.Content
        End If
        
  

        ' Extra witregel tussen items
        wdDoc.Content.InsertAfter vbCrLf & "----------------------------------" & vbCrLf
    Next i

    MsgBox "Klaar met exporteren naar Word!"
End Sub

Ik hoop dat iemand mij kan helpen

 

[peter59]

Probeer deze code eens. Die code is absoluut niet van mij maar van AI Claude.
Maak eerst een kopie voordat je de code gebruikt.

Sub ZetLijstEnFotoNaarWord()
    Const wdCollapseEnd As Long = 0

    Dim wdApp As Object, wdDoc As Object
    Dim rng As Object
    Dim ws As Worksheet
    Dim laatsteRij As Long, i As Long
    Dim shp As Shape
    Dim fotoGevonden As Boolean

    Set ws = ThisWorkbook.Sheets("Lijst met punten")
    laatsteRij = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Start Word
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True
    Set wdDoc = wdApp.Documents.Add

    ' Eén Range-object dat we steeds naar het einde schuiven
    Set rng = wdDoc.Content
    rng.Collapse Direction:=wdCollapseEnd

    For i = 2 To laatsteRij

        ' --- Tekst toevoegen (steeds op de huidige eindpositie) ---
        rng.InsertAfter ws.Cells(i, 1).Value & vbCrLf
        rng.Collapse Direction:=wdCollapseEnd

        rng.InsertAfter ws.Cells(i, 3).Value & vbCrLf
        rng.Collapse Direction:=wdCollapseEnd

        rng.InsertAfter ws.Cells(i, 4).Value & vbCrLf
        rng.Collapse Direction:=wdCollapseEnd

        ' --- Foto zoeken die op deze rij in kolom E staat ---
        fotoGevonden = False
        For Each shp In ws.Shapes
            If Not shp.TopLeftCell Is Nothing Then
                If shp.TopLeftCell.Row = i And shp.TopLeftCell.Column = 5 Then
                    shp.Copy
                    rng.Paste
                    rng.Collapse Direction:=wdCollapseEnd
                    fotoGevonden = True
                    Exit For
                End If
            End If
        Next shp

        ' Fallback: als er toch een bestandspad in kolom E staat
        If Not fotoGevonden Then
            Dim fotoPad As String
            fotoPad = ws.Cells(i, 5).Value
            If fotoPad <> "" And Dir(fotoPad) <> "" Then
                wdDoc.InlineShapes.AddPicture Filename:=fotoPad, _
                    LinkToFile:=False, SaveWithDocument:=True, Range:=rng
                rng.Collapse Direction:=wdCollapseEnd
            End If
        End If

        ' --- Scheidingslijn ---
        rng.InsertAfter vbCrLf & "----------------------------------" & vbCrLf
        rng.Collapse Direction:=wdCollapseEnd

    Next i

    MsgBox "Klaar met exporteren naar Word!"
End Sub

Belangrijkste wijzigingen op een rij:

1. rng wordt na élke invoeging (tekst én foto) gecollapset naar het einde, zodat alles netjes na elkaar komt in plaats van vooraan.
2. Voor de foto wordt eerst gezocht naar een Shape op de rij (kolom E) via shp.TopLeftCell. Die wordt gekopieerd en met rng.Paste op de juiste plek geplakt.
3. Staat er toch nog een bestandspad in kolom E (geen shape gevonden), dan valt de code terug op de oude AddPicture-methode, nu met Range:=rng in plaats van Range:=wdDoc.Content.

Eén aandachtspunt:
shp.TopLeftCell.Column = 5 gaat ervan uit dat de afbeelding echt in kolom E begint. Staat de foto een beetje "scheef" over meerdere cellen, dan kun je die check versoepelen (bijv. alleen op Row matchen, of een bereik van kolommen toestaan).

 

[Enigmasmurf]

Nu kon ik toch echt niet laten om Claude's oplossing eens te bekijken, en neen, ik heb niet de indruk dat dit was waar TS naar zocht.

@mrnico,
Als ik het goed inschat moet er aan je eigen code niet zo veel veranderen.
Vervang

If fotoPad <> "" And Dir(fotoPad) <> "" Then
  wdDoc.Content.InlineShapes.AddPicture Filename:=fotoPad, _
    LinkToFile:=False, SaveWithDocument:=True, Range:=wdDoc.Content
End If

eens door

If fotoPad <> "" And Dir(fotoPad) <> "" Then
  Set einde = wdDoc.Content
  einde.collapse wdCollapseEnd
  wdDoc.Content.InlineShapes.AddPicture Filename:=fotoPad, _
    LinkToFile:=False, SaveWithDocument:=True, Range:=einde
End If

En o ja, "werkt momenteel alleen als PAD plaats van rechtsteeks de foto uit de cel", dat heb je natuurlijk zelf zo ingesteld met "fotoPad = ws.Cells(i, 5).Value"...