Microsoft Office Forums Help with VBA code to add plain text content control

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 11-13-2019, 10:56 AM
mgoblue mgoblue is offline Help with VBA code to add plain text content control Windows XP Help with VBA code to add plain text content control Office 2013
Novice
Help with VBA code to add plain text content control
 
Join Date: Nov 2019
Posts: 1
mgoblue is on a distinguished road
Default Help with VBA code to add plain text content control

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
Reply With Quote
  #2  
Old 11-13-2019, 11:31 PM
gmayor's Avatar
gmayor gmayor is offline Help with VBA code to add plain text content control Windows 10 Help with VBA code to add plain text content control Office 2016
Expert
 
Join Date: Aug 2014
Posts: 3,027
gmayor is just really nicegmayor is just really nicegmayor is just really nicegmayor is just really nicegmayor is just really nice
Default

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
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
Reply

Thread Tools
Display Modes


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
Help with VBA code to add plain text content control 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
Help with VBA code to add plain text content control 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


All times are GMT -7. The time now is 04:37 AM.


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