Quote:
Originally Posted by Rfuchs730
just for spacing between the photos.
|
The code below adds a 12 point space to the top of the cells from row 2 onwards.
Code:
Sub InsertMultipleImagesFixed()
Dim fd As FileDialog
Dim imgCount As Long
Dim imgTable As Table
Dim index As Long
Dim img As InlineShape
Dim imageLoc As Variant
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", _
"*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png; *.wmf"
.FilterIndex = 2
End With
If fd.Show = -1 Then
imgCount = fd.SelectedItems.Count
With ActiveDocument
With .Content.Find
.Replacement.ClearFormatting
.Text = "TotalImageNumber"
.Replacement.Text = imgCount
.Execute Replace:=wdReplaceAll
End With
Set imgTable = .Tables.Add(Range:=.Characters.Last, NumRows:=imgCount, NumColumns:=2)
End With
'apply table settings
With imgTable
.Borders.Enable = False
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Rows.Alignment = wdAlignRowLeft
.Columns(1).Width = 140
.Columns(2).Width = 400
End With
'loop through table adding images and text
For index = 1 To imgCount
With imgTable.Cell(index, 1).Range
With .ParagraphFormat
If index > 1 Then .SpaceBefore = 12
End With
With .Font
.Size = 12
.Underline = wdUnderlineSingle
End With
.Text = "Photograph No. " & index & ":"
.Characters(.Characters.Count - 1).Font.Underline = wdUnderlineNone
.InsertParagraphAfter
With .Paragraphs.Last.Range
.Font.Underline = wdUnderlineNone
With .ParagraphFormat
.RightIndent = InchesToPoints(0.02)
.SpaceBefore = 0
'the following are likely unnecessary
'.SpaceBeforeAuto = False
'.SpaceAfterAuto = False
End With
End With
End With
With imgTable.Cell(index, 2).Range.ParagraphFormat
.RightIndent = InchesToPoints(0.01)
If index > 1 Then .SpaceBefore = 12
'the following are likely unnecessary
'.SpaceBeforeAuto = False
'.SpaceAfterAuto = False
End With
'insert image
Set img = _
ActiveDocument.InlineShapes.AddPicture(FileName:=imageLoc & fd.SelectedItems(index), _
LinkToFile:=False, SaveWithDocument:=True, Range:=imgTable.Cell(index, 2).Range)
'resize image
With img
With .Fill
.Visible = msoFalse
.Solid
.Transparency = 0
End With
With .Line
.Weight = 0.75
.Transparency = 0#
.Visible = msoFalse
End With
'I suspect the above should simply be
'.Fill.Visible = msoFalse
'.Line.Visible = msoFalse
.LockAspectRatio = msoTrue
.Height = 288
.Width = 383.75
With .PictureFormat
.Brightness = 0.5
.Contrast = 0.5
.ColorType = msoPictureAutomatic
'these should all be unnecessary
' .CropLeft = 0#
' .CropRight = 0#
' .CropTop = 0#
End With
End With
Next index
End If
End Sub