Listing de fichier JPEG sur ligne et colonne

Le 13/04/2016 à 10:48

Bonjour à vous,

Je viens vers vous aujourd'hui avec un nouveau problème. J'ai mélangé une macro de listing de fichier JPEG avec une macro pour afficher sur la cellule à côté du nom, le fichier JPEG.

Voici le code :

Sub ListeChoixFichiers()

'macro pour choisir le répertoire

  racine = ChoixDossier()     ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
  Range("a4:D10000").ClearContents
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier = fs.GetFolder(racine) 'DossierRacine
  ligne = 3
  'je pose le nom du dossier dans cette case
   Cells(3, 3) = dossier.Name
   'Cells(3, 3).Interior.ColorIndex = 36
   ligne = ligne + 1
   'on liste les jpeg
   For Each f In dossier.Files
     Cells(ligne, 1) = f.Name

     ligne = ligne + 1
   Next

'insertion de la formule pour faire apparaître les images

    Range("C4").Select
    ActiveCell.FormulaR1C1 = "=R3C3&""\""&RC[-2]"

  'incrémentation de la formule

     Selection.AutoFill Destination:=Range("C4:C28"), Type:=xlFillDefault
    Range("C4:C25").Select

   'On filtre de A à Z les fichiers que l'on insère pour avoir TA avant TB

    Range("A4:A25").Select
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("A4"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("A4:A25")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    'masque la colonne C pour faire disparaître le lien dossier

    Columns("C:C").Select
    Selection.EntireColumn.Hidden = True

    'affichage des images

     ' Sélectionner les cellules contenant un lien vers une image et appeler la macro
    ' AffImage les affichera sur le lien ou dans la colonne de gauche ou de droite
    Const hDefaut = 75 ' hauteur des images
    Const imgDefaut = "" ' saisir chemin complet et le nom de l'image par défaut à afficher si erreur
    Dim msg As String, r As Long, h As Long, lmax As Long
    Dim c As Range, numfich As Integer
    Dim fich
    'msg = "Oui : Afficher les images à gauche des liens sélectionnés" & vbCrLf
    'msg = msg & "Non : Afficher les images sur les liens sélectionnés" & vbCrLf
    'msg = msg & "Annuler : Afficher les images à droite des liens sélectionnés"
    'r = MsgBox(msg, vbYesNoCancel, "Cellules où mettre les images")
    'If r = vbYes Then
    '    r = -1
   ' ElseIf r = vbNo Then
    '    r = 0
   ' Else
        r = 1 'position de placement des images voulu à côté du lien
    'End If
    h = InputBox("Hauteur des lignes :", "Choix hauteur", hDefaut)
    For Each c In Selection
        'c.ColumnWidth = 10
        fich = c.Value
        ' test fichier
        If fich <> "" Then
            If Left(fich, 7) = "http://" Then
                ' on conserve le lien sur le net
            Else
                numfich = FreeFile()
                On Error GoTo errfich
                Open fich For Input As #numfich
                Close #numfich
                On Error GoTo 0
            End If
        End If
            '
        If fich <> "" Then
            c.RowHeight = h 'fixer la hauteur de ligne
            ActiveSheet.Pictures.Insert(fich).Select 'ouverture image
            With Selection.ShapeRange
                .LockAspectRatio = msoTrue 'conserver les proportions
                .Height = h - 4 'hauteur de l'image = hauteur des lignes - 4
                .Left = c.Offset(0, r).Left + 2 'à gauche colonne A (sinon tu calcules avec la largeur de colonne)
                .Top = c.Top + 2 'et positionner verticalement
            End With
        End If
    Next c
    Exit Sub
errfich:
    fich = imgDefaut
    Resume Next

End Sub

'Fonction qui nous permet d'aller chercher notre dossier

Function ChoixDossier()
    If Val(Application.Version) >= 10 Then
       With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then
           ChoixDossier = .SelectedItems(1)
        Else
           ChoixDossier = ""
        End If
       End With
     Else
       ChoixDossier = InputBox("Répertoire?")
     End If
End Function

Ce code marche donc sans aucun soucis. Son principe est que j'aille chercher un dossier, dans ce dossier ma macro prend tous les fichiers (ça ne sera que des JPEG),me les listes dans la colonne A, et j'ai l'image qui apparaît dans une colonne à côté.

Mon problème est que je ne veux pas afficher mon listing fichier que dans une seule colonne. Je voudrais que toutes les 4 images mon listing automatique aille sur une colonne que je peux choisir.

Imaginons j'ai 12 fichiers, je voudrais que la liste me mettent automatiquement 4 fichiers en colonne A, 4 fichiers en colonne E et 4 fichiers en colonne I et si possible à partir de la ligne 4 ( donc A4--> A7, E4 --> E7,...). J'ai essayé de me renseigner et de chercher par moi même mais je suis resté jusque là bredouille. Est-ce possible ?

Et deuxième question, est ce qu'il existe une macro pour différencier 2 noms quasi identique dans un même dossier. Par exemple je pourrais avoir 4 fichiers dans mon dossier : "toto_1_A.jpg" "toto_2_A.jpg" "toto_1_B.jpg" "toto_2_B.jpg". Comment pourrais-je choisir de lister tous les fichiers finissant par _A ?

Voilà s'il faut j'ai ajouté mon fichier aussi.

En vous remerciant d'avance

27test.xlsm (31.42 Ko)
Le 17/04/2016 à 00:15

Bonjour Takezo Santso,

Concernant ta première demande, c'est réalisable, même si un peu tordu. Il faut donc à un moment demander à l'utilisateur où il veut mettre les images (dans quelle colonne)

Possibilité 1: demander à l'utilisateur de saisir toutes les colonnes, et s'il y a trop d'images redemander au fur et à mesure

Possibilité 2: demander toutes les 4 images

Pour ta seconde question, tu as plusieurs possibilités, en voilà une.

(je ne sais pas me servir de l'objet filesystem donc je propose rien dessus)

Dim uneImage as string
uneImage  = Dir ("C:\toto\*_A.jpg")
while uneImage <> "" 
'actions
'passage à l'image suivante
uneImage = Dir
Wend
Le 18/04/2016 à 09:10

Bonjour et tout d'abord merci de ta réponse.

Concernant la réponse pour ma première question, je n'ai pas réussi à programmer non plus une demande à l'utilisateur en choisissant où il veut mettre les images. Et si possible j'aimerais que ce ne soit pas demandé à l'utilisateur, que je définisse des colonnes dans mon code et ça sera toujours les même. Aurais-tu un bout de code pour au moins m'orienter dans la bonne direction ?

Concernant la réponse pour ma seconde question, j'ai essayé ton bout de code et j'ai rencontré un problème. Dans mon code j'ai une fonction qui me permet de choisir le répertoire où se situe mes images. Et dans ton code je suis censé rentrer la direction de mon répertoire, je ne peux donc pas faire varier mon répertoire grâce à ma fonction, je suis obligé de changer mon chemin manuellement à chaque fois. Comment pourrais-je injecter ton code dans le mien afin que je puisse quand même choisir grâce à ma fonction un répertoire voulu ?

En vous remerciant d'avance

Le 18/04/2016 à 10:13
Sub test()
Dim fileD As FileDialog
Dim repertoire As String

Set fileD = Application.FileDialog(msoFileDialogFolderPicker)
With fileD
    .AllowMultiSelect = False
    .Show
End With

If fileD.SelectedItems.Count = 0 Then Exit Sub 'on sort on a pas choisi de répertoire
repertoire = fileD.SelectedItems.Item(1) & "\"

Dim uneImage As String
uneImage = Dir(repertoire & "*.jpg")

Dim numImage As Integer 'on va compter les images. Il faut donc calculer en fonction du numéro de l'image sa position
Dim listeColonnes As Variant
listeColonnes = Array("A", "B", "C", "D", "E", "F")

Dim numLigne As Integer, numColonne As Integer '1ere colonne -> A, 2ème colonne B -> ie se rapporter à listeColonnes

While uneImage <> ""
    'actions
    'ATTENTION, la variable uneImage ne contient que le nom du fichier avec son extension, il faut rajouter le répertoire pour importer l'image
    'par exemple : cheminComplet = repertoire & uneImage
    numImage = numImage + 1
    numColonne = numImage \ 5 'division entière ATTENTION listeColonnes(0) = "A" = premier élément !!
    numLigne = numImage - 4 * numColonne

    Select Case numLigne
        Case 1
            'action à faire si c'est la premiere image de la colonne
           '***************
        Case 2
            'action à faire si c'est la deuxieme image de la colonne
            '***************
        Case 3
            'action à faire si c'est la troisieme image de la colonne
           '***************
        Case 4
            'action à faire si c'est la quatrième image de la colonne
           '***************
        Case Else
    End Select
    'on passe au fichier suivant
    uneImage = Dir
Wend
End Sub

Voilà une proposition avec en surligné les éléments qu'il faudra modifier pour coller à ton besoin.

La liste des colonnes est stockée dans la variable listeColonnes. Si tu veux écrire en A puis E puis Z ->

listeColonnes = Array("A","E","Z")
Le 18/04/2016 à 16:37

Merci grâce à ton aide j'ai pu résoudre mon problème

Rechercher des sujets similaires à "listing fichier jpeg ligne colonne"