Usuário com melhor resposta
Tratamento Erro em VBA continuar execução

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