meerdere afbeeldingen invoegen in doc

[marleen009]

Hallo,

Ik moet dikwijls verslagen maken met veel foto's erin. Nu zit ik met een uitzonderlijk verslag en 1500 foto's die hierin moeten komen. Ik zou deze foto's in een mooi overzicht willen hebben en met tekst of nummering erbij.
Ik neem aan dat hiervoor de enigste oplossing een macro is? Spijtig genoeg weet ik hier niet zoveel over.
Is dit inderdaad de enigste oplossing? Heeft er iemand zo een macro??
What to do?
Ik ben maar aan het googlen voor een oplossing, maar misschien begin ik er beter gewoon aan ipv mijn tijd hieraan verder te verspillen...

Alle hulp welkom!!!

 

[hoogteijling]

Is dit misschien een start ?
http://lmgtfy.com/?q=insert+multiple+photo's+in+word
http://www.wordbanter.com/showthread.php?t=144264
http://blog.dumbleton.info/2011/10/...ly-into-microsoft-word-2007-and-2010-updated/

Groeten Marcel

 

[marleen009]

Yes!!! Heb een goede macro gevonden, Thanxx to Marcel :thumb::thumb:

Sub InsertMultipleImages()
 Dim fd As FileDialog
 Dim oTable As Table
 Dim sNoDoc As String
 Dim vrtSelectedItem As Variant
 If Documents.Count = 0 Then
 sNoDoc = MsgBox(" " & _
 "No document open!" & vbCr & vbCr & _
 "Do you wish to create a new document to hold the images?", _
 vbYesNo, "Insert Images")
 If sNoDoc = vbYes Then
 Documents.Add
 Else
 Exit Sub
 End If
 End If
 'add a 1 row 2 column table to take the images
 Set oTable = Selection.Tables.Add(Selection.Range, 1, 2)
 oTable.AutoFitBehavior (wdAutoFitFixed)
 Set fd = Application.FileDialog(msoFileDialogFilePicker)
 With fd
 .Title = "Select image files and click OK"
 .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
 .FilterIndex = 2
 If .Show = -1 Then
 oTable.Cell(1, 1).Select
 For Each vrtSelectedItem In .SelectedItems
 With Selection
 .InlineShapes.AddPicture FileName:= _
 vrtSelectedItem _
 , LinkToFile:=False, SaveWithDocument:=True, _
 Range:=Selection.Range
 .MoveRight Unit:=wdCell
 End With
 Next vrtSelectedItem
 Else
 End If
 End With
 If Len(oTable.Rows.Last.Cells(1).Range) = 2 Then
 oTable.Rows.Last.Delete
 End If
 Set fd = Nothing
 End Sub

Het enigste wat ik nodig heb is dat de benaming van de foto er mee op komt te staan of dat ik tekst bij de foto kan zetten...
Nu heb ik 2 kolommen en 4 foto's per blz. Dit zouden er 6 mogen zijn of 8...
Weet iemand hoe ik dit aan kan passen?

Nog eens bedankt Marcel!

 

[hoogteijling]

Fijn voor je
Succes verder

Groeten Marcel

 

[marleen009]

meerdere afbeeldingen invoegen in Word2010 met macro, hulp met macro nodig...

Weet iemand hoe ik dit kan aanpassen zodat ik automatisch meerdere foto's per blad ingevoegd krijg??

Sub InsertMultipleImages()
 Dim fd As FileDialog
 Dim oTable As Table
 Dim sNoDoc As String
 Dim vrtSelectedItem As Variant
 If Documents.Count = 0 Then
 sNoDoc = MsgBox(" " & _
 "No document open!" & vbCr & vbCr & _
 "Do you wish to create a new document to hold the images?", _
 vbYesNo, "Insert Images")
 If sNoDoc = vbYes Then
 Documents.Add
 Else
 Exit Sub
 End If
 End If
 'add a 1 row 2 column table to take the images
 Set oTable = Selection.Tables.Add(Selection.Range, 1, 2)
 oTable.AutoFitBehavior (wdAutoFitFixed)
 Set fd = Application.FileDialog(msoFileDialogFilePicker)
 With fd
 .Title = "Select image files and click OK"
 .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
 .FilterIndex = 2
 If .Show = -1 Then
 oTable.Cell(1, 1).Select
 For Each vrtSelectedItem In .SelectedItems
 With Selection
 .InlineShapes.AddPicture FileName:= _
 vrtSelectedItem _
 , LinkToFile:=False, SaveWithDocument:=True, _
 Range:=Selection.Range
 .MoveRight Unit:=wdCell
 End With
 Next vrtSelectedItem
 Else
 End If
 End With
 If Len(oTable.Rows.Last.Cells(1).Range) = 2 Then
 oTable.Rows.Last.Delete
 End If
 Set fd = Nothing
 End Sub

 

[huijb]

@marleen009 code dient tussen de codetags te staan. Denk daar aan de volgende keer. Je doet er de helpers er een groot plezier mee.

 

[marleen009]

ok bedankt huijb, sorry helpers...

 

[OctaFish]

Wat is je vraag eigenlijk? De code doet het prima, en maakt een tabel aan met twee kolommen waar de afbeeldingen in komen. Dus je hebt al werkende code. Wil je meer kolommen, dan hoef je alleen maar het aantal kolommen te verhogen 9 Set oTable = Selection.Tables.Add(Selection.Range, 1, 6) bijvoorbeeld voor 6 kolommen).

 

[OctaFish]

Met een extra stukje code kun je de naam van de afbeelding nog toevoegen onder de foto's:

Sub InsertMultipleImages()
Dim fd As FileDialog
Dim oTable As Table
Dim sNoDoc As String
Dim itm As Variant, [B]tmp As Variant[/B]

    If Documents.Count = 0 Then
        sNoDoc = MsgBox(" " & "No document open!" & vbCr & vbCr _
        & "Do you wish to create a new document to hold the images?", _
        vbYesNo, "Insert Images")
        If sNoDoc = vbYes Then
            Documents.Add
        Else
            Exit Sub
        End If
    End If
    
    'add a 1 row 2 column table to take the images
    Set oTable = Selection.Tables.Add(Selection.Range, 1, 3)
    oTable.AutoFitBehavior (wdAutoFitFixed)
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "Select image files and click OK"
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
        .FilterIndex = 2
        If .Show = -1 Then
            oTable.Cell(1, 1).Select
            For Each itm In .SelectedItems
                With Selection
                    .InlineShapes.AddPicture FileName:=itm, _
                    LinkToFile:=False, SaveWithDocument:=True, Range:=Selection.Range
                    [B]tmp = Split(itm, "\")
                    .MoveRight Unit:=wdCharacter
                    .TypeText vbCrLf & tmp(UBound(tmp))[/B]
                    .MoveRight Unit:=wdCell
                End With
            Next itm
        End If
    End With
    
    If Len(oTable.Rows.Last.Cells(1).Range) = 2 Then
        oTable.Rows.Last.Delete
    End If
    Set fd = Nothing

End Sub