Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #16  
Old 12-31-2020, 10:51 PM
victorybadges victorybadges is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2013
Novice
Create Table for Multiple Pictures
 
Join Date: Dec 2020
Posts: 22
victorybadges is on a distinguished road
Default


perfect thanks
Reply With Quote
  #17  
Old 02-13-2021, 10:49 PM
victorybadges victorybadges is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2013
Novice
Create Table for Multiple Pictures
 
Join Date: Dec 2020
Posts: 22
victorybadges is on a distinguished road
Default

Dear Paul, had to revisit this as my Word updated itself and I lost my macros
I am back now where I was after a few hours of reconstructing.
The macro with the captions I still need a slight modification. For file names which seem to fit perfectly within the width of the column there appears to be no indenting, so if adjacent files names are of similar length they appear touching each other. Hope you can help.

This is my file at this stage

Code:
Sub Add_PicsinTable_with_Captions()
Application.ScreenUpdating = False
Dim 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 = CLng(InputBox("How Many Columns per Row?"))
RwHght = CentimetersToPoints(CSng(InputBox("What max row height for the pictures, in Centimeters (e.g. 5)?")))
ColWdth = CentimetersToPoints(CSng(InputBox("What max column width for the pictures, in Centimeters (e.g. 5)?")))
On Error GoTo 0
'Select and insert the Pics
With Application.FileDialog(msoFileDialogFilePicker)
  .Title = "Select image files and click OK"
  .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
  .FilterIndex = 2
  If .Show = -1 Then
    'Create a paragraph Style with 0 space before/after & centre-aligned
    On Error Resume Next
    With ActiveDocument
      .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
    'Add a 2-row by NumCols-column table to take the images
    Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
    With ActiveDocument.PageSetup
      TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      If TblWdth / NumCols < ColWdth Then ColWdth = 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:="Picture"
    For i = 1 To .SelectedItems.Count Step NumCols
      r = ((i - 1) / NumCols + 1) * 2 - 1
      'Format the rows
      Call FormatRows(oTbl, r, RwHght)
      For c = 1 To NumCols
        j = j + 1
        'Insert the Picture
        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
        'Get the Image name for the Caption
        StrTxt = Split(.SelectedItems(j), "")(UBound(Split(.SelectedItems(j), "")))
        StrTxt = "" & Split(StrTxt, ".")(0)
        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c).Range
            .Text = StrTxt
            If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _
              .Characters.First.Information(wdVerticalPositionRelativeToPage) Then
              .FitTextWidth = ColWdth - CentimetersToPoints(0.3)
            End If
        End With
        'Exit when we're done
        If j = .SelectedItems.Count Then Exit For
      Next
      'Add extra rows as needed
      If j < .SelectedItems.Count Then
        oTbl.Rows.Add
        oTbl.Rows.Add
      End If
    Next
  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 = "Caption"
  End With
End With
End Sub

Last edited by macropod; 02-13-2021 at 11:47 PM. Reason: Added code tags
Reply With Quote
  #18  
Old 02-14-2021, 04:12 AM
macropod's Avatar
macropod macropod is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,224
macropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant future
Default

Change this:
Code:
        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c).Range
            .Text = StrTxt
            If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _
              .Characters.First.Information(wdVerticalPositionRelativeToPage) Then
              .FitTextWidth = ColWdth - CentimetersToPoints(0.3)
            End If
        End With
to this:
Code:
        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c)
          .LeftPadding = CentimetersToPoints(0.15)
          .RightPadding = CentimetersToPoints(0.15)
          With .Range
            .Text = StrTxt
            If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _
              .Characters.First.Information(wdVerticalPositionRelativeToPage) Then
              .FitTextWidth = ColWdth - CentimetersToPoints(0.3)
            End If
          End With
        End With
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #19  
Old 02-14-2021, 02:12 PM
victorybadges victorybadges is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2013
Novice
Create Table for Multiple Pictures
 
Join Date: Dec 2020
Posts: 22
victorybadges is on a distinguished road
Default

thank you Paul, but this has revealed two issues

firstly can it centre first and then do the padding as this is more evident in small file names that there is no centring of the caption

secondly I noticed a different issue in that the images in the 2nd row onwards are not centred, I tested it several times (this does not happen with my macro with no captions ?)

regards Nick
Reply With Quote
  #20  
Old 02-14-2021, 06:24 PM
macropod's Avatar
macropod macropod is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,224
macropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant future
Default

Quote:
Originally Posted by victorybadges View Post
can it centre first and then do the padding as this is more evident in small file names that there is no centring of the caption
I already showed you how to center the Caption Style in post #15.
Quote:
Originally Posted by victorybadges View Post
the images in the 2nd row onwards are not centred, I tested it several times (this does not happen with my macro with no captions ?)
Not when you use the code I've supplied. Apparently your mods have resulted in the centering applying to the wrong rows.

