Como inserir imagens com legendas??

Question

Ola.

Preciso inserir uma grande quantidade de imagens em um documento do word.

Para otimizar este trabalho e economizar espaço, utilizo a macro abaixo para redimencionar as imagens todas:

Sub RedimensionarImagens()

Dim ishp As InlineShape

For Each ishp In ActiveDocument.InlineShapes

ishp.Width = 120

ishp.Height = 182

Next ishp

End Sub

Porém as imagens são anexadas umas grudadas nas outras, e eu preciso automatizar este processo de separa-las e ficar escrevendo a legenda uma a uma. Como por exemplo: Anexo 1, Anexo 2, Anexo 3....     O que as vezes acaba sendo péssimo pois dependendo da quantidade de anexos no relatório, é facil se perder na conta....

Como faço para automatizar este processo?

Obrigado.

Answer 1

Realmente, precisava de alguns ajustes.

Importante!!! Adicione sempre novas imagens no final do documento, nunca no inicio!

teste com 5 imagens.. depois acrescente mais umas 20.. acabei de testar e funcionou

Não esqueça de marcar a resposta como útil..

abraços!!

Sub Melhorado()

Dim ishp            As InlineShape

Dim countLabels     As Single

countLabels = 1

'Melhora um pouco a performance

'Desabilita funções

Application.ScreenUpdating = False

'Aplica Legenda

CaptionLabels.Add Name:="Anexo"

If Application.ActiveDocument.Content.Fields.Count = 0 Then

    For Each ishp In ActiveDocument.InlineShapes

        ishp.Width = 120

        ishp.Height = 182

        ishp.Select

        Selection.InsertCaption Label:="Anexo", Position:=wdCaptionPositionBelow

        Selection.TypeParagraph

    Next ishp

Else

    For Each ishp In ActiveDocument.InlineShapes

        If countLabels > Application.ActiveDocument.Content.Fields.Count Then

            ishp.Width = 120

            ishp.Height = 182

            ishp.Select

            Selection.InsertCaption Label:="Anexo", Position:=wdCaptionPositionBelow

            Selection.TypeParagraph

        End If

        countLabels = countLabels + 1

    Next ishp

End If

' Formata alinhamento e Cor

Application.ActiveDocument.Content.ParagraphFormat.Alignment = wdAlignParagraphCenter

Application.ActiveDocument.Content.Font.ColorIndex = wdAuto

' Restaura funções

Application.ScreenUpdating = True

End Sub

Answer 2

Ola

Jorge,

funcionou sim, porém temos um problema:

No caso de eu executar a macro com muitas imagens, o word praticamente trava, ai para evitar isso, pensei em ir inserindo aos poucos e rodando a macro por etapas, porém sempre que executo novamente, ele insere as legendas aonde já tem pulando uma posição. É possível solucionar isso?

Outro ponto, apenas como detalhe de perfumaria, tentei alterar o escrito "anexo" para "Anexo", porém não aceitou, e gostaria de que já saisse tudo centralizado na folha e a fonte fosse na cor preta, isso é possível?

Obrigado.

Answer 3

Olá Maurício, mudei a Macro um pouquinho,  aqui a macro funcionou OK.

Teste com poucas imagens - umas 4 por exemplo. Depois tente com várias imagens.

Se mesmo assim der problema vou pensar em outra alternativa

Sub teste()

Dim ishp As InlineShape

CaptionLabels.Add Name:="anexo"

For Each ishp In ActiveDocument.InlineShapes

    ishp.Width = 120

    ishp.Height = 182

    ishp.Select

    Selection.InsertCaption Label:="anexo", Position:=wdCaptionPositionBelow

    Selection.TypeParagraph

Next ishp

End Sub

Exemplo de saída

Answer 4

Boa tarde.

---

Jorge,

---

Fiz isso, porem a macro está travando o word, como se fosse um loop sem fim.

---

Outra coisa é que o texto está aparecendo ao contrario, por exemplo:

---

20: anexo, 21:anexo...etc...

---

Preciso que aparece ao contrário, exemplo:

---

Anexo: 21 , Anexo 22 ...etc...

---

você consegue me ajudar?

---

Obrigado.

Answer 5

Acrescentei três linhas de comando em sua macro.

Tente desta forma:

Sub RedimensionarImagens()

Dim ishp As InlineShape

For Each ishp In ActiveDocument.InlineShapes

ishp.Width = 120

ishp.Height = 182

ishp.SelectSelection.InsertCaption Label:=wdCaptionFigure, Title:=": SEU TEXTO", _Position:=wdCaptionPositionBelow, ExcludeLabel:=True

Selection.TypeParagraph

Next ishp

End Sub