Appel d'un fonction dans un "for each"

Le 17/11/2022 à 10:55

Je reviens vers vous pour une chose qui doit être très simple, mais pas pour moi !

 Application.ScreenUpdating = False

    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim I As Long
    Dim Height As Object
    Dim Width As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(Repertoire)

    'Récupère le numéro de la dernière ligne vide dans la colonne A.
    I = Range("A65536").End(xlUp).Row + 1

    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files
        If FileItem.Type = "Fichier d’image disque" Or FileItem.Type = "ImageView Document (.cgm)" Or FileItem.Type = "Fichier PNG" Then
        'Inscrit le nom du répertoire
        Cells(I, 1) = FileItem.ParentFolder.Name
        'Inscrit le nom du fichier dans la cellule
        Cells(I, 2) = FileItem.Name
        'Ajoute un lien hypertexte vers le fichier
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(I, 2), _
        Address:=FileItem.ParentFolder & "\" & FileItem.Name

À la suite de ce code, j'aimerais connaître au sujet de l'image en cellule 2

en cellule 3 la hauteur de l'image,

en cellule 4 la largeur de l'image

en cellule 5 la résolution en Dpi.

un truc du genre :

Cells(I, 3) = hauteur de l'image
Cells(I, 4) = largeur de l'image
....

Est-ce possible ?

Merci,

Seb78

Le 17/11/2022 à 12:27

bonjour,

je ne sais pas exactement ce que vous voulez, mais je pas qu'ici vous trouvez quelque properties de votre fichier avec shell.application. Hauteur etc est en pixels

http://www.snb-vba.eu/VBA_Bestanden_en.html#L_1.77

Le 17/11/2022 à 12:27

bonjour,

edit : Hallo BsAlv

voici une fonction (trouvée sur internet) qui te donne les infos que tu demandes.

Private Type ImgageInfo
    Height                    As Long
    Width                     As Long
    FileExtension             As String
    HorizontalResolution      As Double
    VerticalResolution        As Double
    PixelDepth As Long
End Type
Public Img                    As ImgageInfo

'---------------------------------------------------------------------------------------
' Procedure : WIA_GetImgDimensions
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Retrieve various properties (dimensions, extension, resolution) of an image
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFile     : Fully qualified path, filename and extension of the image file to check
'
' Usage:
' ~~~~~~
' Call WIA_GetImgDimensions(C:\Tmp\database.png )
' Debug.Print sFile, "Width: " & Img.Width, "Height: " & Img.Height, "FileExtension: " & _
'                  Img.FileExtension, "HorizontalResolution: " & Img.HorizontalResolution, _
'                  "VerticalResolution: " & Img.VerticalResolution, _
'                  "PixelDepth: " & Img.PixelDepth
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2018-10-23              Initial Release
'---------------------------------------------------------------------------------------
Function WIA_GetImgDimensions(ByVal sFile As String) As Boolean
    'For a complete listing of available WIA ImageFile properties
    '   Ref: https://docs.microsoft.com/en-us/previous-versions/windows/desktop/wiaaut/-wiaaut-imagefile
    On Error GoTo Error_Handler
    Dim oWIA                  As Object

    Set oWIA = CreateObject("WIA.ImageFile")
    oWIA.LoadFile sFile
    Img.Width = oWIA.Width
    Img.Height = oWIA.Height
    Img.FileExtension = oWIA.FileExtension
    Img.HorizontalResolution = oWIA.HorizontalResolution
    Img.VerticalResolution = oWIA.VerticalResolution
    Img.PixelDepth = oWIA.PixelDepth

Error_Handler_Exit:
    On Error Resume Next
    If Not oWIA Is Nothing Then Set oWIA = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: WIA_GetImgDimensions" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function

Private Sub Testme()
    Dim sFile                 As String

    sFile = "d:\downloads\monprofil.png"
    Call WIA_GetImgDimensions(sFile)
    MsgBox sFile & " " & "Width: " & " " & Img.Width & " " & "Height: " & " " & Img.Height & " " & _
                "FileExtension: " & " " & Img.FileExtension & " " & _
                "HorizontalResolution: " & " " & Img.HorizontalResolution & " " & _
                "VerticalResolution: " & " " & Img.VerticalResolution & " " & _
                "PixelDepth: " & " " & Img.PixelDepth
End Sub
Le 17/11/2022 à 13:13

Merci à vous deux.

En fait, je pense que mon problème, au delà de la macro est surtout que je dois lancer le sub depuis le "For Each"....

Merci

Seb78

Le 17/11/2022 à 15:29

les experts de PQ savent vous donner une bonne application, je suppose, autrement ce soir, je vous donne la macro.

Le 18/11/2022 à 00:14

bonsoir,

ajouter la fonction et la définition de type (proposées précédemment) dans ton code et appeler la fonction ainsi

For Each FileItem In SourceFolder.Files
        If FileItem.Type = "Fichier d’image disque" Or FileItem.Type = "ImageView Document (.cgm)" Or FileItem.Type = "Fichier PNG" Then
        'Inscrit le nom du répertoire
        Cells(I, 1) = FileItem.ParentFolder.Name
        'Inscrit le nom du fichier dans la cellule
        Cells(I, 2) = FileItem.Name
        'Ajoute un lien hypertexte vers le fichier
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(I, 2), _
        Address:=FileItem.ParentFolder & "\" & FileItem.Name
        WIA_GetImgDimensions FileItem.ParentFolder & "\" & FileItem.Name
        Cells(I,3)=img.Width
        Cells(I,4)=img.Height
        'etc ......
Le 22/11/2022 à 10:13

Bonjour,

je n'y suis pas arrivé, cependant, c'est un peu moins urgent que d'autres choses, je vais laisser tomber pour le moment et revenir dessus à tête reposée.

Rechercher des sujets similaires à "appel fonction each"