Dimensions d'une image

Le 25/08/2020 à 10:01

Bonjour,

J'ai un programme qui test l'extension des images (jpg, tif, bmp), j'aimerais en plus qu'il test leurs dimensions en pixels par pouce, je ne sais pas quelle procédure utiliser pour cela, je vous mets ci-dessous le code actuel.

Au final, je veux que le nom des images qui n'ont pas une largeur ou hauteur comprise entre 995 ppp et 1005 ppp, soient inscrit à k + 1 c'est à dire à la suite de la liste testant les extensions.

Option Explicit
Dim k As Integer

Sub VerifImages()

Dim Repertoire As FileDialog
k = 2
ListeFichiers Range("A1")

End Sub

Sub ListeFichiers(Repertoire As String) 

Dim fso, SourceFolder, SubFolder, Fichier, cheminETnom
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder(Repertoire)

    For Each Fichier In SourceFolder.Files

        If Fichier Like "*.tif" Or Fichier Like "*.bmp" Then
            cheminETnom = Repertoire & "\" & Fichier.Name
            Cells(k, 2).Value = Split(cheminETnom, "\")(UBound(Split(cheminETnom, "\")))
            Cells(k, 3).Interior.Color = RGB(255, 20, 70)
            Cells(k, 3).Value = "L'image doit être mise en jpg"
            k = k + 1
        End If

    Next Fichier

    For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
    Next SubFolder

End Sub
Le 25/08/2020 à 17:32

Bonjour Man.403030,

Tu n'indiques pas quelle version d'Excel tu utilises, ce qui permettrait de jauger ta version Windows et donc les propriétés permises aux fichiers.

Avec le code ci-dessous teste si les propriétés images de ton dossier sont comprises entre les n° de propriétés 175 à 178.

Avec le dossier Images (Pictures). Nomme avant une feuille Excel Propriétés avant d'exécuter la macro.

'Liste des propriétés de résolution (ppp) & dimension fichier image
Sub GetDetailsOfFields()
    Dim objShell
    Dim objFolder
    Dim n As Long, Chemin As String

    Chemin = Environ("HOMEDRIVE") & Environ("HOMEPATH")
    Set objShell = CreateObject("shell.application")
    Set objFolder = objShell.Namespace(Chemin & "\Pictures\")

    On Error GoTo ErrDetail
    For n = 1 To 4
        Worksheets("Propriétés").Cells(n, 3).Value = n + 174
        Worksheets("Propriétés").Cells(n, 4).Value = objFolder.GetDetailsOf(objFolder.Items, n + 174)
    Next n

ErrDetail:

    Set objFolder = Nothing
    Set objShell = Nothing
End Sub

Confirme le moi alors en retour.

A suivre...

Le 26/08/2020 à 09:36
image

J'ai mis une image dans le dossier image, j'ai renommé feuil1 en "propriétés" j'ai exécuté la macro, voilà le résultat.

Pour répondre à ta question je suis sous excel 2010

Le 26/08/2020 à 14:12

Bonjour Man.403030,

Suite à ton retour voici le code pour récupérer les dimensions Pixel (horizontales + verticales)

Option Explicit
Public PixH, PixV As Integer

Sub TestPixImg()
Dim Ret As String: Ret = Chr(10) & Chr(13)
Call TestPPP("CaptRond.jpg")    ' Exemple fait sur cette image unique
MsgBox PixH & Ret & PixV        ' Pour vérification seulement
End Sub

Sub TestPPP(Img As String)
Dim ResH, ResV, Image As String
    Image = Img                                                                                 ' Exemple sur dossier Images (Pictures)
    ResH = FileProperty(Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Pictures", Img, 175)     ' "Résolution horizontale"
    ResV = FileProperty(Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Pictures", Image, 177)   ' "Résolution verticale"
    PixH = CInt(Replace(ResH, "ppp", "")): PixV = CInt(Replace(ResV, "ppp", ""))                ' Conversion du texte(hors ppp)en entier
End Sub

Function FileProperty(FilePath As String, FileName As String, PropInt As Integer) As String 
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objShell As Object

    FileProperty = vbNullString

    FileName = StrConv(FileName, vbUnicode): FilePath = StrConv(FilePath, vbUnicode)

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(StrConv(FilePath, vbFromUnicode))

    If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
    End If

    If Not objFolderItem Is Nothing Then
        FileProperty = Right(objFolder.GetDetailsOf(objFolderItem, PropInt), 6)
    Else
        FileProperty = vbNullString
    End If

    Set objShell = Nothing: Set objFolder = Nothing: Set objFolderItem = Nothing
End Function

C'est le code de la macro TestPixImg que tu peux insérer dans ton code. Au sein du même module.

Le Call appelle la macro TestPPP avec la référence du fichier image (nom + extension) qui va remplacer pour l'exemple CaptRond.jpg

Ou toute variable string (nom + extension) d'image valide.

En retour PixH et PixV représentent les résolutions ppp horizontales et verticales que tu peux exploiter par une condition.

Dans l'exemple c'est une boîte de message. A ôter après avoir testé.

Si besoin, reviens sur le sujet.

Bons tests, bonne continuation.

Le 02/09/2020 à 12:07

Merci pour ton aide, malheureusement je ne souhaite pas avoir à changer le nom de l'image à chaque fois dans le code j'ai beaucoup d'images à tester in faut que le programme test tous les fichiers d'un dossier pas que une image par une image

Le 02/09/2020 à 13:06

Bonjour Man.403030,

je ne souhaite pas avoir à changer le nom de l'image à chaque fois dans le code

Je te rappelle un extrait de ton code.

 For Each Fichier In SourceFolder.Files

        If Fichier Like "*.tif" Or Fichier Like "*.bmp" Then
            cheminETnom = Repertoire & "\" & Fichier.Name

Que fais tu dans ton code sinon tester toutes les images avec extension TIF ou BMP.

En plus Fichier.Name te donne le nom de exacte de l'image.

Comme je l'exprimais dans mon dernier message

C'est le code de la macro TestPixImg que tu peux insérer dans ton code. Au sein du même module.

Utilises ton Fichier.Name pour faire un Call TestPPP(Fichier.Name). Une fois que tu as inséré l'ensemble du code dans ton If....End if

Bonne continuation.

Le 02/09/2020 à 13:38

D'accord merci je n'avais pas compris ta remarque en dessous je regarde ça dans l'après midi

Le 03/09/2020 à 10:47
Option Explicit
Dim k As Integer

Sub VerifImages()

Dim Repertoire As FileDialog
k = 2
ListeFichiers Range("A1")

End Sub

Sub ListeFichiers(Repertoire As String) 'procédure permettant de trouver le nom de l'image dans le répertoire ou sous répertoires, si il n'y a pas d'image trouvée la cellule est colorée

Dim fso, SourceFolder, SubFolder, Fichier, cheminETnom
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder(Repertoire)

    For Each Fichier In SourceFolder.Files

        If Fichier Like "*.tif" Or Fichier Like "*.bmp" Then
            cheminETnom = Repertoire & "\" & Fichier.Name
            Cells(k, 2).Value = Split(cheminETnom, "\")(UBound(Split(cheminETnom, "\")))
            Cells(k, 3).Interior.Color = RGB(255, 20, 70)
            Cells(k, 3).Value = "L'image doit être mise en jpg"
            k = k + 1
        End If

Dim Ret As String: Ret = Chr(10) & Chr(13)
Call TestPPP(Fichier.Name)

 If PixH > 1005 Or PixH < 995 Or PixV > 1005 Or PixV < 995 Then
            cheminETnom = Repertoire & "\" & Fichier.Name
            Cells(k, 2).Value = Split(cheminETnom, "\")(UBound(Split(cheminETnom, "\")))
            Cells(k, 3).Interior.Color = RGB(0, 20, 70)
            Cells(k, 3).Value = "Mettes l'image au format 1000x1000ppp"
            k = k + 1
        End If

    Next Fichier

    For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
    Next SubFolder

End Sub

Sub TestPPP(Img As String)
Dim ResH, ResV, Image As String
    Image = Img                                  ' Exemple sur dossier Images (Pictures)
    ResH = FileProperty(Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Pictures", Img, 175)     ' "Résolution horizontale"
    ResV = FileProperty(Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Pictures", Image, 177)   ' "Résolution verticale"
    PixH = CInt(Replace(ResH, "ppp", "")): PixV = CInt(Replace(ResV, "ppp", ""))                ' Conversion du texte(hors ppp)en entier
End Sub

Function FileProperty(FilePath As String, FileName As String, PropInt As Integer) As String
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objShell As Object

    FileProperty = vbNullString

    FileName = StrConv(FileName, vbUnicode): FilePath = StrConv(FilePath, vbUnicode)

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(StrConv(FilePath, vbFromUnicode))

    If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
    End If

    If Not objFolderItem Is Nothing Then
        FileProperty = Right(objFolder.GetDetailsOf(objFolderItem, PropInt), 6)
    Else
        FileProperty = vbNullString
    End If

    Set objShell = Nothing: Set objFolder = Nothing: Set objFolderItem = Nothing
End Function

J'ai donc ceci mais j'ai un problème avec les variables pixH et pixV elles ne sont pas reconnues

Le 03/09/2020 à 12:58

Bonjour Man.403030,

J'ai donc ceci mais j'ai un problème avec les variables pixH et pixV elles ne sont pas reconnues

Normal, tu as Option Explicit en haut de ton code et seul k est indiqué comme variable Integer.

Donc si tu fais Dim k, PixH, PixV as Integer. Ces variables ajoutées pourront être reconnues.

Ensuite fais aussi attention. J'ai testé la macro TestPPP comme indiqué sur le dossier Images (Pictures).

Donc mets bien le répertoire souhaité si il est différent de Pictures.

Bonne continuation.

Le 03/09/2020 à 15:21
J'ai déjà essayé après j'ai une incompatibilité de type sur cette partie :

PixH = CInt(Replace(ResH, "ppp", ""))
Le 03/09/2020 à 16:23

A nouveau,

Tu ne dois pas avoir que des fichiers image dans ton répertoire cible. Donc modifie ton code.

FichImg = ""
If Fichier Like "*.tif" Or Fichier Like "*.bmp" Then
            cheminETnom = Repertoire & "\" & Fichier.Name
            FichImg = Fichier.Name
'suite de ton code...
'puis 

if FichImg >"" then Call TestPPP(FichImg) Else goto Fin

'suite du code...

Fin:
'Sans test pixels
Next Fichier

Fais en retour, si encore incompatibilité, les valeurs des variables ResH et ResV.

Il suffit de passer le curseur de la souris sur ces variables. Ou d'écrire avant les PixH et PixV ces valeurs sur la feuille dans des cellules test (Exemple: en E1 et F1 )

Afin de pouvoir leur contenu dès la survenue de l'incompatibilité.

A suivre...

Le 03/09/2020 à 17:09

J'ai bien que des fichiers images dans mes dossiers et sous dossiers j'ai quand même mis ton code pour dans le cas où ça arriverait mais j'ai toujours le même blocage.

Le 03/09/2020 à 17:23

en plus ça ne fonctionne pas car j'ai mis si PixH > 1005 or PixH<995 alors ça écrit le nom de l'image au final ça écrit le nom de l'image alors qu'elle fait 1000x1000ppp

Le 03/09/2020 à 18:56

Suite,

J'avais vu cela. Mais c'est ton code! Et ne voulais pas pour l'instant y remédier car il faut traiter le sujet pour le moment.

Contrôle bien tes conditions sur une feuille avant de passer en VBA.

Une fois que tu auras vérifié les valeurs ResH et ResV et transmis en retour comme demandé. Tu pourras corriger. Enlève ta condition pour le moment.

Ou fais un test seulement avec la macro fourni le 26/08 avec un nom d'image existant (en jpg par exemple). Avec ton propre chemin (répertoires...)

Enfin, met ta version d'Excel dans ton profil au lieu de VBa car certaines fonctions sont différentes selon version.

A suivre...

Le 03/09/2020 à 19:06

A nouveau,

Tu peux mettre aussi un message box te sortant les valeurs ResH, ResV comme fait lors de mes premiers messages.

Je te rappelle le code.

Sub TestPixImg()
Dim Ret As String: Ret = Chr(10) & Chr(13)
Call TestPPP("CaptDemo.tif")    ' Exemple fait sur cette image
MsgBox PixH & Ret & PixV        ' Pour vérification seulement
End Sub

Change PixH et PixV par les valeurs ResH et ResV.

Le 03/09/2020 à 19:36

A nouveau,

En images ce que donne le programme pour les valeurs Res et Pix (H et V)

captpix captres 
Option Explicit
Public PixH, PixV As Integer, ResH, ResV, Ret As String

Sub TestPixImg()
Dim Ret As String: Ret = Chr(10) & Chr(13)
Call TestPPP("CaptDemo.tif")    ' Exemple fait sur cette image Note: bmp pas de pixel
MsgBox "PixH=" & PixH & Ret & "PixV=" & PixV        ' Pour vérification seulement
End Sub

Sub TestPPP(Img As String)
Dim ResH, ResV, Image As String: Ret = Chr(10) & Chr(13)
    Image = Img                                                                                 ' Exemple sur dossier Images (Pictures)
    ResH = FileProperty(Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Pictures", Img, 175)     ' "Résolution horizontale"
    ResV = FileProperty(Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Pictures", Image, 177)   ' "Résolution verticale"
    MsgBox "ResH =" & ResH & Ret & "ResV =" & ResV ' Contrôle des variables ResH et ResV
    PixH = CInt(Replace(ResH, "ppp", "")): PixV = CInt(Replace(ResV, "ppp", ""))                ' Conversion du texte(hors ppp)en entier
End Sub

Macros TestPixImg() et TestPPP(Img as String) rappelées ci-dessus. Function FileProperty présente dans le même module bien entendu.

Le 04/03/2021 à 10:20

Bonjour,

Désolée pour cette réponse si tardive sur le sujet. Ce sujet étant traitée pour mon alternance je n'ai pas pu le traiter avant mon retour en entreprise.

Tout d'abord merci pour tes différentes réponses, j'ai pu modifier quelques petites choses de mon code ce matin. J'ai lancé un pas à pas détaillé pour comprendre qu'est ce qui pouvait poser problème. Je m'aperçois que lorsque je passe sur la fonction FileProperty il n'en ressort rien pour ResV et ResH donc je pense que comme tu le dis c'est de que découle l'erreur d'incompatibilité de type du PixH et PixV.

Je vous remets le code car cela fait déjà un moment que vous avions communiqué.

Option Explicit
Dim k As Integer
Dim PixH, PixV As Variant

Sub VerifImages()

Dim Repertoire As FileDialog
k = 2
ListeFichiers Range("A1")

End Sub

Sub ListeFichiers(Repertoire As String) 'procédure permettant de trouver le nom de l'image dans le répertoire ou sous répertoires, si il n'y a pas d'image trouvée la cellule est colorée

Dim fso, SourceFolder, SubFolder, Fichier, cheminETnom
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder(Repertoire)
Dim FichImg As String

    For Each Fichier In SourceFolder.Files

        FichImg = ""
        If Fichier Like "*.tif" Or Fichier Like "*.bmp" Then
            cheminETnom = Repertoire & "\" & Fichier.Name
            Cells(k, 2).Value = Split(cheminETnom, "\")(UBound(Split(cheminETnom, "\")))
            Cells(k, 3).Interior.Color = RGB(255, 0, 0)
            Cells(k, 3).Value = "L'image doit être mise en jpg"
            FichImg = Fichier.Name
            k = k + 1

        End If

If Fichier Like "*.jpg" Then 'permet de ne pas traiter les autres types de fichier sinon prb sur la suite
FichImg = Fichier.Name
End If

If Fichier Like "*.bmp" Then 'Note bmp âs de pixels
FichImg = ""
End If

If FichImg > "" Then Call TestPPP(FichImg) Else GoTo Fin

 If PixH > 1005 Or PixH < 995 Or PixV > 1005 Or PixV < 995 Then
            cheminETnom = Repertoire & "\" & Fichier.Name
            Cells(k, 2).Value = Split(cheminETnom, "\")(UBound(Split(cheminETnom, "\")))
            Cells(k, 3).Interior.Color = RGB(0, 0, 200)
            Cells(k, 3).Value = "Il faut l'image au format 1000x1000ppp"
            k = k + 1
        End If
Fin:
    Next Fichier

    For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
    Next SubFolder

End Sub

Sub TestPPP(Img As String)

Dim ResH, ResV, Image As String
    Image = Img
    ResH = FileProperty(Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Pictures", Img, 175)     ' "Résolution horizontale"
    ResV = FileProperty(Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Pictures", Image, 177)   ' "Résolution verticale"
    PixH = CInt(Replace(ResH, "ppp", "")): PixV = CInt(Replace(ResV, "ppp", ""))                ' Conversion du texte(hors ppp)en entier
End Sub

Function FileProperty(FilePath As String, FileName As String, PropInt As Integer) As String
    Dim objFolder As Object
    Dim objFolderItem As Object
    Dim objShell As Object

    FileProperty = vbNullString

    FileName = StrConv(FileName, vbUnicode): FilePath = StrConv(FilePath, vbUnicode)

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(StrConv(FilePath, vbFromUnicode))

    If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
    End If

    If Not objFolderItem Is Nothing Then
        FileProperty = Right(objFolder.GetDetailsOf(objFolderItem, PropInt), 6)
    Else
        FileProperty = vbNullString
    End If

    Set objShell = Nothing: Set objFolder = Nothing: Set objFolderItem = Nothing
End Function
Le 04/03/2021 à 22:50

Bonsoir Man.403030,

Désolée pour cette réponse si tardive sur le sujet

En effet, sacré confinement... penses quand même à posséder un ordi personnel.

Ci-dessous la sortie photo du programme présenté.

a1dossierpictures

J'ai simplement changé les couleurs pour que cela ressorte mieux. Bleu ciel si fichier autre que du type jpg et jaune si format de taille incorrect.

Cells(k, 3).Interior.Color = vbCyan
            'Cells(k, 3).Interior.Color = RGB(255, 0, 0)
            Cells(k, 3).Value = "L'image doit être mise en jpg"

... etc... suite du code...

            Cells(k, 3).Interior.Color = vbYellow
            'Cells(k, 3).Interior.Color = RGB(0, 0, 200)
            Cells(k, 3).Value = "Il faut l'image au format 1000x1000ppp"

Simplement le chemin en cellule A1 doit correspondre au chemin visé

Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Pictures"

Ci dessus Environ("HOMEDRIVE") & Environ("HOMEPATH") correspond à C:\Users\X_Cellus

Tandis que "\Pictures" représente le répertoire images ou existent un ensemble d'images.

Donc vérifie si dans ta cellule A1, il est inscrit le même chemin que la ligne de code commençant par Environ... et finissant par le répertoire visé pour tester tes images. Fais un essai par exemple sur ton répertoire image. Puis ensuite change le pour tester d'autres répertoires en oubliant pas de changer A1.

Je m'aperçois que lorsque je passe sur la fonction FileProperty il n'en ressort rien pour ResV et ResH

Car s'il ne ressort rien c'est que les chemins ne sont pas identiques simplement!

Le 09/03/2021 à 14:45

Merci j'ai pu résoudre le problème !!!

Bonne après midi

Rechercher des sujets similaires à "dimensions image"