Re : Importer et valider Images Via Usf vers BD
Bonjour
Essaye en compressant ton fichier Excel
(Clic-droit -> Envoyer vers -> Dossiers compressés
Tu obtiendras un nomfichierexcel.zip
Postes ce fichier sur le forum
Bonjour
Merci de ta réponse ,m
mais même en Zip il dépasse 50 Ko,,Je met le Code de mon Usf
Option Explicit
'*****Code de Mon Usf "F_Lettre2"
Dim Btn(1 To 27) As New ClasseLettres
Dim ligne
Dim b
Dim c
Dim temp
Dim répertoire
Private Sub B_imprime_Click()
ImprimeAnnuaire
End Sub
Private Sub CommandButton2_Click()
Me.PrintForm
End Sub
Private Sub UserForm_Initialize()
For b = 1 To 27: Set Btn(b).GrLettres = Me("B_" & b): Next b
Sheets("BD").[A2:J5000].Sort key1:=Sheets("BD").[A2]
'-- Liste des noms
Me.Lettre = "Tous"
majChoixNom
ligne = 2
majFiche
End Sub
Private Sub ChoixNom_Click()
ligne = Sheets("BD").[A:A].Find(choixnom, LookIn:=xlValues).Row
majFiche
End Sub
Sub majFiche()
Me.nom = Sheets("BD").Cells(ligne, 1)
Me.Carrefour = Sheets("BD").Cells(ligne, 2)
Me.Auchan = Sheets("BD").Cells(ligne, 3)
Me.Leclerc = Sheets("BD").Cells(ligne, 4)
Me.Casino = Sheets("BD").Cells(ligne, 5)
Me.SuperU = Sheets("BD").Cells(ligne, 6)
Me.GeantCasino = Sheets("BD").Cells(ligne, 7)
Me.Intermarche = Sheets("BD").Cells(ligne, 8)
Me.ED = Sheets("BD").Cells(ligne, 9)
Me.Commentaire = Sheets("BD").Cells(ligne, 10)
répertoire = ThisWorkbook.Path
If Dir(répertoire & "\" & Me.nom & ".jpg") <> "" Then
Me.Image1.Picture = LoadPicture(répertoire & "\" & Me.nom & ".jpg")
Else
On Error Resume Next
Me.Image1.Picture = LoadPicture(répertoire & "\" & "transparent.gif")
End If
End Sub
Private Sub b_validation_Click()
If Me.nom = "" Then
MsgBox "Saisir un nom!"
Me.nom.SetFocus
Exit Sub
End If
Set temp = Sheets("BD").[A:A].Find(Me.nom, LookIn:=xlValues)
If Not temp Is Nothing Then
If temp.Row <> ligne Then
MsgBox "Ce Nom de Produit Existe déjà!"
Exit Sub
End If
End If
'---- transfert base
Sheets("bd").Cells(ligne, 1) = Application.Proper(Me.nom)
Sheets("bd").Cells(ligne, 2) = Me.Carrefour
Sheets("bd").Cells(ligne, 3) = Me.Auchan
Sheets("bd").Cells(ligne, 4) = Me.Leclerc
Sheets("bd").Cells(ligne, 5) = Me.Casino
Sheets("bd").Cells(ligne, 6) = Me.SuperU
Sheets("bd").Cells(ligne, 7) = Me.GeantCasino
Sheets("bd").Cells(ligne, 8) = Me.Intermarche
Sheets("bd").Cells(ligne, 9) = Me.ED
Sheets("bd").Cells(ligne, 10) = Me.Commentaire
Me.nom.SetFocus
Sheets("BD").[A2:J5000].Sort key1:=Sheets("BD").[A2]
ligne = Sheets("BD").[A:A].Find(Me.nom, LookIn:=xlValues).Row
majChoixNom
End Sub
Private Sub B_ajout_Click()
ligne = Sheets("BD").[A65000].End(xlUp).Row + 1
nettoie
End Sub
Private Sub B_sup_Click()
rep = MsgBox("Etes vous sûr?", vbYesNo)
If rep = vbYes Then
Sheets("BD").Rows(ligne).Delete
nettoie
ligne = Sheets("BD").[A65000].End(xlUp).Row + 1
majChoixNom
End If
End Sub
Private Sub B_suiv_Click()
If Me.Lettre = "Tous" Then
If ligne < Sheets("BD").[A65000].End(xlUp).Row Then
If Me.nom <> "" Then b_validation_Click
ligne = ligne + 1
majFiche
End If
Else
If Left(Sheets("bd").Cells(ligne + 1, 1), 1) = Me.Lettre Then
If Me.nom <> "" Then b_validation_Click
ligne = ligne + 1
majFiche
End If
End If
End Sub
Private Sub B_prec_Click()
If Me.Lettre = "Tous" Then
If ligne > 2 Then
If Me.nom <> "" Then b_validation_Click
ligne = ligne - 1
majFiche
End If
Else
If Left(Sheets("bd").Cells(ligne - 1, 1), 1) = Me.Lettre Then
If Me.nom <> "" Then b_validation_Click
ligne = ligne - 1
majFiche
End If
End If
End Sub
Sub nettoie()
Me.nom = ""
Me.Carrefour = ""
Me.Auchan = ""
Me.Leclerc = ""
Me.Casino = ""
Me.SuperU = ""
Me.GeantCasino = ""
Me.Intermarche = ""
Me.ED = ""
Me.Commentaire = ""
Me.nom.SetFocus
End Sub
Sub majChoixNom()
Me.choixnom.Clear
If Me.Lettre = "Tous" Then
For Each c In Range(Sheets("BD").[A2], Sheets("BD").[A65000].End(xlUp))
Me.choixnom.AddItem c
Next c
Else
For Each c In Range(Sheets("BD").[A2], Sheets("BD").[A65000].End(xlUp))
If Left(c.Value, 1) = Me.Lettre Then Me.choixnom.AddItem c
Next c
End If
End Sub
Private Sub b_fin_Click()
Unload Me
End Sub
'Private Sub nom_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
'temp = Application.Match(Me.nom, [A2:A10000], 0)
'If Not IsError(temp) Then
' MsgBox "Doublon"
' Cancel = True
' Exit Sub
'End If
'End Sub
ET EN PIECE JOINTE L'USERFORM + Doc Word du Code Complet
Sincérement merci
Christian