Este fórum está sendo desativado

[LeoHenrique]

Bom dia a todos !
Pessoal, apenas uma pergunta... Tenho uma macro que busca fotos pelo número do ítem e coloca ao lado... O que não consegui fazer, é manter a foto "pois como é um link que busca no meu pc", quando outra pessoa abre a planilha em outro computador, a foto não abre.
- É possível copiar a foto, e como fazemos com fórmulas "colar especial valores" para mantê-la ?

Ficarei muito agradecido se alguém souber como, "se é possível" !!

Muito obrigado !
Leandro Henrique

[osvaldomp]

Veja se ajuda.
O código abaixo insere uma foto sem vínculo em D5:E11 da planilha ativa; nome da foto em A1.

Código: Selecionar todos

Sub InsereFoto()
 Dim r As Range, sPath As String, shp As Shape
  'On Error Resume Next
  Set r = [D5].Resize(7, 2)
  sPath = "C:\Fotos\Pessoas\" & [A1] & ".jpg"
  Set shp = ActiveSheet.Shapes.AddPicture(sPath, _
    False, True, r.Left, r.Top, r.Width, r.Height)
End Sub

[LeoHenrique]

Boa tarde !!!

Obrigado pelo retorno Osvaldo, mas não consegui fazer funcionar... Para melhor entender o que quero, segue a planilha que estão as fotos. E o código que uso para puxar as fotos está abaixo :
Lembrando que quando envio a planilha para outra pessoa, as fotos não abrem !
Muito obrigado por enquanto !

'Colocar fotos
'Definir intervalo onde estão os códigos das imagens
Dim TodosCod, Cod As Range
Set TodosCod = ActiveSheet.Range("B2:B512")

'Definir variáveis para o procedimento de inserção de fotos
Dim Pasta, Ext, TxtCod As String
Dim Fig As Shape
Dim FigJaExist As Boolean
Pasta = "S:\Comercial\Usuários\Leandro\Fotos\"
Ext = ".jpg"

'Inserir a imagem baseado no código da imagem
For Each Cod In TodosCod
TxtCod = Cod.Value
FigJaExist = False

'Checar a existência do arquivo
If Not Dir(Pasta & TxtCod & Ext) = "" Then

'Checar se há alguma foto na célula de destino
For Each Fig In ActiveSheet.Shapes
If Fig.TopLeftCell.Address = Cod.Offset(0, 1).Address Then FigJaExist = True
Next Fig

'Se não houver foto na célula, inserir o arquivo
If FigJaExist = False Then
With ActiveSheet.Pictures.Insert(Pasta & TxtCod & Ext)
.Left = Cod.Offset(0, 1).Left
.Top = Cod.Offset(0, 1).Top
'...caso queira determinar a largura e altura da imagem
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Width = 105
.ShapeRange.Height = 62
End With
End If
End If
Next Cod

'Run "ArrasCont"

Dim rng As Range
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
Set rng = shp.TopLeftCell
shp.Left = rng.Left + (rng.Width - shp.Width) / 2
shp.Top = rng.Top + (rng.Height - shp.Height) / 2
Next shp

[osvaldomp]

... mas não consegui fazer funcionar...
O que exatamente você fez que não conseguiu fazer funcionar? Descreva o passo a passo do que você fez.

Lembrando que quando envio a planilha para outra pessoa, as fotos não abrem !
Sim, isso eu já havia entendido. O código que passei é justamente para corrigir essa situação.

[LeoHenrique]

Bom dia Osvaldo !!
Obrigado pelo retorno !
Usei apenas o seu código, funcionou sim !! Obrigado !!!
Porém gostaria que buscasse as fotos dos calçados que têm números, até a linha 512 e ajustar dentro da célula. É possível ?

"O código está da forma abaixo, ajustei o caminho das fotos"

Sub Coloca_e_fixa_fotos()

'Sub InsereFoto()
Dim r As Range, sPath As String, shp As Shape
'On Error Resume Next
Set r = [D5].Resize(7, 2)
sPath = "S:\Comercial\Usuários\Leandro\Fotos\" & [B8] & ".jpg"
Set shp = ActiveSheet.Shapes.AddPicture(sPath, _
False, True, r.Left, r.Top, r.Width, r.Height)

End Sub

Leandro

[LeoHenrique]

Complementando... o código funcionou perfeitamente, mas buscou apenas a 1º foto, gostaria que buscasse todas as fotos para os números que aparecem ao lado !

[osvaldomp]

... o código funcionou perfeitamente, mas buscou apenas a 1º foto ...
O código que passei insere UMA FOTO, conforme comentei antes, e foi pra você testar e adaptar ao seu código.

Porém gostaria que buscasse as fotos dos calçados que têm números, até a linha 512 ...
O código abaixo insere na coluna C as fotos sem vínculos, nomeadas de B7 até a última linha com dados na coluna B da planilha ativa.

