![]() |
#2
|
||||
|
||||
![]()
The code for that is quite different:
Code:
Sub AddPicsNoCaption() 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 = 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 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 '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] |
|
![]() |
||||
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 |
![]() |
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 |
![]() |
JBA479 | Word VBA | 1 | 01-24-2014 08:51 PM |