Ajout de photos avec un code VBA
A
Bonjour,
Je comprends pas beaucoup le vba et j'ai essayé d'adapter le code que quelqu'un m'avait fourni sans beaucoup de succès. Est-ce que quelqu'un peut m'indiquer ce qui ne fonctionne pas?
Merci d'avance.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Const CC_COL_PHOTOS = 3
Const CC_LIG_MIN = 3
Const CC_LIG_MAX = 500
Const CC_COL_LOT_NUMBER = 4
If (Target.Column = CC_COL_PHOTOS) And (Target.Row >= CC_LIG_MIN) And (Target.Row <= CC_LIG_MAX) And (ActiveSheet.Cells(CC_COL_LOT_NUMBER, Target.Row).Value <> "") Then
Cancel = True
InsererPhoto1 Target, ActiveSheet.Cells(CC_COL_LOT_NUMBER, Target.Row).Value
End If
End Sub
Private Sub InsererPhoto1(rngPhotoComparables As Range, vLotNumber As Variant)
Dim fName As String
Dim L As Single, T As Single, W As Single, H As Single
Dim cLotNumber As String
Dim wsRC As Worksheet
Dim tsDataRC As ListObject
Dim nLigRC As Long
Dim shTmp As Shape
On Error Resume Next
cLotNumber = Format(vLotNumber, "#,###,##0")
fName = Application.GetOpenFilename(FileFilter:="Images (*.jpg;*.jpeg;*.gif;*.png),*.jpg;.jpeg;*.gif;*.png", _
Title:="Please select the photo corresponding to lot number " & cLotNumber & " ...")
If fName = "False" Then Exit Sub
With rngPhotoComparables
L = .Left
T = .Top
W = .Width
H = .Height
End With
ActiveSheet.Shapes.AddPicture fName, True, True, L, T, W, H
If Err.Number <> 0 Then
MsgBox "L'insertion de l'image n'a pas abouti." & vbCrLf & "Code errreur " & Err.Number & " - " & Err.Description, vbExclamation, "Image à associer au n° de lot"
Err.Clear
On Error GoTo 0
End If
End Subf