1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
| Private Sub Worksheet_Change(ByVal Target As Range)
Dim feuille As Worksheet
Dim photoplace As Object
Dim choixpersonne As Object
Dim nom As Object
Dim prénom As Object
Dim trigramme As Object
Dim service As Object
Dim site As Object
Dim job As Object
Dim emplacement As Object
Dim telint As Object
Dim teldir As Object
Dim telgsm As Object
Set feuille = ThisWorkbook.Sheets(2)
Set photoplace = feuille.Cells(3, 4)
Set choixpersonne = feuille.Cells(2, 2)
Set nom = feuille.Cells(4, 2)
Set prénom = feuille.Cells(5, 2)
Set trigramme = feuille.Cells(6, 2)
Set service = feuille.Cells(8, 2)
Set site = feuille.Cells(9, 2)
Set job = feuille.Cells(10, 2)
Set emplacement = feuille.Cells(11, 2)
Set telint = feuille.Cells(13, 2)
Set teldir = feuille.Cells(14, 2)
Set telgsm = feuille.Cells(15, 2)
Application.EnableEvents = False
Range("b3:b50").ClearContents
Set filesys = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
On Error GoTo 0
'vérfier s'il y a déja des images et si oui, effacer la photo déja chargée
If feuille.Pictures.Count > 0 Then
feuille.Shapes("Photo").Delete
End If
derlgn = Sheets(1).Cells(Sheets(1).Columns(1).Cells.Count, 1).End(xlUp).Row
Trouve = False
'rechercher a quelle ligne on trouve la premiere occurence qui correspond a la recherche
For i = 1 To derlgn
If (Len(Replace(UCase(Sheets(1).Cells(i, 1)), UCase(choixpersonne), "")) <> Len(Sheets(1).Cells(i, 1))) Or (UCase(choixpersonne) = UCase(Sheets(1).Cells(i, 5))) Then
image = Sheets(1).Cells(i, 4)
Trouve = True
Exit For
End If
Next i
'si on a trouvé la personne, afficher ses données, sinon afficher un message d'erreur
If Trouve Then
'créer l'url de la photo sur base du nom choisit
URL = "G:\DataCom\Eliane\Trombinoscope-final-redimensionne\" & image
nom = Sheets(1).Cells(i, 2)
prénom = Sheets(1).Cells(i, 3)
trigramme = Sheets(1).Cells(i, 5)
job = Sheets(1).Cells(i, 6)
site = Sheets(1).Cells(i, 7)
service = Sheets(1).Cells(i, 9)
emplacement = Sheets(1).Cells(i, 8)
telint = Sheets(1).Cells(i, 10)
teldir = Sheets(1).Cells(i, 11)
telgsm = Sheets(1).Cells(i, 12)
'tester si l'image existe, si oui, on l'affiche et on la nomme, si non, on affiche l'image de secour
If filesys.FileExists(URL) Then
feuille.Pictures.Insert(URL).Name = "Photo"
Else
feuille.Pictures.Insert("Z:\ECR\nopicture.gif").Name = "Photo"
End If
feuille.Shapes("Photo").Left = photoplace.Left
feuille.Shapes("Photo").Top = photoplace.Top
If feuille.Shapes("Photo").Height > 200 Or feuille.Shapes("Photo").Height < 100 Then
feuille.Shapes("Photo").Height = 150
End If
Else
If choixpersonne <> "" Then
MsgBox "Cette personne n'a pas encore été ajoutée à la liste"
End If
End If
Application.EnableEvents = True
End Sub |
Partager