TRIER DES PHOTOS A LA VOLEE

Résolu

SERIEUXETCOOL Messages postés 336 Date d'inscription dimanche 3 avril 2011 Statut Membre Dernière intervention 12 juin 2012 - 3 mars 2012 à 02:48
SERIEUXETCOOL Messages postés 336 Date d'inscription dimanche 3 avril 2011 Statut Membre Dernière intervention 12 juin 2012 - 11 mars 2012 à 17:51

Bonsoir le Forum,

Je suis à la recherche de quelques lignes de code qui m'aideraient à réaliser une opération que je fait souvent et que je trouve fastidieuse !

Voila la chose :

-J'ai un dossier qui contient uniquement des photos. A chaque fois je dois ouvrir ce dossier, prendre les 13 premières photos, les copier, les coller dans le répertoire précédent celui qui contient les photos (en gros je sors les photos du dossier pour pouvoir les traiter).
Une fois les 13 premières photos collées, je supprime les 5 premières et les 5 dernières pour ne garder que les 3 du milieu.

-Ensuite je retourne dans mon dossier qui contient les photos, je sélectionne une deuxième série qui contient 14 photos cette fois-ci. Je copie-colle cette série à la suite des 3 photos qui sont à la racine du dossier qui contient toutes les photos. Je ne travaille que sur les 14 photos importées, je supprime les 6 premières, je supprime les 5 dernières pour n'en garder de nouveau que 3.

-Ce dossier contient donc 6 photos qui sont le résultat "épuré" d'une série de photos.

-Et ainsi de suite. Je retourne donc dans mon dossier qui contient toutes les photos, je sélectionne les 13 prochaines photos, je les sors du dossier par copie, je les colles et supprime les 5 premières et 5 dernières. Plus 3 photos sont donc ajoutées.

-Je retourne dans mon dossier qui contient toutes les photos, je copie-colle les 14 nouvelles photos et supprime les 6 premières et 5 dernières.

Etc, Etc jusqu'à parcourir toutes les photos du dossier.

Le but étant de sortir du dossier qui contient toutes les photos uniquement un échantillons caractérisé.

Voici comment je verrai le fichier Excel :

Un fichier Excel qui possède un bouton de commande. Ce bouton de commande permet de sélectionner le dossier qui contient toutes les photos et de lancer l'extraction.

Une cellule qui contient le nombre de photos de la première série que l'on veut extraire (dans mon cas 13 mais ça peut varier).
Une cellule qui définis le nombre de photos que l'on souhaite garder de la série.

Et la même chose pour la deuxième série, c'est à dire :

Une cellule qui contient le nombre de photos de la deuxième série que l'on veut extraire (dans mon cas 14 mais ça peut varier).
Une cellule qui définis le nombre de photos que l'on souhaite garder de la série.

En fonction des nombres paires et impaires je me fiche de savoir de quel bord de la série on doit garder les photos. On en choisis en un et puis c'est tout.

A chaque fois on doit sortir obligatoirement le bon nombre de photos. Dans mon cas pour les deux séries il faut sortir tout le temps 3 photos.

Il est également indispensable de réaliser une copie et non un couper !

Mon dossier contient plusieurs centaines de photos.

Des questions, des remarques je reste disponible. Pour une fois, je dois avouer que ce code m'aiderais si je pouvais l'obtenir pour ce weekend. Sinon je vais tout me taper à la main ENCORE. Et j'avoue que j'ai pas envie de passer mon weekend à faire ce traitement pourtant obligatoire pour la suite de mon projet.

Merci à tous ceux qui sauront m'aider.

Bien cordialement,

André

A voir également:

TRIER DES PHOTOS A LA VOLEE
Trier une colonne excel par ordre alphabétique vba - Forum Visual Basic
Trier par ordre alphabétique un tableau. - Forum Visual Basic 6
Trier en arabe ✓ - Forum ASP / ASP.NET
Ordre alphabétique sur + colonnes en vba - excel ✓ - Forum Visual Basic 6
Base de données photos ✓ - Forum Visual Basic 6

