-1

Bom dia! Estou utilizando o código abaixo, mas ele não coloca a imagem corretamente na célula mesclada e eu gostaria que a imagem ficasse do tamanho da célula mesclada

        Public Sub Carregarfoto1()
       
       Dim photoNameAndPath As Variant
    Dim photo As Picture
    photoNameAndPath = Application.GetOpenFilename(Title:="")
    If photoNameAndPath = False Then Exit Sub
        Set photo = ActiveSheet.Pictures.Insert(photoNameAndPath)
        With photo
           .Left = ThisWorkbook.Worksheets("Template").Range("C205").Left
           .Top = ThisWorkbook.Worksheets("Template").Range("C205").Top
           .Width = ThisWorkbook.Worksheets("Template").Range("C205").Width
           .Height = ThisWorkbook.Worksheets("Template").Range("C205").Height
           
           .Placement = 1
    
        End With
         
    End Sub
3
  • Range("C205").Left, assim como Top, Width e Height, não retornam as medidas da área inteira, e sim somente da célula C205, como se não estivesse mesclada. Para obter as medidas da célula mesclada por inteiro, você precisa pegar: ThisWorkbook.Worksheets("Template").Range("C205").MergeArea.Left (e também top, width e height). Commented 17/04/2023 às 18:07
  • Poxa me ajudou muito, obrigada! Mas a foto está saindo muito pra cima sabe como posso trazer ela mais pra baixo?
    – Ana Pizani
    Commented 20/04/2023 às 17:29
  • Mexa no top, assim: .Top = ThisWorkbook.Worksheets("Template").Range("C205").Top + 10. Aí em vez de +10, Você testa um número útil pra você. Commented 23/04/2023 às 16:25

1 Resposta 1

-3

Oi tudo bem? Use o código abaixo que vai resolver seu problema:

Public Sub Carregarfoto1()
Dim photoNameAndPath As Variant
Dim photo As Picture
Dim CelulaFotoImagem As Range

photoNameAndPath = Application.GetOpenFilename(Title:="")

If photoNameAndPath = False Then Exit Sub

Set photo = ActiveSheet.Pictures.Insert(photoNameAndPath)
Set CelulaFotoImagem = ThisWorkbook.Worksheets("Template").Range("C205")

With photo
    'Ajustar aqui a proporção da imagem
    .Left = CelulaFotoImagem.Left + 1
    .Top = CelulaFotoImagem.Top + 1
    
    'Seta Proporção para 100%
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
    .ShapeRange.ScaleWidth 1, msoTrue, msoScaleFromTopLeft
    .ShapeRange.LockAspectRatio = msoTrue
    
    'Reduz proporcionalmente até "caber" na celula
    .Width = CelulaFotoImagem.MergeArea.Width - 2
    Do While .Height > CelulaFotoImagem.MergeArea.Height - 2
        .Width = .Width - 1
    Loop
   
   
    'Ajusta imagem no centro da celula
    'Se quiser centralizar, descomente esses duas linha abaixo
    '.Left = CelulaFotoImagem.Left + 1 + ((CelulaFotoImagem.Width - .Width) / 2)
    '.Top = CelulaFotoImagem.Top + 1 + ((CelulaFotoImagem.Height - .Height) / 2)
   
   
    'Ajusta imagem na célula com crop
    .Left = CelulaFotoImagem.Left + 1
    .Top = CelulaFotoImagem.Top + 1
    .ShapeRange.PictureFormat.Crop.ShapeWidth = CelulaFotoImagem.MergeArea.Width - 2
    .ShapeRange.PictureFormat.Crop.ShapeHeight = CelulaFotoImagem.MergeArea.Height - 2
    .ShapeRange.PictureFormat.Crop.PictureOffsetX = 0
    .ShapeRange.PictureFormat.Crop.PictureOffsetY = 0
   
    
    .Placement = 1
End With

End Sub

1
  • Curioso como um código que funciona adequadamente para a questão receba tantos votos negativos. Se alguém quiser testar o código, renomeie uma aba para o nome "Template" (sem aspas) e mescle algumas células a partir da C205. Vocês verão que funciona. Obrigado para quem isso foi útil. Commented 4/07/2023 às 13:29

Você deve fazer log-in para responder a esta pergunta.

Esta não é a resposta que você está procurando? Pesquise outras perguntas com a tag .