Create Textbox based on the postion of the picture

[Kumarcoolz]

Hi Guys,
i have a problem regarding word VBA, i wanted to select and paste a group of pictures in an alligned manner and then create a textbox over the pictures and get the name of the picture in the textbox.

i googled, recorded and maniplated somes macro to select the pictures, paste them on the format as required. Find the code below:

Sub InsertImages()
Dim doc As Word.Document
Dim fd As FileDialog
Dim mg2 As Range
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Set doc = ActiveDocument
Dim vrtSelectedItem As Variant
Dim oILShp As InlineShape
Dim Char As Characters
Dim StrPath As String
Dim StrNewPath As String
Dim strDocName As String

' selecting the Picture files

With fd
.Filters.Add "Computer Graphics Metafile", "*.jpg", 1
.FilterIndex = 1
r = 0
If .Show = -1 Then
StrPath = .SelectedItems(1)
For Each vrtSelectedItem In .SelectedItems
Set mg2 = ActiveDocument.Range
mg2.Collapse wdCollapseEnd
doc.InlineShapes.AddPicture FileName:=vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, Range:=mg2

r = r + 1

'getting the file names of the pictures
StrPath = vrtSelectedItem
strDocName = Replace(StrPath, "\", Chr(45), 1, (Len(StrPath) - Len(Replace(StrPath, "\", ""))) - 1)
strDocName = Right(strDocName, Len(StrPath) - InStr(strDocName, "\"))
strDocName = Left(strDocName, InStrRev(strDocName, ".", -1) - 1)
Debug.Print strDocName

'allignment of the picture
If r Mod 2 = 0 Then
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.TypeParagraph
Selection.TypeParagraph
End If
If r Mod 2 = 1 Then
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.TypeText (vbTab)
End If

Next vrtSelectedItem
Else
MsgBox ("No Images Selected")
Exit Sub
End If
End With
Set fd = Nothing

'changing the size of the picture
For Each oILShp In ActiveDocument.InlineShapes
With oILShp
.Height = InchesToPoints(2.5)
.Width = InchesToPoints(3)
End With
Next


End Sub


But i am unable to bring textbox appropriately above the pictures. Help or ideas on this would be highly greatfully.

i have attached the sample document of my final requirement. my document contains generally 100 such pictures to be pasted.


Regards
Kumar

[Kumarcoolz]

Update to the above code:
I have managed to place the textbox above the picture as i have desired but the textbox is placed on the top-right corner of the picture.

The intend is to place the textbox on the Bottom-right of the picture (as shown in the sample document)


The updated code I created is below for your reference:

Sub InsertImages()
Dim doc As Word.Document
Dim fd As FileDialog
Dim mg2 As Range
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Set doc = ActiveDocument
Dim vrtSelectedItem As Variant
Dim oILShp As InlineShape
Dim Char As Characters
Dim StrPath As String
Dim StrNewPath As String
Dim strDocName As String
Dim Shp As Shape

' selecting the Picture files

With fd
.Filters.Add "Computer Graphics Metafile", "*.jpg", 1
.FilterIndex = 1
r = 0
If .Show = -1 Then
StrPath = .SelectedItems(1)
For Each vrtSelectedItem In .SelectedItems
Set mg2 = ActiveDocument.Range
mg2.Collapse wdCollapseEnd
doc.InlineShapes.AddPicture FileName:=vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, Range:=mg2

r = r + 1

'getting the file names of the pictures
StrPath = vrtSelectedItem
strDocName = Replace(StrPath, "\", Chr(45), 1, (Len(StrPath) - Len(Replace(StrPath, "\", ""))) - 1)
strDocName = Right(strDocName, Len(StrPath) - InStr(strDocName, "\"))
strDocName = Left(strDocName, InStrRev(strDocName, ".", -1) - 1)

'allignment of the picture based on Even and Odd Numbers
If r Mod 2 = 0 Then
'formating the Picture
Set oILShp = ActiveDocument.InlineShapes(r)
With oILShp
.Height = InchesToPoints(2.5)
.Width = InchesToPoints(3)
End With
Set oILShp = Nothing

'adding textbox above picture
Set Shp = ActiveDocument.Shapes.AddTextbox(1, fcnXCoord, fcnYCoord, 50, 36)
With Shp
.TextFrame.TextRange.Text = strDocName
.Line.Visible = msoTrue
.Fill.Visible = msoTrue
End With
Set Shp = Nothing

'Moving the cursor for next picture
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.TypeParagraph
Selection.TypeParagraph
End If

If r Mod 2 = 1 Then

'formating the Picture
Set oILShp = ActiveDocument.InlineShapes(r)
With oILShp
.Height = InchesToPoints(2.5)
.Width = InchesToPoints(3)
End With
Set oILShp = Nothing

'adding textbox above picture
Set Shp = ActiveDocument.Shapes.AddTextbox(1, fcnXCoord, fcnYCoord, 50, 36)
With Shp
.TextFrame.TextRange.Text = strDocName
.Line.Visible = msoTrue
.Fill.Visible = msoTrue
End With
Set Shp = Nothing

'Moving the cursor for next picture
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.TypeText (vbTab)

End If
Next vrtSelectedItem

Else
MsgBox ("No Images Selected")
Exit Sub
End If
End With
Set fd = Nothing

End Sub
Function fcnXCoord() As Double
fcnXCoord = Selection.Information(wdHorizontalPositionRelativeToPage)
End Function
Function fcnYCoord() As Double
fcnYCoord = Selection.Information(wdVerticalPositionRelativeToPage)
End Function

[macropod]

Cross-posted (and solved) at: http://www.excelforum.com/word-programming-vba-macros/986423-create-textbox-based-on-the-postion-of-the-picture.html
For cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184