Insert multiple images into a Word table with file name only (no path or extension)

[Ticker Tape]

Hello,

This question refers to VBA in Word 2007 running under Windows XP Pro. SP3.

My problem is simple. The script below does everything I need to achieve image insertion formatted to my needs, except:-

It types the full file name into each cell of the table: I need only the file name itself, without path or extension.

At this point, if you can help please do so. If you can tell me the modification needed, and where it fits into the script to achieve the objective, I would be very grateful.

The rest of this note, after the script, is background describing how I got to this point. When I help people, I find it interesting / useful to understand what the person is trying to do, and why.




Sub Autopics()
Dim fd As FileDialog
Dim oTbl As Table
Dim oILS As InlineShape
Dim vrtSelectedItem As Variant
If Documents.Count = 0 Then
If MsgBox("No document open!" & vbCr & vbCr & _
"Do you wish to create a new document to hold the images?", _
vbYesNo, "Insert Images") = vbYes Then
Documents.Add
Else
Exit Sub
End If
End If
'Add a 1 row 2 column table to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 1, 2)
With oTbl.Borders
.InsideColor = wdColorAutomatic
.InsideLineStyle = wdLineStyleSingle
.OutsideColor = wdColorAutomatic
.OutsideLineStyle = wdLineStyleSingle
End With
oTbl.AutoFitBehavior (wdAutoFitFixed)
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
With Selection
Set oILS = .InlineShapes.AddPicture(FileName:= _
vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, _
Range:=Selection.Range)
.InsertAfter vbCrLf & vbCrLf
.Collapse 0
.MoveLeft Unit:=wdCharacter, Count:=1
.Text = vrtSelectedItem
.MoveRight wdCell, 1
End With
Next vrtSelectedItem
Else
End If
End With
If Len(oTbl.Rows.Last.Cells(1).Range) = 2 Then oTbl.Rows.Last.Delete
Set fd = Nothing
' Stop rows breaking
Selection.Tables(1).Select
Selection.Rows.AllowBreakAcrossPages = 0
' Font size and colour'
Selection.Tables(1).Select
Selection.Font.Color = wdColorAutomatic
Selection.Font.Bold = 0
Selection.Font.Size = 9
Selection.ParagraphFormat.SpaceAfter = 0 'or the value you prefer
End Sub




Background

I am a UK based inventory clerk. For years I have been inserting images of property interiors and their defects into the reports I produce for clients (Inventories, Check In, Check Out etc.). Methodology: Insert pictures one at a time and then type descriptive text. This is time consuming and can be troublesome when selecting images which were captured out of sequence during the inspection.

So, I trawled the web and found some VBA code which provided the basis of my script (if it’s yours, and you still recognise it after my editing, thank you very much). The script has been much ‘tweaked’ by trial and error to achieve my particular needs and now meets those needs to perfection except for the name problem (although I have no idea whether it still stands up as a logical, efficient script). I have searched extensively and found numerous pieces of code that achieve the desired file name output, but have been unable to get any of them to work within my script. I apologise for including the full script but, after my own efforts, I don’t know where, or how, it needs modifying. (Did I explain? Prior to this, a macro was something I recorded with keystrokes, I am a VBA virgin!). It’s clear to me that I’m not going to achieve my aim without a lot more time spent understanding VBA, hence my plea for help.

BTW

Whilst looking for file name code to complete my macro, I came across a Word Add-In, written by Greg Maxey. For a short time I was prepared to kick myself for spending so much time putting my own solution together. Unfortunately, Greg’s Add-In doesn’t meet my needs in respect of a couple of key details:-

My principal client requires each image to be in a cell with borders and its descriptive text to be in the same cell, above the image. In all other respects Greg’s Add-In is perfect. I’m afraid I don’t have the knowledge to know just how clever his work is, but every time I run my macro I will be thinking of his image selection and ordering screen. For what it’s worth, that feature is, to me, fantastic.

Thanks for taking the time to read this note.

Phil

[Dave]

U can trial this untested code. HTH. Dave

'add these variables
Dim FlName As Variant, Cnt As Integer, Cnt2 As Integer
For Each vrtSelectedItem In .SelectedItems
'insert the following after the above
Cnt = 0
For Cnt2 = 1 To Len(vrtSelectedItem)
'search for "\" (ie. Asc 92)
If Asc(Mid(vrtSelectedItem, Cnt2, 1)) = 92 Then
Cnt = Cnt + 1
End If
Next Cnt2
FlName = Split(vrtSelectedItem, "\")
'change this line of code
.Text = Left(FlName(Cnt + 1), Len(FlName(Cnt + 1)) - 4)

[Ticker Tape]

Thanks, Dave

My problem has been working out where in the script the modification should be inserted.

Did you notice how I avoided asking simply - Where should I insert it?:)

Phil

PS

Have now edited script as advised and

.Text = Left(FlName(Cnt + 1), Len(FlName(Cnt + 1)) - 4) is returning 'Run time error ‘9’ subscript out of range'

[Dave]

Whoops. Trial...

.Text = Left(FlName(Cnt), Len(FlName(Cnt)) - 4)

[Ticker Tape]

Absolute perfection.

Many thanks for taking the time to help.

Kind regards,
Phil

[Dave]

You are Welcome. Thanks for posting your outcome. Dave

[macropod]

