![]() |
#1
|
|||
|
|||
![]()
Hi,
I have an inventory list where each item has a unique ID (called "Kürzel") based on its category in the format A 01, A 02, A 03, E 01, E 02 etc. Each item has a QR-Code (PNG File) with the same ID as a text value. Screenshot 2.jpg I now want to print out physical labels to then put on the items. Therefore I have a word template with a table. Each Label has two columns, one for the picture of the QR-Code and one for the text. Screenshot 1.jpg And this brings me to my question. I would like to insert all images at once (at least per column) so I do not have to do it indiviually. I found a great VBA code from this thread that I modified a bit: 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 scaleFactor As Long Dim max_height As Single 'define resize constraints max_height = 275 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 Next i End If End With Set fd = Nothing End Sub
Thanks Elias |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
Nina | Word VBA | 16 | 08-27-2018 01:53 AM |
![]() |
nando88 | Word VBA | 6 | 05-09-2016 11:56 PM |
![]() |
skatiemcb | Word Tables | 2 | 01-24-2015 08:18 AM |
![]() |
mescaL | Word VBA | 3 | 11-03-2014 10:51 PM |
![]() |
JBA479 | Word VBA | 1 | 01-24-2014 08:51 PM |