Microsoft Office Forums

Go Back   Microsoft Office Forums > >
Reload this Page Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Create Table for Multiple Pictures. 1 picture, 1 table and space between tables
Register FAQ

Reply
 
Thread Tools Display Modes
  #1  
Old 03-05-2022, 03:16 AM
gorkac gorkac is offline Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Windows 10 Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Office 2019
Banned
Create Table for Multiple Pictures. 1 picture, 1 table and space between tables 		 
Join Date: Jul 2021
Location: Usa
Posts: 62
gorkac is on a distinguished road
Default Create Table for Multiple Pictures. 1 picture, 1 table and space between tables
Split from: https://www.msofficeforums.com/word-...-pictures.html


My intention is that if more than one image was selected, one table by image. Also, I have added a line what I like it, but and I would like to remove only the outer edge, is it possible?

I would like it to stay like this:



Anyway, I would like that if I choose several images, they have space between them. I don't know where I have to put the line of code to create a space between one table and the next.

Code:
Code:
Sub AddPics()
Application.ScreenUpdating = False
Dim Stl As Style, i As Long, j As Long, c As Long, r As Long, NumCols As Long, iShp As InlineShape
Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single, ColWdth As Single
On Error GoTo ErrExit

NumCols = 1 'CLng(InputBox("Cuantas columnas por fila?"))
RwHght = CentimetersToPoints(8)  '(CSng(InputBox("¿Altura maxima de la fila?")))
On Error GoTo 0

'Selecciona e inserta fotos
With Application.FileDialog(msoFileDialogFilePicker)
  .Title = "Seleccion de imagenes y click en Abrir"
  .Filters.Add "Imagenes", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
  .FilterIndex = 2
  If .Show = -1 Then
  
    'Crea un Estilo de parrafo con 0 espacios antes/despues y alineado al centro.
    With ActiveDocument
      On Error Resume Next
      Set Stl = .Styles("TblPic")
      If Stl Is Nothing Then Set Stl = .Styles.Add(Name:="TblPic", Type:=wdStyleTypeParagraph)
      On Error GoTo 0
      With .Styles("TblPic").ParagraphFormat
        .Alignment = wdAlignParagraphCenter
        .KeepWithNext = True
        .SpaceAfter = 0
        .SpaceBefore = 0
      End With
    End With
    
    'Agregue una tabla de 2 filas por NumCols-column para colocar las imágenes
    Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
    With ActiveDocument.PageSetup
      TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      ColWdth = CentimetersToPoints(15) 'TblWdth / NumCols
    End With
    With oTbl
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = 0
      .BottomPadding = 0
      .LeftPadding = 0
      .RightPadding = 0
      .Spacing = 0
      .Columns.Width = ColWdth
      .Borders.Enable = True
    End With
    CaptionLabels.Add Name:="Fotografía nº"
    For i = 1 To .SelectedItems.Count Step NumCols
      r = ((i - 1) / NumCols + 1) * 2 - 1
      
      'Formato de filas
