Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 12-24-2020, 12:30 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 Create Table for Multiple Pictures

Dear macropod



I literally stumbled onto the brilliant AddPics macro in https://www.msofficeforums.com/word-...es-1-page.html. I was actually searching for ways of doing this. It will save me so much time. Thank you. My question is can you advise on how to run it without captions please. thank you

Edit: just to clarify, I don't want a caption line either, simply a table full of photos as I have 400 photos and the images do not require a caption.

Last edited by victorybadges; 12-24-2020 at 03:19 PM. Reason: additional clarification
Reply With Quote
  #2  
Old 12-24-2020, 11:54 PM
macropod's Avatar
macropod macropod is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2010
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 for that is quite different:
Code:
Sub AddPicsNoCaption()
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 height 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 1-row by NumCols-column table to take the images
    Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=1, NumColumns:=NumCols)
    With ActiveDocument.PageSetup
      TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      ColWdth = TblWdth / NumCols
    End With
    With oTbl
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = 0
      .BottomPadding = 0
      .LeftPadding = 0
      .RightPadding = 0
      .Spacing = 0
      .Columns.Width = ColWdth
      .Rows.Height = RwHght
      .Rows.HeightRule = wdRowHeightExactly
      .Range.Style = "TblPic"
      .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
      .Borders.Enable = True
    End With
    For i = 1 To .SelectedItems.Count Step NumCols
      r = ((i - 1) / NumCols + 1) * 2 - 1
      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
        If j = .SelectedItems.Count Then Exit For
      Next
      'Add extra rows as needed
      If j < .SelectedItems.Count Then
        oTbl.Rows.Add
      End If
    Next
  Else
  End If
End With
ErrExit:
Application.ScreenUpdating = True
End Sub
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #3  
Old 12-25-2020, 01:20 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

Merry Xmas Macropod, this is the best Xmas present, much appreciated.
I have tested the macro and it works wonderfully except for 1 thing which can be fixed manually. The images are not centred as the cell margins are not set to zero. (PS I used fixed width columns)

As I use varying fixed column widths in different tables is there a way of enabling a fixed width question to be prompted on run time to save me from editing the macro each time. thank you kindly

many thanks
Reply With Quote
  #4  
Old 12-25-2020, 01:54 PM
macropod's Avatar
macropod macropod is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2010
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
I have tested the macro and it works wonderfully except for 1 thing which can be fixed manually. The images are not centred as the cell margins are not set to zero. (PS I used fixed width columns)
Unless you have some default set up with different left/right and/or top/bottom margins, the images cannot but be centered in the cells. nevertheless, I've added code to eliminate all cell margins.
Quote:
Originally Posted by victorybadges View Post
As I use varying fixed column widths in different tables is there a way of enabling a fixed width question to be prompted on run time to save me from editing the macro each time.
After:
Code:
RwHght = CentimetersToPoints(CSng(InputBox("What max height for the pictures, in Centimeters (e.g. 5)?")))
insert:
Code:
ColWdth = CentimetersToPoints(CSng(InputBox("What max column width for the pictures, in Centimeters (e.g. 8)?")))
and either delete:
Code:
ColWdth = TblWdth / NumCols
or change that line to:
Code:
If TblWdth / NumCols < ColWdth Then ColWdth = TblWdth / NumCols
Delete the line if you don't care whether the cumulative specified column width exceeds the page margins; otherwise, make the change.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #5  
Old 12-25-2020, 02:11 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

thanks Paul, I will give it a go later today. Much appreciated.
I will also amend the original macro as I will need captions in some of my tables.
I am writing a book with pages of images and this will be very handy
cheers
Reply With Quote
  #6  
Old 12-25-2020, 06:05 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

Hi Paul

I have now being working with the original one with the captions and while I have changed a number of things and can also use Word to improve the output such as centring the caption line the one thing I cannot do is to form fit the text to fit in the prescribed column width, hope you can help.

here is my revised macro for captions
Code:
Sub AddPics()
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
        oTbl.Cell(r + 1, c).Range.Text = StrTxt
        '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; 12-26-2020 at 04:30 AM. Reason: Added code tags
Reply With Quote
  #7  
Old 12-26-2020, 04:52 AM
macropod's Avatar
macropod macropod is offline Create Table for Multiple Pictures Windows 10 Create Table for Multiple Pictures Office 2010
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

I don't see where you're centring the caption, which in any event should be accomplished by modifying the Caption Style, not by overriding the paragraph format in code. Indeed, your line:
Code:
oTbl.Cell(r + 1, c).Range.Text = StrTxt
eliminates all of Word's implementation of normal captioning conventions.

To fit the text to the cell, you could use the .FitText method. but you don't want to apply that to text that's already less than the cell width. For example:
Code:
        With oTbl.Cell(r + 1, c).Range
          .InsertBefore vbCr
          .Characters.First.InsertCaption _
          Label:="Picture", Title:=StrTxt, _
          Position:=wdCaptionPositionBelow, ExcludeLabel:=False
          .Characters.First = vbNullString
          .Characters.Last.Previous = vbNullString
            If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _
              .Characters.First.Information(wdVerticalPositionRelativeToPage) Then
              .FitTextWidth = ColWdth
            End If
        End With
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #8  
Old 12-26-2020, 02:31 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, I have had trouble so I started off with your original macro for the captions and then placed this last change and it worked fine. However I dont want the label "Picture: ". How do I only show the file name please.
Reply With Quote
  #9  
Old 12-27-2020, 01:55 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

For just the text:
To fit the text to the cell, you could use the .FitText method. but you don't want to apply that to text that's already less than the cell width. For example:
Code:
        With oTbl.Cell(r + 1, c).Range
            .Text = StrTxt
            If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _
              .Characters.First.Information(wdVerticalPositionRelativeToPage) Then
              .FitTextWidth = ColWdth
            End If
        End With
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #10  
Old 12-27-2020, 03:16 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

H Paul
thank you for your latest update
sorry I keep asking you questions
the caption is now fitting as requested however its squeezed against the adjacent captions. Ideally 0.1cm left and right margin or a run time selection for the margin and can you do it so the caption is centred please

thank you
Reply With Quote
  #11  
Old 12-29-2020, 05:29 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:
Code:
.FitTextWidth = ColWdth
to:
Code:
.FitTextWidth = ColWdth - CentimetersToPoints(0.1)
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #12  
Old 12-30-2020, 03:51 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

just tested it thanks
no left indent and not centred
Reply With Quote
  #13  
Old 12-30-2020, 05:30 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

As I said in an earlier reply, changes to the caption paragraph's formatting should be done by changing the Style definition. You can do that manually, or by code. In your post previous to that, you said you had already modified things so that you were getting the required centring.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #14  
Old 12-30-2020, 03:26 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

thanks Paul, sorry I had forgotten regarding centring. No code, I manually highlight the table and click on paragraph centre so that is fine,
so only thing left is the left indent please, if this is too difficult I can increase the CentimetersToPoints from 0.1 to say 0.2 and then centre it.
let me know
Reply With Quote
  #15  
Old 12-31-2020, 06:33 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

Quote:
Originally Posted by victorybadges View Post
No code, I manually highlight the table and click on paragraph centre so that is fine
That is absolutely the wrong way to do it.

To center the captions (the pics are already centered), before:
Code:
      With .Styles("TblPic").ParagraphFormat
insert:
Code:
      .Styles("Caption").ParagraphFormat.Alignment = wdAlignParagraphCenter
It's not apparent why you'd want both centering and indenting in this situation.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
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 12:11 AM.


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