none
Tratamento Erro em VBA continuar execução RRS feed

  • Pergunta

  • Preciso de um auxilio com a query abaixo onde busco as imagens em um diretório e vou inserindo em um planilha, porém quando a imagem não for encontrada no diretório, quero exibir a mensagem para o usuário e continuar a execução da próxima linha em diante...e assim sucessivamente...como devo ajustar meu tratamento de erro, pois hoje da forma que tenho montado, quando isso ocorre a execução é terminada.

    Obrigado

    Sub Insere_Figura_celula()
    '
    'Macro gravada por Claiton Orth - 04/06/2013
    '
    Dim Coluna As String
    Dim Linha As Integer
    Dim Celula As String
    Dim Coluna_Figura As String
    Dim Celula_Figura As String

    Coluna = Range("G3")
    Linha = Range("G5")
    Celula = Coluna & Linha
    Coluna_Figura = Range("G4")
    Celula_Figura = Coluna_Figura & Linha
    Diretorio = Range("G2")
    Extensao = Range("G6")

    Reinicia_imagem:
    On Error GoTo Tratamento1

        Do While Range(Celula).Value <> ""
        
            Range(Celula_Figura).Select
          ' Insere imagem concatenando o valor da variável "Celula" com J:\FOTOS
            ActiveSheet.Pictures.Insert(Diretorio & Range(Celula).Value & Extensao).Select
          ' Define que redimencionamento será TRANCADO - mantém proporção do tamanho
            Selection.ShapeRange.LockAspectRatio = msoTrue
          ' Define altura da imagem com 1 cm, onde uma unidade é igual a 0,35278 mm.
            Selection.ShapeRange.Height = 26.96
          ' Move a imagem para baixo
            Selection.ShapeRange.Top = Range(Celula_Figura).Top
          ' Move a imagem 0.75 unidades (0,264585 mm) para baixo
            Selection.ShapeRange.IncrementTop 0.75
          ' Move a imagem para esquerda
            Selection.ShapeRange.Left = Range(Celula_Figura).Left
          ' Move a imagem 0.75 unidades (0,264585 mm) para esquerda
            Selection.ShapeRange.IncrementLeft 0.75
          ' Sai para evitar a rotina de tratamento.
                
    ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Copy
    ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Delete
    ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False, DisplayAsIcon:=False
    'Linhas de comando para gravar imagens no arquivo,
    'pois no office 2010 sem estes 3 comandos cria somente um link da imagem.

            Linha = Linha + 1
            Celula = Coluna & Linha
            Coluna_Figura = Coluna_Figura
            Celula_Figura = Coluna_Figura & Linha
        Loop
            Range(Celula).Select
            Range("A1").Select
            MsgBox ("Todas as imagens inseridas com sucesso !!!")
        '
    Tratamento1:
        Select Case Err.Number    ' Avalie o número do erro.
            Case 1004    ' Erro "O arquivo já está aberto".
                MsgBox ("Existe problema, ou não foi encontrada a imagem " & Range(Celula).Value & ".jpg !?!")
        End Select
    End Sub

    quarta-feira, 17 de dezembro de 2014 11:38

