Macro para inserir fotos no Word

[bilareal]

Sendo um leigo na matéria, com a ajuda de diversas macros que obtive na net, que serviram de base, fui desenvolvendo uma macro para inserir múltiplas fotos num documento word.

Com esta macro pretendo inserir fotos em tabela com duas colunas, em que a coluna direita apareça a foto e nome do ficheiro e a coluna esquerda fique em branco para poder fazer a descrição.

Contudo, agora não consigo correr a macro, pois dá erro (erro 4198) na função de inserir o nome do ficheiro. Alguém me pode dar uma dica?

Sub InsertMultipleImagesWithFilename()

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

If Documents.Count = 0 Then

sNoDoc = MsgBox(" " & _

"No document open!" & vbCr & vbCr & _

"Do you wish to create a new document to hold the images?", _

vbYesNo, "Insert Images")

If sNoDoc = vbYes Then

Documents.Add

Else

Exit Sub

End If

End If

'add a 1 row 2 column table to take the images

Set oTable = Selection.Tables.Add(Selection.Range, 1, 2)

'+++++++++++++++++++++++++++++++++++++++++++++

'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"

.FilterIndex = 2

If .Show = -1 Then

For i = 1 To .SelectedItems.Count

'find col,row #s

If i Mod 2 = 0 Then 'even number right column

iRow = i / 2

iCol = 2

Else 'odd number left column new row

iRow = (i + 1) / 2

iCol = 1

End If

iRow = i

iCol = 1

'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 = oTable.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 = wdAlignParagraphLeft

'insert caption above image

oCell.InlineShapes(i).Range.InsertCaption Label:="ppp", TitleAutoText:="", _

Title:=":" & picName, Position:=wdCaptionPositionAbove, ExcludeLabel:=False

If i < .SelectedItems.Count And i Mod 2 = 0 Then 'add another row, more to go

oTable.Rows.Add

End If

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

Edited June 3, 2014 at 08:39 AM by bilareal

[bilareal]

Não há sugestões? 😞