You could just change:
.Text = vrtSelectedItem
to:
.Text = Mid(vrtSelectedItem, InStrRev(vrtSelectedItem, "\") + 1, InStrRev(vrtSelectedItem, ".") - InStrRev(vrtSelectedItem, "\") - 1)

PS: When posting code, please use the code tags, indicated by the # symbol on the posting menu.

[Ticker Tape]

Hi Paul,

Your solution also works perfectly. When I did my own research I found several bits of code for producing just the file name, IIRC none were exactly like yours or Dave's so I hope you can understand my initial confusion. There are obviously numerous different ways to 'skin a cat' in VBA.

Nevertheless, thank you very much for taking the time to send me your very elegant solution, it's much appreciated and I'm starting to feel the stirrings of an increased interest in going further with VBA.

Re:- Posting code

I did read the FAQs before I sent my original question. They said click the 'VBA' button before and after the code. Unfortunately, there's no 'VBA' button on my toolbar. So, thank you once again for letting me know that the '#' does the same thing.

Warm regards from a wet and windy UK,
Phil

[snb]

VBA has a special library that provides the very method you are looking for:


CreateObject("scripting.filesystemobject").getbasename("fullname")

In your case I'd use:


Sub M_snb()
If Documents.Count = 0 Then If MsgBox("No document open!" & vbCr & vbCr & "Do you wish to create a new document to hold the images?", vbYesNo, "Insert Images") = vbYes Then Documents.Add
If Documents.Count = 0 Then Exit Sub

Selection.Tables.Add Selection.Range, 1, 2

With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
If .Show = -1 Then
For Each it In .SelectedItems
j = j + 1
ActiveDocument.InlineShapes.AddPicture it, False, True, ActiveDocument.Tables(1).Cell(1, j).Range
ActiveDocument.Tables(1).Cell(1, j).Range.InsertAfter vbCr & vbCr & CreateObject("scripting.filesystemobject").getbasename(it)
Next
End If
End With
End Sub

[Ticker Tape]

Hi snb,

Thanks for your interest. I tried running your code and:-


ActiveDocument.InlineShapes.AddPicture it, False, True, ActiveDocument.Tables(1).Cell(1, j).Range

returns

Runtime error ‘5941’ The requested member of the collection does not exist.

Cheers,
Phil

[snb]

You probably selected 3 pictures ? The table only contains 2 cells.

But this code will take care of any amount of selected pictures:


Sub M_snb()
If Documents.Count = 0 Then If MsgBox("No document open!" & vbCr & vbCr & "Do you wish to create a new document to hold the images?", vbYesNo, "Insert Images") = vbYes Then Documents.Add
If Documents.Count = 0 Then Exit Sub

With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
If .Show = -1 Then
Selection.Tables.Add Selection.Range, .SelectedItems.Count \ 2 + .SelectedItems.Count mod 2, 2

For Each it In .SelectedItems
j = j + 1
ActiveDocument.InlineShapes.AddPicture it, False, True, ActiveDocument.Tables(1).Cell((j - 1) \ 2 +1, (j - 1) Mod 2 + 1).Range
ActiveDocument.Tables(1).Cell((j - 1) \ 2 +1, (j - 1) Mod 2 + 1).Range.InsertAfter vbCrLf & vbCrLf & CreateObject("scripting.filesystemobject").getbasename(it)
Next
End If
End With
End Sub

[Ticker Tape]

Understood, thanks for the revised version.

My original script, with Macropod’s one line modification is now producing exactly the output I needed, Dave’s modifications worked equally well.

As you know, I'm no expert but I know enough (I think) to infer that your code has probably reduced the basic macro to its bare essentials in a very neat way.

When I get the chance to ‘play’, I look forward to starting to understand the difference between the various scripts. For me, 'learning by doing' has always been the most effective way of gaining expertise with various software products and your kind contribution will allow me to keep moving forward in this manner.

Thanks again,
Phil

[macropod]

I'm no expert but I know enough (I think) to infer that your code has probably reduced the basic macro to its bare essentials in a very neat way.
Indeed, there was much that could be done to improve your macro. I limited my reply to the task at hand.

IMHO, though, using CreateObject to instantiate a new copy of the filesystemobject on every iteration of the loop the way snb has done is both inefficient and prone to cause other problems if you try inserting a lot of images (since the resources allocated to each new instance aren't released till the macro ends). You could just as easily replace his:
CreateObject("scripting.filesystemobject").getbasename(it)
with:
Mid(it, InStrRev(it, "\") + 1, InStrRev(it, ".") - InStrRev(it, "\") - 1)
and avoid the issue entirely.

Do note, too, that snb has a poor habit of not declaring variables (in this case 'it'), which just makes it harder to maintain/debug the code later on. It also won't work for any one who uses Option Explicit, which requires variable declarations and is very useful for trapping errors such as if you have an 'it' variable but accidently input it somewhere as, say, 'ti'. Without that, you could waste time trying to figure why code that looks like it's running OK doesn't actually work...

[Ticker Tape]

Hi Paul,

Thanks for your continued interest, your comments are well received and noted.

I’ve learned a valuable lesson over the last few days. I have never registered with a forum to seek help before. The generosity of you guys is exemplary.

In the past, I have been more accustomed to giving rather than receiving help with computer issues. When helping others, I have probably responded in the same way as Dave and snb - i.e. solve the problem and move things along a little. This week, I have learned the value of trying to solve only the problem presented.

What you did was deal precisely with the problem in front of you. For a person at my level of knowledge, this was exactly what was needed. It told me that my basic script (no matter how ugly) was sound enough to accept a small, final, modification to achieve the desired result. At the end of the day, good script or bad script, it’s making a significant difference in the real world. Should something go wrong down the road, I have a fighting chance of fixing it without bothering you guys.

Had you not responded, I would have been using one of the other two solutions. The big thing here is that both needed minor debugging and the guys’ response to this was instant and effective, so I had no sense that I would be hung out to dry if I used them. As I mentioned before, both these contributions will have their part to play as I move along the learning curve.

When I sent my first post, I was fully expecting some pretty cool responses, along the lines of ‘you’re an idiot and this problem is beneath us’, instead of which, thanks to each of you, my first experience of joining a forum has been 100% positive.

Sorry if this has been a bit ‘wordy’ but you have been good enough to help and I feel it’s important to let you know how, and why, that help has been appreciated, particularly as it’s unlikely I will ever reach a level where I can do the same for you.

Kind regards,
Phil