84 réponses

Réponse 81 / 84

SERIEUXETCOOL Messages postés 336 Date d'inscription dimanche 3 avril 2011 Statut Membre Dernière intervention 12 juin 2012 1
11 mars 2012 à 15:14

Pas de soucis pour les ajouts Ucfoutu.

Personnellement j'ai 40 dossiers à extraire impérativement avant ce soir. Donc vu que le code est fonctionnel pour le moment, et bien je vais commencer à l'utiliser ainsi.

J'utiliserai le code finalisé par la suite car je vais en avoir besoin au quotidien quasiment. Mais la c'est plus qu'urgent, faut que je commence l’extraction coute que coute sinon je ne serai plus du tout dans les impératifs que je me suis fixé.

Je viens de commencer une extraction réelle et tout de suite je me suis heurté à une limitation du code. La taille de la liste des noms était fixé ainsi "ActiveSheet.Range("F2:F100").Copy Destination:=.Range("C2")" dans la procédure événementielle "commandButton1"

Du coup j'ai eu des fichiers renommés et d'autres non. J'ai donc augmenté manuellement la taille. J'espère que ça ne pose pas de soucis pour la suite du code. En tout cas cela semble fonctionner pour le moment. Il faudrait en profiter pour gérer une liste dynamique qu'en pense tu ?

Sinon tout vas bien pour le moment. La feuille de visualisation est extrêmement précieuse au fait . Je ne m'en passe plus du coup^^

A toute,

André

Réponse 82 / 84

ucfoutu Messages postés 18038 Date d'inscription lundi 7 décembre 2009 Statut Modérateur Dernière intervention 11 avril 2018 211
11 mars 2012 à 16:45

J'avais mis 100 car je pensais que tu n'allais jamais donner un nombre incroyable de noms de baptême.

Mais si tu veux du toujours correspondant à ce nombre ===>>

Remplace donc
ActiveSheet.Range("F2:F100").Copy Destination:=.Range("C2")
par
ActiveSheet.Range("F2:F" & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Row).Copy Destination:=.Range("C2")

____________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches d'autres forumeurs.
Pas d'aide en ligne installée ? ==> ne comptez pas sur moi pour simplement vous dire ce qu'elle contient

Réponse 83 / 84

ucfoutu Messages postés 18038 Date d'inscription lundi 7 décembre 2009 Statut Modérateur Dernière intervention 11 avril 2018 211
11 mars 2012 à 17:08

Je te mets finalement ici le code doté de tous ses gardes-fou car impossible de te le passer par MP en conservant son indentation.

Option Explicit
Private couic As Boolean

Private Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Private Sub ListBox1_Click()
  Dim depart As Worksheet, ma_feuille As String, toto As String
  Set depart = ActiveSheet
  ma_feuille = ListBox1.List(ListBox1.ListIndex)
  If ma_feuille <> "NOUVELLE A CREER" Then
    Range("G2").Value = ListBox1.List(ListBox1.ListIndex)
  Else
    toto = InputBox("donner un nom à cette nouvelle feuille")
    On Error Resume Next
    With Worksheets.Add
      .Name = toto
    End With
    Range("G2").Value = toto
    On Error GoTo 0
  End If
  depart.Activate
  ListBox1.Visible = False
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
 If Target.Row <> 1 Then couic = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 If Target.Row 1 Then couic False: Target.Offset(1, 0).Activate: Exit Sub
 If couic Then couic = False: Exit Sub
 Dim monmsg As String
 If Target.Column <> 2 And Target.Column <> 3 And Target.Column <> 7 Then Exit Sub
 ListBox1.Visible = False
 If Target.Address Range("B2").Address Or Target.Address Range("C2").Address Then
   If Target.Column = 2 Then
     monmsg = "Sélectonne le dossier à traiter puis clique sur OK"
   Else
     monmsg = "Sélectonne le dossier d'accueil puis clique sur OK"
   End If
   Dim iNull As Integer, lpIDList As Long, lResult As Long
     Dim sPath As String, udtBI As BrowseInfo
     With udtBI
        .hWndOwner = 0
        .lpszTitle = lstrcat(monmsg, "") ' lstrcat("C:", "")
        .ulFlags = BIF_RETURNONLYFSDIRS
     End With
     lpIDList = SHBrowseForFolder(udtBI)
     If lpIDList Then
         sPath = String$(MAX_PATH, 0)
         SHGetPathFromIDList lpIDList, sPath
         CoTaskMemFree lpIDList
         iNull = InStr(sPath, vbNullChar)
         If iNull Then
            sPath = Left$(sPath, iNull - 1)
         End If
    End If
    If Target.Column = 2 Then
      Target.Value = sPath
    Else
      sPath InputBox("clique sur OK " & sPath & vbCrLf & "ou compléter pour créer un sous-dossier d'accueil dans " & sPath, "confirmation", sPath)
      If Dir(sPath, vbDirectory) = "" Then MkDir sPath
      Target.Value = sPath
    End If
  ElseIf Target.Address = Range("G2").Address Then
    remplir_choix_feuille
  Else
   Exit Sub
  End If
