Help with VBA code to add plain text content control

mgoblue · #1 11-13-2019, 10:56 AM

Hello all. I found this forum and was hoping I could get some help. I found this code through a google search. The code allows me to open a word document, run the code, select photos to insert, and inserts two photos on the page with the file name below each photo. It is just what I was trying to do except I want a blank plain text content control box under each photo instead of the file name. Does this make sense?

I've tried to add code myself....which has not really worked out...

Below is the code I have been using and trying to get to do what I need it to do. Any help would be much appreciated.

Sub InsertMultipleImagesFixed()
Dim fd As FileDialog
Dim oTable As Table
Dim iRow As Integer
Dim iCol As Integer
Dim oCell As Range
Dim i As Long
Dim sNoDoc As String
Dim picName As String
Dim scaleFactor As Long
Dim max_height As Single
'define resize constraints
max_height = 275

'add a 1 row 2 column table to take the images
Set oTable = Selection.Tables.Add(Selection.Range, 1, 1)
'+++++++++++++++++++++++++++++++++++++++++++++
'oTable.AutoFitBehavior (wdAutoFitFixed)
oTable.Rows.Height = CentimetersToPoints(4)
oTable.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
'++++++++++++++++++++++++++++++++++++++++++++++

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
If .Show = -1 Then

For i = 1 To .SelectedItems.Count

iCol = 1
iRow = i
'get filename
picName = Right(.SelectedItems(i), Len(.SelectedItems(i)) - InStrRev(.SelectedItems(i), ""))
'remove extension from filename ****
picName = Left(picName, InStrRev(picName, ".") - 1)

'select cell
Set oCell = ActiveDocument.Tables(1).Cell(iRow, iCol).Range

'insert image
oCell.InlineShapes.AddPicture FileName:= _
.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oCell

'resize image
If oCell.InlineShapes(1).Height > max_height Then
scale_factor = oCell.InlineShapes(1).ScaleHeight * (max_height / oCell.InlineShapes(1).Height)
oCell.InlineShapes(1).ScaleHeight = scale_factor
oCell.InlineShapes(1).ScaleWidth = scale_factor
End If

'center content
oCell.ParagraphFormat.Alignment = wdAlignParagraphCenter

'insert caption below image
oCell.InlineShapes(1).Range.InsertCaption Label:="Figure", TitleAutoText:="", _
Title:=": " & picName,
If i < .SelectedItems.Count And i Mod 2 = 0 Then 'add another row, more to go
oTable.Rows.Add
End If

Next i
End If
End With

Set fd = Nothing
End Sub

gmayor · #2 11-13-2019, 11:31 PM

Try the following, however you may find Photo Gallery Add-in Template useful

Code:

Sub InsertMultipleImagesFixed()
Dim fd As FileDialog
Dim oTable As Table
Dim oCell As Range
Dim i As Long
Dim oShape As InlineShape
Dim scale_Factor As Long
Dim max_height As Single
Dim oCC As ContentControl
    'define resize constraints
    max_height = 275

    'add a 1 row 1 column table to take the images
    Set oTable = Selection.Tables.Add(Selection.Range, 1, 1)
    '+++++++++++++++++++++++++++++++++++++++++++++
    'oTable.AutoFitBehavior (wdAutoFitFixed)
    oTable.Rows.Height = CentimetersToPoints(4)
    oTable.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
    '++++++++++++++++++++++++++++++++++++++++++++++

    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
        If .Show = -1 Then

            For i = 1 To .SelectedItems.Count
                'select cell
                Set oCell = ActiveDocument.Tables(1).Cell(i, 1).Range
                oCell.End = oCell.End - 1
                'insert image
                Set oShape = oCell.InlineShapes.AddPicture(FileName:= _
                                                           .SelectedItems(i), LinkToFile:=False, _
                                                           SaveWithDocument:=True, Range:=oCell)

                'resize image
                If oShape.Height > max_height Then
                    scale_Factor = oShape.ScaleHeight * (max_height / oShape.Height)
                    oShape.ScaleHeight = scale_Factor
                    oShape.ScaleWidth = scale_Factor
                End If

                'center content
                oCell.ParagraphFormat.Alignment = wdAlignParagraphCenter

                'insert caption below image

                Set oCell = ActiveDocument.Tables(1).Cell(i, 1).Range
                oCell.End = oCell.End - 1

                oCell.Collapse 0
                oCell.Text = vbCr & vbCr
                oCell.Collapse 0

                Set oCC = oCell.ContentControls.Add
                With oCC
                    .Type = wdContentControlRichText
                    .TITLE = "Image " & i
                    .Tag = .TITLE
                    '.LockContentControl = True
                End With
                If i < .SelectedItems.Count Then oTable.Rows.Add
            Next i
        End If
    End With
    Set oShape = Nothing
    Set oTable = Nothing
    Set oCell = Nothing
    Set fd = Nothing
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Copy Formatted Text in one Rich Text Content Control to another Rich Text Content Control	Haygordon	Word	1	04-05-2019 05:43 AM
Rich text/Plain text Content Controls in Template	michael.fisher5	Word	9	11-19-2014 06:36 AM
Plain Text Content Control - Losing Styling on Carriage Return	kintap	Word	0	07-16-2014 12:43 PM
Creating a plain text content control for every instance of a word or phrase	RobsterCraw	Word VBA	16	11-20-2012 03:25 PM
Word2010 check boxes and plain text content control boxes in same table	fcsungard	Word	5	06-01-2012 01:16 AM