Gestion de photos par formulaire

Private Sub Form_Current()
' L'événement Activation (Current) se produit lorsque le focus passe à un enregistrement
'  donné pour en faire l'enregistrement en cours, ou lorsque le formulaire est
'  Actualisé ou en Actualisation.
 
' si le nom du salarié est non vide : on visualise un enregistrement
'  sinon cela indique que nous sommes sur un enregistrement vierge, donc en cours de saisie.
'  Me.Caption : gère le titre du formulaire.
If Len(Me.Nom) > 0 Then
    Me.Caption = "Détails pour le salarié : " & Me.Nom & " - " & Me.Prénom
Else
    Me.Caption = "Saisie d'un nouveau salarié"
End If
 
' Gestion des erreurs
On Error GoTo Catch02
 
' si la photo n'est pas définie, on affiche la photo blank.jpg
' CurrentProject.Path : est le chemin de l'application
If Len(Me.Photo) > 0 Then
    Me.imgPhoto.Picture = Me.Photo
Else
    Me.imgPhoto.Picture = CurrentProject.Path & "\images\blank.jpg"
End If
 
DisplayPhoto
 
Exit Sub
 
Catch02 :
Select Case Err.Number
    Case 2114
        'Cas d'un type de fichier photo non supporté ...
        MsgBox "Le format de l'image n'est pas supporté par le contrôle image Picture", vbCritical + vbOKOnly, "Application Photos"
        Me.imgPhoto.Picture = CurrentProject.Path & "\images\blank.jpg"
        Me.Photo = vbNullString
    Case 2220
        'Cas d'un emplacement non valide du fichier image
        MsgBox "Le fichier image n'a pas été trouvé à l'emplacement indiqué : " & vbCrLf & _
                Me.Photo, vbCritical + vbOKOnly, "Application Photos"
        Me.imgPhoto.Picture = CurrentProject.Path & "\images\blank.jpg"
        Me.Photo = vbNullString
    Case Else
        ' tout autre cas d'erreur
        MsgBox "Erreur inattendue : " & Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Application Photos"
End Select
Err.Clear
 
End Sub

Sub DisplayPhoto()
' Traitement en fonction de la taille de l'image
 
' regarde si la hauteur de l'image dépasse celle du contrôle Picture
If Me.imgPhoto.ImageHeight > Me.imgPhoto.Height Then
    ' met le contrôle en mode zoom
    Me.imgPhoto.SizeMode = 3
Else
    ' met le contrôle en mode respect de la taille originale
    Me.imgPhoto.SizeMode = 0
End If
 
' si la largeur dépasse et qu'on est en mode taille réelle ...
If (Me.imgPhoto.ImageWidth > Me.imgPhoto.Width) And (Me.imgPhoto.SizeMode) = 0 Then
    ' on met en mode zoom
    Me.imgPhoto.SizeMode = 3
End If
 
 
End Sub

Private Sub cmdDelete_Click()
 
' Bouton de commande d'effacement de la photo
 
 
 
' supprime l'adresse de la photo
 
Me.Photo = vbNullString
 
 
 
' affiche l'image blank.jpg
 
Me.imgPhoto.Picture = CurrentProject.Path & "\images\blank.jpg"
 
 
 
' redimensionne la photo
 
DisplayPhoto
 
 
 
End Sub
 
 
 
Private Sub cmdPhoto_Click()
 
' Bouton d'ajout - modification de photo
 
Dim strLink As String
 
 
 
' Gestion des erreurs
 
On Error GoTo Catch01
 
 
 
' récupération du chemin physique de la photo
 
'  par la boite de dialogue
 
strLink = OuvrirUnFichier(Me.Hwnd, _
 
                         "Sélectionner une photo pour le salarié " & Me.Nom, _
 
                         1)
 
 
 
' si la boite renvoie une adresse non nulle
 
If Len(strLink) > 0 Then
 
    ' tentative d'affichage de la photo
 
    Me.imgPhoto.Picture = strLink
 
    Me.Photo = strLink
 
End If
 
 
 
DisplayPhoto
 
Exit Sub
 
 
 
Catch01 :
 
Select Case Err.Number
 
    Case 2114
 
        'Cas d'un type de fichier photo non supporté ...
 
        '  on sort de la procédure
 
        MsgBox "Le format de l'image n'est pas supporté par le contrôle image Picture", vbCritical + vbOKOnly, "Application Photos"
 
        Exit Sub
 
    Case 2220
 
        'Cas d'un emplacement non valide du fichier image
 
        MsgBox "Le fichier image n'a pas été trouvé à l'emplacement indiqué : " & vbCrLf & _
 
                Me.Photo, vbCritical + vbOKOnly, "Application Photos"
 
        Exit Sub
 
    Case Else
 
        ' tout autre cas d'erreur
 
        MsgBox "Erreur inattendue : " & Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Application Photos"
 
End Select
 
Err.Clear
 
 
 
 
 
End Sub