Excel Como inserir imagem numa forma com vba

[Andre4]

Bom dia,

 

Queria carregar num botão e inserir imagem numa caixa de texto em vez de uma célula.

 

Eu utilizei este código mas insere numa célula.

""

Sub Inserir_Imagem()
    Dim profile As String
    On Error GoTo 0
    Dim fd As FileDialog
    Dim myCel As Range
    Set myCel = ActiveSheet.Range("F15")
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Filters.Add "Picture Files", "*.bmp;*.jpg;*.gif;*.png"
        .ButtonName = "Select"
        .AllowMultiSelect = False
        .Title = "Choose Photo"
        .InitialView = msoFileDialogViewDetails
        .Show
    End With
    ActiveSheet.Range("E3").Select
    
    With ActiveSheet.Pictures.Insert(fd.SelectedItems(1))
        i = 17
        .Left = myCel.Left
        .Top = myCel.Top
        .Placement = 1
        .PrintObject = True
        profile = .Name
    End With
    ActiveSheet.Pictures(profile).Select
    With Selection.ShapeRange
        .LockAspectRatio = msoFalse
        .Width = myCel.Width
        .Height = myCel.Height
    End With
    
End Sub"

 

Eu queria inserir numa caixa de texto que renomei "foto_produto".

 

Se alguém puder ajudar.

 

@Basole

[RafaVillani]

@Andre4Bom dia, não seria mais fácil carregar a imagem em um controle de imagem? Poderia anexar um modelo da sua planilha para facilitar a ajuda?

 

RafaVillani

[Andre4]

Deixo modelo em anexo para facilitar. Pretendo carregar em inserir e trocar a imagem.

Planilha.xls

[RafaVillani]

@Andre4 Fiz algumas alterações, veja se lhe atende, a imagem é carregada automaticamente, sem a necessidade de se clicar em um botão, basta entrar com o valor de pesquisa na célula AD1.

 

Para testar precisei retirar suas fórmulas das células Ano, Cliente e Nome da Pasta, redigite estas fórmulas e teste a planilha, se precisar poste novamente.

 

RafaVillani

Modelo_Carrega_Fotos.rar

[Andre4]

@RafaVillani

Já tenho configurado dessa forma, a imagem carregar automaticamente apenas alterando o valor de pesquisa. O que eu pretendo é colocar um botão para o caso de querer buscar manualmente por algum motivo.

[RafaVillani]

@Andre4, então está fácil, cole este código no botão.

On Error GoTo trata_erro
Dim FotoNome As String
FotoNome = Application.GetOpenFilename(filefilter:= _
"Arquivos de Imagem(*.jpg),*.jpg", Title:="Selecione uma imagem")
If FotoNome <> "False" Then
Folha3.Foto_Produto.Picture = LoadPicture(FotoNome)
End If

trata_erro:

If Err.Number = 53 Then
End
End If

RafaVillani

[Andre4]

Não funcionou. Eu colei no botão mas não deu nada.

[RafaVillani]

agora, Andre4 disse:

Não funcionou. Eu colei no botão mas não deu nada.

@Andre4Você está usando botão ou forma? Se for forma você devera criar uma Sub dentro de um módulo para este código, depois atribuir a forma à sub criada. Veja meu exemplo.

Modelo_Carrega_Fotos.rar

[Andre4]

@RafaVillani Estava usando uma forma. Eu criei uma Sub num novo módulo e colei esse código mas não funcionou.

[RafaVillani]

@Andre4Substitua esta linha

 

Folha3.foto_produto.Picture = LoadPicture(FotoNome)

 

por esta

ActiveSheet.Shapes("foto_produto").Fill.UserPicture (FotoNome)

 

Veja se funciona.

 

RafaVillani

[Andre4]

@RafaVillani Resultou! Ficou perfeito.

 

Tem forma de somente quando preencher a tabela de pesquisa (Coluna AL) acrescentar novas folhas em baixo?

 

Ou tornar a folha ativa para imprimir. Por exemplo ao preencher uma célula de pesquisa a folha se torna ativa e imprime, se não tiver preenchida não imprime.

[RafaVillani]

@Andre4Veja se lhe atende:

 

Coloque o valor 1 na célula AS7.

 

Copie este código e cole no evento Change da sua planilha, abaixo do End If

Dim linha As Long

Select Case Target.Cells.Column
Case Is = 39
linha = ActiveCell.Row - 1
Folha3.Cells(linha, 38) = "Orç. " & Folha3.Range("AS7")
Folha3.Range("AS7") = Folha3.Range("AS7") + 1
End Select

RafaVillani

[Andre4]

@RafaVillani Acho que não funciona. Colei no change mas não aconteceu nada.

 

A folha orç.1 pode ficar sempre ativa. O que pretendo é quando pesquiso pelo orç.2 , orç.3,etc, aparecer em baixo do orç.1

[RafaVillani]

@Andre4Eu havia entendido que você queria novas folhas, não foi o que disse?

agora, Andre4 disse:

Tem forma de somente quando preencher a tabela de pesquisa (Coluna AL) acrescentar novas folhas em baixo?

Para que o código funcione você tem que fazer alguma alteração na coluna AM, na célula Pesquisa, veja o vídeo, se não for isso, me explique melhor a forma como quer.

 

RafaVillani

Exemplo.rar

[Andre4]

@RafaVillani Não, não era isso que eu procurava. É como na imagem anexo.

[RafaVillani]

@Andre4Entendi, me de algum tempo.

[RafaVillani]

@Andre4Vamos lá.

 

1- Crie uma nova folha e copie a Proposta para esta nova folha, ela será sua base para criarmos as outras.

 

2- Atribua o valor O (Zero) na célula AK1 da folha3.

 

3- Cole este código no evento Change da folha3, após o End If.

 

Dim linha As Long
Dim aux As Long

Select Case Target.Cells.Column
Case Is = 38
aux = 57
Folha1.Range("A1:AJ57").Copy 'altere o número da folha conforme a que você criou
linha = Folha3.Range("A1").CurrentRegion.Rows.Count
Folha3.Cells(linha + aux + Range("AK1"), 1).Select
ActiveCell.PasteSpecial xlPasteAll
Range("AK1") = Range("AK1") + aux
End Select

Espero que lhe atenda.

 

RafaVillani

[Andre4]

@RafaVillani Olá,

 

Experimentei o código e não acontece nada. 

[RafaVillani]

@Andre4Você seguiu todos os passos? Criou uma noma sheet na planilha e copiou o formulário para ela? Alterou a linhas o código corrigindo o nome da nova sheet criada? Atribuiu o valor zero na célula AK1?

[RafaVillani]

@Andre4O código está funcionando, veja o vídeo. Siga a a ordem das instruções e tente novamente.

Modelo_Nova_folha.rar

[Andre4]

@RafaVillani Sim está funcionando, eu ajustei os dados e está copiando. Mas quando eu quiser guardar em PDF guarda todas as folhas. Ou seja, eu queria que quando guarda-se em PDF guarda-se apenas as folhas que correspondem à pesquisa. Se na pesquisa tem Orç.1 e Orç.2 guardar apenas esses dois, se tiver o Orç.1 guarda só esse, está entendendo?