My preferred approach would be to configure the entire table with a suitable amount of cell padding all round plus, of course, the centering of the Caption Style. For example:
Code:
Sub Add_PicsinTable_with_Captions()
Application.ScreenUpdating = False
Dim 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, RowHght As Single, ColWdth As Single
Dim HPad As Single, VPad As Single, PicHght As Single, PicWdth As Single
HPad = CentimetersToPoints(0.15):   VPad = CentimetersToPoints(0.05)
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
RowHght = CentimetersToPoints(CSng(InputBox("What max row height for the pictures, in Centimeters (e.g. 5)?")))
ColWdth = CentimetersToPoints(CSng(InputBox("What max column width for the pictures, in Centimeters (e.g. 5)?")))
On Error GoTo 0
PicHght = RowHght - VPad * 2: PicWdth = ColWdth - HPad * 2
'MsgBox "PicWdth: " & PointsToCentimeters(PicWdth) & vbTab & "ColWdth: " & PointsToCentimeters(ColWdth)
'MsgBox "PicHght: " & PointsToCentimeters(PicHght) & vbTab & "RowHght: " & PointsToCentimeters(RowHght)
'Select and insert the Pics
With Application.FileDialog(msoFileDialogFilePicker)
  .Title = "Select image files and click OK"
  .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
  .FilterIndex = 2
  If .Show = -1 Then
    'Create a paragraph Style with 0 space before/after & centre-aligned
    On Error Resume Next
    With ActiveDocument
      .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("Caption").ParagraphFormat.Alignment = wdAlignParagraphCenter
    End With
    'Add a 2-row by NumCols-column table to take the images
    Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
    With ActiveDocument.PageSetup
      TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      If TblWdth / NumCols < ColWdth Then ColWdth = TblWdth / NumCols
    End With
    With oTbl
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = VPad
      .BottomPadding = VPad
      .LeftPadding = HPad
      .RightPadding = HPad
      .Spacing = 0
      .Columns.Width = ColWdth
      .Borders.Enable = True
      .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
    End With
    CaptionLabels.Add Name:="Picture"
    For i = 1 To .SelectedItems.Count Step NumCols
      r = ((i - 1) / NumCols + 1) * 2 - 1
      'Format the rows
      Call FormatRows(oTbl, r, RowHght)
      For c = 1 To NumCols
        j = j + 1
        'Insert the Picture
        Set iShp = ActiveDocument.InlineShapes.AddPicture( _
          FileName:=.SelectedItems(j), LinkToFile:=False, _
          SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
        With iShp
          .LockAspectRatio = True
          If .Width < PicWdth Then .Width = PicWdth
          If .Height > PicHght Then .Height = PicHght
        End With
        'Get the Image name for the Caption
        StrTxt = Split(.SelectedItems(j), "")(UBound(Split(.SelectedItems(j), "")))
        StrTxt = Split(Split(StrTxt, "\")(UBound(Split(StrTxt, "\"))), ".")(0)
        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c)
          With .Range
            .Text = StrTxt
            If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _
              .Characters.First.Information(wdVerticalPositionRelativeToPage) Then
              .FitTextWidth = PicWdth
            End If
          End With
        End With
        'Exit when we're done
        If j = .SelectedItems.Count Then Exit For
      Next
      'Add extra rows as needed
      If j < .SelectedItems.Count Then
        oTbl.Rows.Add
        oTbl.Rows.Add
      End If
    Next
  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"
  End With
  With .Rows(x + 1)
    .Height = CentimetersToPoints(0.5)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Caption"
  End With
End With
End Sub
Note that I've also chosen to omit the filepaths from the captions.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #21  
Old 02-14-2021, 07:00 PM
victorybadges victorybadges is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2013
Novice
Create Table for Multiple Pictures
 
Join Date: Dec 2020
Posts: 22
victorybadges is on a distinguished road
Default

seems to work well
I have changed the padding to zero in this line
HPad = CentimetersToPoints(0.15): VPad = CentimetersToPoints(0.05) and seems to work fine
I have left this line as is though 0 x 2 may be a problem
I have tested it with 30 black images and I am getting a white line down at the end of the 3rd column going all the way down, is this a bug in word
I also need to have it so it does not allow break across pages please
Reply With Quote
  #22  
Old 02-14-2021, 07:08 PM
macropod's Avatar
macropod macropod is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,224
macropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant future
Default

By setting VPad to 0, you may end up with pics overlapping the top/bottom cell borders. By setting HPad to 0, you'll be back to your previous issue with text occupying the full cell width.

I cannot see how you could end up with rows being split across a page break, as all you have in each cell is either a single pic or a single line of text. Plus, unless you've modified your version of the Caption Style to have the 'Keep with Next' attribute, captions and their pics would be forced to appear on the same page.

The display issue may be related to your display driver.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #23  
Old 02-14-2021, 07:39 PM
victorybadges victorybadges is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2013
Novice
Create Table for Multiple Pictures
 
Join Date: Dec 2020
Posts: 22
victorybadges is on a distinguished road
Default

whatever I do I am having an issue
now the images are not being reduced to fit the box so I am back to my original script and will forget about the padding, just now need centring of the caption
I will give it a go and if I cannot succeed will let you know
Reply With Quote
  #24  
Old 02-14-2021, 08:34 PM
macropod's Avatar
macropod macropod is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,224
macropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant future
Default

The code in post #20 does all of that.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #25  
Old 02-15-2021, 12:34 AM
victorybadges victorybadges is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2013
Novice
Create Table for Multiple Pictures
 
Join Date: Dec 2020
Posts: 22
victorybadges is on a distinguished road
Default

thank you, I will work through it
Reply With Quote
  #26  
Old 02-15-2021, 02:09 AM
victorybadges victorybadges is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2013
Novice
Create Table for Multiple Pictures
 
Join Date: Dec 2020
Posts: 22
victorybadges is on a distinguished road
Default

thank you so much for your help and persistence.
I can comfortably say the template looks great.
thank you
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
How do I change multiple pictures in Word 2016 to all new pictures that appear in a specified order? chaz Word VBA 7 07-11-2018 03:57 AM
Create Table for Multiple Pictures Mail merge from excel - need to create sheets and create a table bluenosebex Mail Merge 5 08-02-2015 05:34 PM
Create multiple copies of same email in multiple folders gaker10 Outlook 0 10-06-2014 07:44 AM
create fields with multiple lines - fix column width in table expert4knowledge Word 4 02-14-2014 01:06 PM
Resize multiple pictures in a Word 2010 table JBA479 Word VBA 1 01-24-2014 08:51 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 01:41 PM.


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