Código: Selecionar todos

Sub InsereRedimensionaFotos()
 Dim r As Range, sPath As String, shp As Shape
  On Error Resume Next
  For Each r In Range("B7:B" & Cells(Rows.Count, 2).End(3).Row)
   sPath = "S:\Comercial\Usuários\Leandro\Fotos\" & r.Value & ".jpg"
   Set shp = ActiveSheet.Shapes.AddPicture(sPath, False, True, _
    r.Offset(, 1).Left, r.Offset(, 1).Top, r.Offset(, 1).Width, r.Offset(, 1).Height)
   On Error GoTo 0
  Next r
End Sub

[LeoHenrique]

Bom dia a todos !
Muito obrigado por ajudar Osvaldo ! Funcionou perfeitamente !
Estou tentando agora apenas ajustar a foto dentro da célula, no código acima a foto apenas não se ajusta dentro da célula, fica um pouco pra fora.
Estou quebrando a cabeça, mas aprendendo... e se não for pedir muito, é possível adaptar o código abaixo na continuação do código que vc me enviou ? Pois esse abaixo, adaptei ao anterior que eu tinha e ajustou a foto dentro da célula corretamente.

(Esse abaixo é o código que me enviou, "perfeito, manteve a foto sem o vínculo")

Sub InsereRedimensionaFotos()

Dim r As Range, sPath As String, shp As Shape
On Error Resume Next
For Each r In Range("B7:B" & Cells(Rows.Count, 2).End(3).Row)
sPath = "S:\Comercial\Usuários\Leandro\Fotos\" & r.Value & ".jpg"


Set shp = ActiveSheet.Shapes.AddPicture(sPath, False, True, _
r.Offset(, 1).Left, r.Offset(, 1).Top, r.Offset(, 1).Width, r.Offset(, 1).Height)
On Error GoTo 0


Next r
End Sub

E o abaixo, é o código que adaptei ao anterior que eu usava.... é possível adaptar ele para ajustar a foto ?
Dim rng As Range
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
Set rng = shp.TopLeftCell
shp.Left = rng.Left + (rng.Width - shp.Width) / 2
shp.Top = rng.Top + (rng.Height - shp.Height) / 2
Next shp

[osvaldomp]

Estou tentando agora apenas ajustar a foto dentro da célula, no código acima a foto apenas não se ajusta dentro da célula, fica um pouco pra fora.

Você pode colocar aqui no fórum uma planilha com 3 ou fotos com as dimensões ajustadas manualmente nas células (ou inseridas com o seu código) que mostrem como você deseja que fiquem ?

[LeoHenrique]

Bom dia Osvaldo !!

Segue a planilha... Nas macros, deixei apenas o código que eu usava "ExecutaColocarFotos", e o que você me passou "InsereRedimensionaFotos".
Na primeira coluna, estão as fotos ajustadas dentro das células, e na segunda coluna estão as fotos pelo seu código. Um detalhe, no seu código quando o código não localiza a referência, ele pára. E se tiver como continuar e deixar em branco, ficará excelente.

Desde já, agradeço imensamente sua ajuda !
Leandro Henrique

[osvaldomp]

Leandro, alterei os comandos com base na planilha que você postou. Experimente o código abaixo e veja se melhorou quanto ao tamanho das figuras e as posições delas nas células.
Quanto a interromper a execução ao não encontrar o nome da foto, foi erro meu, desculpe. O tratamento de erro estava na posição incorreta no código anterior.

Código: Selecionar todos

Sub InsereRedimensionaFotos()
 Dim r As Range, sPath As String, shp As Shape
  For Each r In Range("B7:B" & Cells(Rows.Count, 2).End(3).Row)
   sPath = "S:\Comercial\Usuários\Leandro\Fotos\" & r.Value & ".jpg"
   On Error Resume Next
   Set shp = ActiveSheet.Shapes.AddPicture(sPath, False, True, _
    r.Offset(, 1).Left + r.Offset(, 1).Width * 0.05, _
    r.Offset(, 1).Top + r.Offset(, 1).Height * 0.1, _
    r.Offset(, 1).Width * 0.9, r.Offset(, 1).Height * 0.8)
   On Error GoTo 0
  Next r
End Sub

[LeoHenrique]

Bom dia a todos !!

Muito obrigado Osvaldo !! Perfeito !! Ficou top agora !!

Ainda quero chegar nesse ponto !! Muito obrigado mesmo pela ajuda !!

Iniciei este ano o curso e graduação á distância "Análise e Desenvolvimento de Sistemas" pela Unicesumar ! Estou gostando muito !
E sobre os códigos no VBA, ás vezes tenho dúvidas... se puder te contatar ás vezes por e-mail, me envie uma mensagem por favor,
leandro.manhani@gmail.com

Abraço