Call FormatRows(oTbl, r, RwHght)
      For c = 1 To NumCols
        j = j + 1
        ActiveDocument.Tables(1).Spacing = 9
        'Inserta la foto
        Set iShp = ActiveDocument.InlineShapes.AddPicture( _
          FileName:=.SelectedItems(j), LinkToFile:=False, _
          SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
        With iShp
          .LockAspectRatio = True
          If (.Width < ColWdth) And (.Height < RwHght) Then
            .Width = ColWdth
            If .Height > RwHght Then .Height = RwHght
          End If
        End With
        
        'Obtener el nombre de la imagen para el pie de foto
        StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
        StrTxt = ": " & Split(StrTxt, ".")(0)
        
        'Inserta el título Caption en la fila debajo de la imagen
        With oTbl.Cell(r + 1, c).Range
          .InsertBefore vbCr
          .Characters.First.InsertCaption _
          Label:="Fotografía nº", Title:=StrTxt, _
          Position:=wdCaptionPositionBelow, ExcludeLabel:=False
          .Characters.First = vbNullString
          .Characters.Last.Previous = vbNullString
        End With
        
        'Salir cuando hayamos terminado
        If j = .SelectedItems.Count Then Exit For
      Next
      
      'Agregue filas adicionales según sea necesario
      If j < .SelectedItems.Count Then
        oTbl.Rows.Add
        oTbl.Rows.Add
      End If
    Next
'    oTbl.ConvertToText
  Else
  End If
End With
ErrExit:
Application.ScreenUpdating = True
End Sub

Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
With oTbl
  With .Rows(x)
    .Height = Hght
    .HeightRule = wdRowHeightExactly
    .Range.Style = "TblPic"
    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
    
  End With
  With .Rows(x + 1)
    .Height = CentimetersToPoints(0.5)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Normal"
    
  End With
End With
End Sub
Last edited by macropod; 03-05-2022 at 07:06 PM. Reason: Split thread & delete duplicate
Reply With Quote
  #2  
Old 03-05-2022, 07:41 PM
macropod's Avatar
macropod macropod is offline Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Windows 10 Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Office 2016
Administrator
  
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,369
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default
The code requires multiple changes for that. Try:

Code:
Sub AddPics()
Application.ScreenUpdating = False
Dim Stl As Style, i As Long, j As Long, c As Long, r As Long, NumCols As Long, iShp As InlineShape
Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single, ColWdth As Single
On Error GoTo ErrExit

NumCols = 1 'CLng(InputBox("Cuantas columnas por fila?"))
RwHght = CentimetersToPoints(8)  '(CSng(InputBox("¿Altura maxima de la fila?")))
On Error GoTo 0

'Selecciona e inserta fotos
With Application.FileDialog(msoFileDialogFilePicker)
  .Title = "Seleccion de imagenes y click en Abrir"
  .Filters.Add "Imagenes", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
  .FilterIndex = 2
  If .Show = -1 Then
  
    'Crea un Estilo de parrafo con 0 espacios antes/despues y alineado al centro.
    With ActiveDocument
      On Error Resume Next
      Set Stl = .Styles("TblPic")
      If Stl Is Nothing Then Set Stl = .Styles.Add(Name:="TblPic", Type:=wdStyleTypeParagraph)
      On Error GoTo 0
      With .Styles("TblPic").ParagraphFormat
        .Alignment = wdAlignParagraphCenter
        .KeepWithNext = True
        .SpaceAfter = 0
        .SpaceBefore = 0
      End With
      .Styles(wdStyleNormal).ParagraphFormat.SpaceBefore = 0
    End With
    
    'Agregue una tabla de 2 filas por NumCols-column para colocar las imágenes
    Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=3, NumColumns:=NumCols)
    With ActiveDocument.PageSetup
      TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      ColWdth = CentimetersToPoints(15) 'TblWdth / NumCols
    End With
    With oTbl
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = 0
      .BottomPadding = 0
      .LeftPadding = 0
      .RightPadding = 0
      .Spacing = 0
      .Columns.Width = ColWdth
      .Borders.Enable = True
      '.Spacing = 9
    End With
    CaptionLabels.Add Name:="Fotografía nº"
    For i = 1 To .SelectedItems.Count Step NumCols
      r = ((i - 1) / NumCols + 1) * 3 - 2
      
      'Formato de filas
      Call FormatRows(oTbl, r, RwHght)
      For c = 1 To NumCols
        j = j + 1
        'Inserta la foto
        Set iShp = ActiveDocument.InlineShapes.AddPicture( _
          FileName:=.SelectedItems(j), LinkToFile:=False, _
          SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
        With iShp
          .LockAspectRatio = True
          If (.Width < ColWdth) And (.Height < RwHght) Then
            .Width = ColWdth
            If .Height > RwHght Then .Height = RwHght
          End If
        End With
        
        'Obtener el nombre de la imagen para el pie de foto
        StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
        StrTxt = ": " & Split(StrTxt, ".")(0)
        
        'Inserta el título Caption en la fila debajo de la imagen
        With oTbl
          With .Cell(r + 1, c)
            .Borders(wdBorderLeft).Visible = False
            .Borders(wdBorderRight).Visible = False
          End With
          With .Cell(r + 2, c).Range
            .InsertBefore vbCr
            .Characters.First.InsertCaption Label:="Fotografía nº", Title:=StrTxt, _
              Position:=wdCaptionPositionBelow, ExcludeLabel:=False
            .Characters.First = vbNullString
            .Characters.Last.Previous = vbNullString
          End With
        End With
        
        'Salir cuando hayamos terminado
        If j = .SelectedItems.Count Then Exit For
      Next
      
      'Agregue filas adicionales según sea necesario
      If j < .SelectedItems.Count Then
        oTbl.Rows.Add
        oTbl.Rows.Add
        oTbl.Rows.Add
      End If
    Next
'    oTbl.ConvertToText
    With oTbl
      For r = .Rows.Count - 2 To 3 Step -3
        .Split .Rows(r)
      Next
    End With
  Else
  End If
End With
ErrExit:
Application.ScreenUpdating = True
End Sub

Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
With oTbl
  With .Rows(x)
    .Height = Hght
    .HeightRule = wdRowHeightExactly
    .Range.Style = "TblPic"
    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
  End With
  With .Rows(x + 1)
    .Height = CentimetersToPoints(0.5)
    .HeightRule = wdRowHeightExactly
    .Range.Style = wdStyleNormal
  End With
  With .Rows(x + 2)
    .Height = CentimetersToPoints(0.5)
    .HeightRule = wdRowHeightExactly
    .Range.Style = wdStyleNormal
    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
  End With
End With
End Sub
PS: Please don't post the same question in multiple threads.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #3  
Old 03-05-2022, 11:58 PM
gorkac gorkac is offline Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Windows 10 Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Office 2019
Banned
Create Table for Multiple Pictures. 1 picture, 1 table and space between tables 		 
Join Date: Jul 2021
Location: Usa
Posts: 62
gorkac is on a distinguished road
Default
WOW, It works perfect. Thanks a lot.
Could you explain to me what these lines of code do? I execute it step by step and still I don't understand it very well:
Code:
With oTbl
      For r = .Rows.Count - 2 To 3 Step -3
        .Split .Rows(r)
      Next
    End With
And these lines, what exactly do they count?:
Code:
For i = 1 To .SelectedItems.Count Step NumCols
      r = ((i - 1) / NumCols + 1) * 3 - 2
      MsgBox r
Last edited by gorkac; 03-06-2022 at 12:44 AM. Reason: One more question.
Reply With Quote
  #4  
Old 03-06-2022, 01:12 AM
gorkac gorkac is offline Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Windows 10 Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Office 2019
Banned
Create Table for Multiple Pictures. 1 picture, 1 table and space between tables 		 
Join Date: Jul 2021
Location: Usa
Posts: 62
gorkac is on a distinguished road
Default
One last question please.
Bold this part of the only:
Code:
    CaptionLabels.Add Name:="Fotografía nº"
    For i = 1 To .SelectedItems.Count Step NumCols
      r = ((i - 1) / NumCols + 1) * 3 - 2
      
      'Formato de filas
      Call FormatRows(oTbl, r, RwHght)
      For c = 1 To NumCols
        j = j + 1
        'Inserta la foto
        Set iShp = ActiveDocument.InlineShapes.AddPicture( _
          FileName:=.SelectedItems(j), LinkToFile:=False, _
          SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
        With iShp
          .LockAspectRatio = True
          If (.Width < ColWdth) And (.Height < RwHght) Then
            .Width = ColWdth
            If .Height > RwHght Then .Height = RwHght
          End If
        End With
        
        'Obtener el nombre de la imagen para el pie de foto
        StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
        StrTxt = ": " & Split(StrTxt, ".")(0)
So that only these parts remains in bold:
"Fotografía nº 1: xxxxx"
"Fotografía nº 2: xxxxx"
"Fotografía nº 3: xxxxx" and so
Reply With Quote
  #5  
Old 03-06-2022, 01:50 AM
macropod's Avatar
macropod macropod is offline Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Windows 10 Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Office 2016
Administrator
  
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,369
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default
Quote:
Could you explain to me what these lines of code do?
1. Try deleting or commenting-out:
Code:
        .Split .Rows(r)
and see what happens.

2. The line:
Code:
      r = ((i - 1) / NumCols + 1) * 3 - 2
tells Word how many rows to go down on each iteration.

Quote:
Bold this part of the only:
After:
Code:
            .Characters.Last.Previous = vbNullString
insert:
Code:
            .Collapse wdCollapseStart
            .MoveEndUntil ":"
            .End = .End + 1
            .Style = wdStyleStrong
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #6  
Old 03-07-2022, 03:11 AM
gorkac gorkac is offline Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Windows 10 Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Office 2019
Banned
Create Table for Multiple Pictures. 1 picture, 1 table and space between tables 		 
Join Date: Jul 2021
Location: Usa
Posts: 62
gorkac is on a distinguished road
Default
It works perfect, THANKS ¡¡¡¡
One last request, how do I make more space where I indicate with the arrow?
Screenshot_20220307-120413_Samsung Internet Beta.jpg
Last edited by gorkac; 03-07-2022 at 04:41 AM. Reason: One more question.
Reply With Quote
  #7  
Old 03-07-2022, 02:40 PM
macropod's Avatar
macropod macropod is offline Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Windows 10 Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Office 2016
Administrator
  
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,369
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default
After:
Code:
        .Split .Rows(r)
you could insert something like:
Code:
        .Range.Characters.Last.Next.ParagraphFormat.SpaceAfter = 18
where the '18' specifies the space after setting (in points) of the paragraph that separates each of the tables.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #8  
Old 03-08-2022, 03:11 AM
gorkac gorkac is offline Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Windows 10 Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Office 2019
Banned
Create Table for Multiple Pictures. 1 picture, 1 table and space between tables 		 
Join Date: Jul 2021
Location: Usa
Posts: 62
gorkac is on a distinguished road
Default
Yes, its, certain.
One last thing, since the work is perfect and I don't bother you anymore. Is it possible to change the style of the second row?

Captura.PNG
Reply With Quote
  #9  
Old 03-08-2022, 07:30 PM
macropod's Avatar
macropod macropod is offline Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Windows 10 Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Office 2016
Administrator
  
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,369
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default
It would have been helpful had you specified all requirements up front.

Replace:
Code:
    With oTbl
      For r = .Rows.Count - 2 To 3 Step -3
        .Split .Rows(r)
        .Range.Characters.Last.Next.ParagraphFormat.SpaceAfter = 18
      Next
    End With
with:
Code:
    With oTbl
      For r = .Rows.Count To 1 Step -3
        With .Rows(.Rows.Count).Borders
          .OutsideLineStyle = wdLineStyleDouble
          .OutsideColorIndex = wdGreen
        End With
        If .Rows.Count > 3 Then .Split .Rows(r - 2)
        .Range.Characters.Last.Next.ParagraphFormat.SpaceAfter = 18
      Next
    End With
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #10  
Old 03-11-2022, 05:12 AM
gorkac gorkac is offline Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Windows 10 Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Office 2019
Banned
Create Table for Multiple Pictures. 1 picture, 1 table and space between tables 		 
Join Date: Jul 2021
Location: Usa
Posts: 62
gorkac is on a distinguished road
Default
I don't know how to thank you for your help. Requests are improvements that occur to me.
Quote:
Originally Posted by macropod View Post
It would have been helpful had you specified all requirements up front.
Reply With Quote
Reply

Tags
solved

« Previous Thread | Next Thread »


Similar Threads
Thread Thread Starter Forum Replies Last Post
Stack multiple tables on top of each other in a single table Remko Excel 2 04-18-2021 04:18 AM
Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Create Table for Multiple Pictures victorybadges Word VBA 4 12-25-2020 02:11 PM
How to compile text from multiple tables into a cell in a nested table jrooney7 Word VBA 2 03-11-2019 07:55 AM
Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Resize multiple pictures in a Word 2010 table JBA479 Word VBA 1 01-24-2014 08:51 PM
Create Table for Multiple Pictures. 1 picture, 1 table and space between tables Copy table cell formatting across multiple cells / tables pakistanray Word Tables 2 10-31-2011 08:07 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 09:46 PM.

Contact Us - Privacy Statement - Top

Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2025, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2025 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft