VBA busca fotos
Enviado: 20 Mai 2019 às 11:58
Bom dia a todos !
O código abaixo, busca a foto do item na "rede" da empresa no caminho informado. Porém quando salvo a planilha e envio a outra pessoa, as fotos não abrem... Provavelmente é devido a não estarem na mesma "rede" que eu !
Mas é possível resolver ? Existe outra forma ? Ou somente se copiar todas fotos para a planilha ?
Fico no aguardo,
Segue código !
'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
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
O código abaixo, busca a foto do item na "rede" da empresa no caminho informado. Porém quando salvo a planilha e envio a outra pessoa, as fotos não abrem... Provavelmente é devido a não estarem na mesma "rede" que eu !
Mas é possível resolver ? Existe outra forma ? Ou somente se copiar todas fotos para a planilha ?
Fico no aguardo,
Segue código !
'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
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