#1
|
|||
|
|||
Insert multiple images in table with filename in column to the side
Hello!
I need to create a document that has 4 columns with a picture in the last column (4), and its filename in the column to the left (3). (The first two columns have data that I'll need to import individually rather than in a batch process.) I'll need to import at least 1000 pictures for my report, so any way that I can save some time would be awesome. I've tried using the following module that I found on Microsoft's technet, and it works for adding the pictures, but I can't figure out how to implement the modifications that I want. Basically, I want a "caption" that shows up in a different column that only contains the filename. (I also want the pictures to only be about 2 inches high, but I think I can modify that by changing "max_height" below, right?) Is what I want to do possible? Any advice? I really don't want to have to drag the text from the caption to a separate column for 1000+ pictures. Thanks in advance for any help! Module: 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 |
#2
|
|||
|
|||
Try this.
Code:
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 scale_Factor As Long Dim max_height As Single 'define resize constraints max_height = 144 ' 2 inches = 144 pt 'add a 1 row 4 column table to take the images Set oTable = Selection.Tables.Add(Selection.Range, 1, 4) '+++++++++++++++++++++++++++++++++++++++++++++ 'oTable.AutoFitBehavior (wdAutoFitFixed) oTable.Rows.Height = InchesToPoints(2.1) 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 = 4 iRow = i 'get filename 'picName = Right(.SelectedItems(i), Len(.SelectedItems(i)) - InStrRev(.SelectedItems(i), "\")) ''remove extension from filename **** 'picName = Left(picName, InStrRev(picName, ".") - 1) picName = WordBasic.FilenameInfo(.SelectedItems(i), 4) '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 in column 4, then move it to column 3 oCell.InlineShapes(1).Range.InsertCaption Label:="Figure", TitleAutoText:="", _ Title:=": " & picName oCell.Paragraphs(2).Range.Cut ActiveDocument.Tables(1).Cell(iRow, iCol - 1).Range.Paste If i < .SelectedItems.Count Then 'add another row, more to go oTable.Rows.Add End If Next i End If End With Set fd = Nothing End Sub |
#3
|
|||
|
|||
This is exactly what I had in mind. Thank you so much!
|
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Insert multiple images at once from a folder | beyondimage | Excel | 1 | 02-01-2017 12:58 AM |
Insert multiple images & controls into a document | vanwijnen | Word VBA | 1 | 06-05-2015 06:16 AM |
Insert different images to multiple labels | Ravon | Word | 3 | 10-16-2014 01:13 PM |
Insert values from multiple rows based on value in one column | pachmarhi | Excel | 3 | 07-18-2014 09:57 PM |
I need to paste two images from a PDF side by side into word | eof | Word | 15 | 04-10-2014 08:12 PM |