Office 365 Macro Photos sans lien ?

fredannab

XLDnaute Nouveau
Bonjour,
J'ai une macro qui insère automatiquement des photos dans les cases Excel en fonction de la référence donnée. Les photos sont toutes stockées sur un serveur commun à l'entreprise, et on pour nom reference.jpg

Cela fonctionne super bien. Sauf que lorsque j'envoie un fichier Excel à l’extérieur de mon entreprise, les photos ne s'affichent pas, fameuse croix rouge et un message qui dit que Excel ne peut télécharger les photos.

C'est une macro que je traîne depuis des années et que je modifie d'entreprise en entreprise, en général juste le chemin d'accès au serveur. Je ne sais pas si c'est lié à une version d'Excel ou quoi, mais jusque là je n'avais jamais eu de soucis. C'est un informaticien qui l'avait construite et je vous avouerai ne pas comprendre tout le code...!

Est-ce que quelqu'un parmi vous aurait la solution ? Je ne sais pas, modifier les paramètres de la photo une fois importée pour qu'elle reste en dur dans le fichier par exemple ?...

MERCI !!!!

Le code de la macro:
----------------------------------------------

Sub Macro_Photo()

Dim rngTmp As Range
Dim rowTmp As Range
Dim rngInsert As Range
Dim tmpFamily As String
Dim tmpPath As String
Dim tmpFile As String
Dim tmpFileOrig As String
Dim cell_photo As Range
Dim img As Object


Set rngTmp = Selection
tmpFile = "Ces articles n'existent pas en photo"
tmpFileOrig = tmpFile

Dim posColstr As String
Dim posCol As Integer

posColstr = InputBox("En quelle colonne voulez-vous inserer vos photos (1, 2, 3...)?", "Colonne", 1)
posCol = CInt(posColstr)

If posCol = 0 Then posCol = 1

For Each rowTmp In rngTmp.Rows
tmpFamily = Mid(rowTmp.Cells(1, 1), 4, 2)


tmpPath = "\\10.0.1.185\projects\COMMUN\PHOTOS skus" + "\" + CStr(rowTmp.Cells(1, 1)) + ".jpg"
If Dir(tmpPath) <> "" Then


ActiveSheet.Cells(rowTmp.Cells(1, 1).Row, rowTmp.Cells.Column).Select
ActiveSheet.Cells(Selection.Row, posCol).Select
ActiveSheet.Pictures.Insert(tmpPath).Select

dblFactorH = rowTmp.Height / Selection.Height * 0.8

Selection.Name = rowTmp.Cells(1, 1)

' Selection.ShapeRange.ScaleWidth dblFactorW, msoFalse, msoScaleFromTopLeft'
Selection.ShapeRange.ScaleHeight dblFactorH, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.IncrementLeft 4
Selection.ShapeRange.IncrementTop 2



Else
tmpFile = tmpFile + vbCrLf + rowTmp.Cells(1, 1)
End If
Next rowTmp

If tmpFile <> tmpFileOrig Then
MsgBox tmpFile
End If

End Sub
 

Discussions similaires


Haut Bas