Respostas

  • Sub Insere_Figura_celula()
      '
      'Macro gravada por Claiton Orth - 04/06/2013
      '
      Dim Coluna As String
      Dim Linha As Integer
      Dim Celula As String
      Dim Coluna_Figura As String
      Dim Celula_Figura As String
      Dim Caminho As String
      Dim Diretorio As String
      Dim Extensao As String
      
      Coluna = Range("G3")
      Linha = Range("G5")
      Celula = Coluna & Linha
      Coluna_Figura = Range("G4")
      Celula_Figura = Coluna_Figura & Linha
      Diretorio = Range("G2")
      Extensao = Range("G6")
      
      Do While Range(Celula).Value <> ""
        
        Range(Celula_Figura).Select
        ' Insere imagem concatenando o valor da variável "Celula" com J:\FOTOS
        Caminho = Diretorio & Range(Celula).Value & Extensao
        If Dir(Caminho) <> "" Then
          ActiveSheet.Pictures.Insert(Caminho).Select
          ' Define que redimencionamento será TRANCADO - mantém proporção do tamanho
          Selection.ShapeRange.LockAspectRatio = msoTrue
          ' Define altura da imagem com 1 cm, onde uma unidade é igual a 0,35278 mm.
          Selection.ShapeRange.Height = 26.96
          ' Move a imagem para baixo
          Selection.ShapeRange.Top = Range(Celula_Figura).Top
          ' Move a imagem 0.75 unidades (0,264585 mm) para baixo
          Selection.ShapeRange.IncrementTop 0.75
          ' Move a imagem para esquerda
          Selection.ShapeRange.Left = Range(Celula_Figura).Left
          ' Move a imagem 0.75 unidades (0,264585 mm) para esquerda
          Selection.ShapeRange.IncrementLeft 0.75
          ' Sai para evitar a rotina de tratamento.
          
          ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Copy
          ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Delete
          ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False, DisplayAsIcon:=False
          'Linhas de comando para gravar imagens no arquivo,
          'pois no office 2010 sem estes 3 comandos cria somente um link da imagem.
        Else
          Range(Celula_Figura) = "<imagem não encontrada>"
        End If
        
        Linha = Linha + 1
        Celula = Coluna & Linha
        Coluna_Figura = Coluna_Figura
        Celula_Figura = Coluna_Figura & Linha
        Loop
        Range(Celula).Select
        Range("A1").Select
        MsgBox ("Todas as imagens inseridas com sucesso !!!")
        '
    End Sub


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    • Marcado como Resposta Claiton Orth quinta-feira, 18 de dezembro de 2014 13:01
    quarta-feira, 17 de dezembro de 2014 21:12
    Moderador

Todas as Respostas

  • Sub Insere_Figura_celula()
      '
      'Macro gravada por Claiton Orth - 04/06/2013
      '
      Dim Coluna As String
      Dim Linha As Integer
      Dim Celula As String
      Dim Coluna_Figura As String
      Dim Celula_Figura As String
      Dim Caminho As String
      Dim Diretorio As String
      Dim Extensao As String
      
      Coluna = Range("G3")
      Linha = Range("G5")
      Celula = Coluna & Linha
      Coluna_Figura = Range("G4")
      Celula_Figura = Coluna_Figura & Linha
      Diretorio = Range("G2")
      Extensao = Range("G6")
      
      Do While Range(Celula).Value <> ""
        
        Range(Celula_Figura).Select
        ' Insere imagem concatenando o valor da variável "Celula" com J:\FOTOS
        Caminho = Diretorio & Range(Celula).Value & Extensao
        If Dir(Caminho) <> "" Then
          ActiveSheet.Pictures.Insert(Caminho).Select
          ' Define que redimencionamento será TRANCADO - mantém proporção do tamanho
          Selection.ShapeRange.LockAspectRatio = msoTrue
          ' Define altura da imagem com 1 cm, onde uma unidade é igual a 0,35278 mm.
          Selection.ShapeRange.Height = 26.96
          ' Move a imagem para baixo
          Selection.ShapeRange.Top = Range(Celula_Figura).Top
          ' Move a imagem 0.75 unidades (0,264585 mm) para baixo
          Selection.ShapeRange.IncrementTop 0.75
          ' Move a imagem para esquerda
          Selection.ShapeRange.Left = Range(Celula_Figura).Left
          ' Move a imagem 0.75 unidades (0,264585 mm) para esquerda
          Selection.ShapeRange.IncrementLeft 0.75
          ' Sai para evitar a rotina de tratamento.
          
          ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Copy
          ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Delete
          ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False, DisplayAsIcon:=False
          'Linhas de comando para gravar imagens no arquivo,
          'pois no office 2010 sem estes 3 comandos cria somente um link da imagem.
        Else
          Range(Celula_Figura) = "<imagem não encontrada>"
        End If
        
        Linha = Linha + 1
        Celula = Coluna & Linha
        Coluna_Figura = Coluna_Figura
        Celula_Figura = Coluna_Figura & Linha
        Loop
        Range(Celula).Select
        Range("A1").Select
        MsgBox ("Todas as imagens inseridas com sucesso !!!")
        '
    End Sub


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    • Marcado como Resposta Claiton Orth quinta-feira, 18 de dezembro de 2014 13:01
    quarta-feira, 17 de dezembro de 2014 21:12
    Moderador
  • Deu certo

    Muito obrigado pela ajuda.

    Obrigado

    quinta-feira, 18 de dezembro de 2014 13:00