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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
| Private Sub cmdAjouterPhotos_Click()
Dim sCheminPhoto As String, l As Long, sRef As String, sParent As String
Dim rs As DAO.Recordset
Dim oFileDlg As Object
' Est-ce que le formulaire est intégré en tant que sous-formulaire ?
sParent = ""
On Error Resume Next
sParent = Me.Parent.Name
On Error GoTo 0
If Len(sParent) = 0 Then
MsgBox "Cette fonction n'est pas applicable lorsque le formulaire est ouvert directement.", vbInformation, "Attention!"
Exit Sub
End If
sRef = Nz(Me.Parent.Controls(CS_CHP_CLE), "")
If Len(sRef) = 0 Then
MsgBox "La référence doit être renseignée dans le formulaire principal.", vbInformation, "Attention!"
Exit Sub
End If
sCheminPhoto = GetParam("CHEMIN_PHOTOS", "TParamsAnnonce")
If Len(sCheminPhoto) = 0 Then
MsgBox "Paramètre CHEMIN_PHOTOS non initialisé", vbExclamation, "Erreur paramètre"
Exit Sub
End If
Set oFileDlg = Application.FileDialog(1) ' 1=msoFileDialogOpen
oFileDlg.AllowMultiSelect = True
oFileDlg.InitialFileName = sCheminPhoto
oFileDlg.Filters.Clear
oFileDlg.Filters.Add "Photos", "*.bmp;*.jpg;*.jpeg;*.gif;*.png"
oFileDlg.Filters.Add "Tous", "*.*"
If oFileDlg.Show Then
Set rs = Me.RecordsetClone
For l = 1 To oFileDlg.SelectedItems.Count
rs.AddNew
rs(CS_CHP_CLE) = sRef
rs("photo") = GetFileFromPathFile(oFileDlg.SelectedItems(l))
rs.Update
Next
Set rs = Nothing
Me.Refresh
End If
Set oFileDlg = Nothing
End Sub
Private Sub Form_Current()
Dim fm As Access.Form
Dim sCheminPhoto As String, sFichPhoto As String
Dim sCheminCompletPhoto As String
Dim lDirLen As Long
On Error GoTo ErrH
Set fm = GetParentForm()
If (fm Is Nothing) Then
Exit Sub
End If
sFichPhoto = Nz(Me.photo, "")
If Len(sFichPhoto) = 0 Then
AfficherPhotoAbsente
Exit Sub
End If
sCheminPhoto = GetParam("CHEMIN_PHOTOS", "TParamsAnnonce")
If Len(sCheminPhoto) = 0 Then
AfficherPhotoAbsente
MsgBox "Paramètre CHEMIN_PHOTOS non initialisé", vbExclamation, "Erreur paramètre"
Exit Sub
End If
sCheminCompletPhoto = sCheminPhoto & "\" & sFichPhoto
On Error GoTo ErrNext
lDirLen = Len(Dir(sCheminCompletPhoto, vbNormal))
On Error GoTo ErrH
If lDirLen = 0 Then
AfficherPhotoAbsente
MsgBox "Fichier non trouvé:" & vbCrLf & sCheminCompletPhoto, vbExclamation, "Erreur Photo"
Exit Sub
End If
' Ne changer la photo que si ce n'est pas la même
If fm.Controls("imgPhoto").Picture <> sCheminCompletPhoto Then
fm.Controls("imgPhoto").Picture = sCheminCompletPhoto
fm.Controls("lblPhoto").Caption = sFichPhoto
End If
ExitP:
Exit Sub
ErrH:
MsgBox "Error No." & err.Number & " : " & err.Description, vbCritical, "fmPhotosListe.Form_Current()"
Resume ExitP
ErrNext:
Resume Next
End Sub |
Répondre avec citation
Envoyé par LedZeppII
Partager