End Sub
Private Sub remplir_choix_feuille()
    Dim sh As Worksheet
    ListBox1.Clear
    For Each sh In Worksheets
      If sh.Name <> ActiveSheet.Name Then
        ListBox1.AddItem sh.Name
      End If
    Next
    ListBox1.AddItem "NOUVELLE A CREER"
    ListBox1.Left = Range("G2").Left
    ListBox1.Top = Range("G2").Top
    ListBox1.Visible = True
End Sub
Private Sub CommandButton1_Click()
  Dim dossier As String, filtre As String, ou As Integer, fc As String, reste As Long, desti As String
  Dim x As Integer, k As Long, i As Long, toto, R, CR
  desti = ActiveSheet.Range("C2")
  R = Split(ActiveSheet.Range("D2").Text, "*")
  CR = Split(ActiveSheet.Range("E2").Text, "*")
  dossier = ActiveSheet.Range("B2").Text
  If verif(dossier, "DO") <> "" Then MsgBox verif(dossier, "DO"): Exit Sub
  If verif(desti, "DA") <> "" Then MsgBox verif(desti, "DA"): Exit Sub
  If ActiveSheet.Range("A2").Text = "" Then MsgBox "extension non renseignée": Exit Sub
  If ActiveSheet.Range("D2").Text = "" Then MsgBox "Rythme non renseigné": Exit Sub
  If ActiveSheet.Range("E2").Text = "" Then MsgBox "co-Rythme non renseigné": Exit Sub
  If ActiveSheet.Range("G2").Text = "" Then MsgBox "Feuille d'accueil/visualisation non renseignée": Exit Sub
  filtre = "\*." & ActiveSheet.Range("A2").Text
  ou = 1
  With Sheets(Range("G2").Text)
    .Cells.ClearContents
    .Columns("A").ColumnWidth = 30
    .Columns("B").ColumnWidth = 45
    .Columns("C").ColumnWidth = 25
    .Columns("D").ColumnWidth = 50
    .Range("A1").Value = "dossier " & dossier
    .Range("B1").Value = "fichiers extraits"
    .Range("C1").Value = "à baptiser ainsi"
    .Range("D1").Value = "sera donc enregistré sous"
    ActiveSheet.Range("F2:F" & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Row).Copy Destination:=.Range("C2")
    fc = Dir(dossier & filtre, vbNormal Or vbHidden)
    Do While fc <> ""
      ou = ou + 1
      .Range("A" & ou) = fc
      fc = Dir
    Loop
    toto = .Range("A2:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
    reste = UBound(toto, 1)
    ou = 2
    x = 0
    For i = 1 To UBound(toto, 1)
      k = k + 1
      reste = reste - 1
      Select Case k
        Case (Val((R(x)) - Val(CR(x))) \ 2) + 1 To (Val((R(x)) - Val(CR(x))) \ 2) + Val(CR(x))
          .Range("B" & ou).Value = toto(i, 1)
          If .Range("C" & ou).Value <> "" Then
            .Range("D" & ou).Value = .Range("C" & ou).Value & _
            Mid(.Range("B" & ou), InStrRev(.Range("B" & ou), "."))
          Else
            .Range("D" & ou).Value = .Range("B" & ou).Value
          End If
          ou = ou + 1
       Case Is > Val(R(x)) - 1
         k 0: x x + 1
         If x > UBound(R) Then x = 0
         If reste < Val(R(x)) Then
           .Range("B" & .Range("B" & Rows.Count).End(xlUp).Row + 1).Value = "| stop là car insuffisant pour série suivante de " & R(x)
            Exit For
         End If
      End Select
    Next
    .Activate
    DoEvents
  End With
  Dim dac As Integer
  dac = MsgBox("es-tu d'accord pour la copie de cette extraction vers le dossier de destination ?", vbYesNo)
  If dac = vbYes Then
    For i = 2 To ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row
      FileCopy dossier & "" & ActiveSheet.Range("B" & i).Text, desti & "" & ActiveSheet.Range("D" & i).Text
    Next
  End If
  Worksheets("traitement").Activate
  DoEvents
  MsgBox "Traitement " & IIf(dac = vbYes, "terminé", "avorté")
 End Sub

Private Function verif(quoi As String, typ As String) As String
  If typ "DO" Then typ "le dossier à traiter " Else typ = "le dossier de destination "
  If quoi "" Or Dir(quoi, vbDirectory) "" Then
    verif = typ & " est inexistant ou non renseigné !"
  End If
End Function

Voilà ! je ne vois maintenant plus rien d'utile à lui rajouter.
Amuse-toi bien.
____________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches d'autres forumeurs.
Pas d'aide en ligne installée ? ==> ne comptez pas sur moi pour simplement vous dire ce qu'elle contient

Réponse 84 / 84

SERIEUXETCOOL Messages postés 336 Date d'inscription dimanche 3 avril 2011 Statut Membre Dernière intervention 12 juin 2012 1
11 mars 2012 à 17:51

Et ben écoute Ucfoutu, c'est parfait je pense !

Je n'ai malheureusement pas le temps de tester le dernier code pour le moment. Je me suis lancé tête dans le guidon dans mes extractions pour l'instant. Mais j'imagine que c'est le même...en mieux

Mais c'est promis je reviens la semaine prochaine pour commenter le code final. Je proposerai très probablement le classeur en téléchargement pour ceux qui passeraient par la ensuite.

Dans tous les cas, avec la version actuelle je m'amuse comme un pti fou. C'est incroyable le temps que tu me fais gagné Ucfoutu avec ce code la !

J'en suis déjà à 20 dossiers parfaitement extraits et renommés. Chaque dossier contenant en moyenne 200 photos extraites et renommées...Cela me fait déjà environ 4000 photos extraites et renommées. T'imagine que je faisais tout à la main avant ???

Bon j'avais jamais autant de dossier d'un coup, mais la pour le coup si. Et avec un impératif de temps en plus. Donc je suis content d'avoir pris le temps pour développer le code avec toi car maintenant c'est que du bonheur.

Donc très sincèrement, merci

Bon je retourne faire mes extractions pour le moment....

A bientôt.

André

Ps : Je vais en profiter très rapidement pour créer une nouvelle discussion qui concerne le placement et dimensionnement des objets sur une feuille. Finalement je ne suis pas encore parvenu au résultat que je souhaitais. Si tu veux y jeter un coup d’œil, c'est sur un autre post.

Discussions similaires

Trier des cellules Excel par ordre alphabetique

"Trier par COUNT() ?"

Probleme de tri de tableau

Trier une liste par ordre croissant

ZOOM SUR IMAGE JPG

Votre réponse

Discussions similaires