Récupérer les dimentions d'un fichier image

Syntaxerror · 3 Mars 2009

Récupérer les dimensions d'un fichier image

Salut le forum !
Après avoir écrit un code qui insère une image récupérer par une boite de dialogue getopenfile dans un commentaire (c'est moi qui l'ai fait ! 🙂)
Je m'aperçoit qu'en fonction des dimensions de l'image, celle ci est souvent écrasée. Je voudrais récupérer les dimension de l'image du fichier afin de redimentionner la bulle de mon commentaire. Voici ma macro:

Code:

Sub bullimage()
'
'
' Macro enregistrée le 24/02/2009 par Christophe
'


    ActiveCell.AddComment
    ActiveCell.Comment.Visible = False
    ActiveCell.Comment.Text Text:=""
    ActiveCell.Comment.Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
    ActiveCell.Comment.Shape.Fill.BackColor.RGB = RGB(255, 255, 255)
    
    ChDir ("G:\_Chemdraw")
        CheminFichier = Application.GetOpenFilename(FileFilter:="Fichiers Image (*.jpg;*.gif), *.jpg;*.gif  ", Title:="Fichier jpg")
        'Arrêt de la procédure si on clique sur Annuler
        If Trim(CheminFichier) = "Faux" Then Exit Sub
        
    'taille = TaillePixelsImage(CheminFichier, Trim(CheminFichier))
        
        
    ActiveCell.Comment.Shape.Fill.UserPicture (CheminFichier)
    ActiveCell.Comment.Shape.LockAspectRatio = msoFalse
    
    ActiveCell.Hyperlinks.Add anchor:=ActiveCell, Address:=CheminFichier, TextToDisplay:=ActiveCell.Value
    
    ActiveCell.Offset(-1, 0).Copy
    ActiveCell.PasteSpecial (xlPasteFormats)
           
End Sub

Après un longue recherche j'ai trouvé dans le forum ce morceau de code :

Code:

Function TaillePixelsImage(repertoire, fichier)
  Set myShell = CreateObject("Shell.Application")
  Set myFolder = myShell.Namespace(repertoire)
  Set myFile = myFolder.Items.Item(fichier)
  TaillePixelsImage = myFolder.GetDetailsOf(myFile, 26)
End Function

Mais je ne parviens pas à l'appliquer à ma macro (snif !). Si quelqu'un pouvait m'aider à l'intégrer ou avec un autre ID....

Merci d'avance

chris · 3 Mars 2009

Re : Récupérer les dimentions d'un fichier image

Bonjour

En se basant sur le Wiki de MichelXLD

Il faut initialiser les variables Repertoire et Nom :
sans doute
"G:\_Chemdraw" et CheminFichier
Après avoir chargé l'image, puis

Code:

Activecell.Comment.Shape.Width = Val(dimensionsImage(Repertoire, Nom, 27))
Activecell.Comment.Shape.Height = Val(dimensionsImage(Repertoire, Nom, 28))

et ajouter la fonction suivante dans ton module

Code:

Public Function dimensionsImage(Chemin As Variant, nomImage As Variant, Itm As Integer)
Dim objShell As Object, strFileName As Object
Dim objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.nameSpace(Chemin)
Set strFileName = objFolder.Items.Item(nomImage)
    dimensionsImage = objFolder.getDetailsOf(strFileName, Itm)
Set objShell = Nothing
Set strFileName = Nothing
Set objFolder = Nothing
End Function

D'après mes essais il faut un peu adapter pour vista.

Syntaxerror · 3 Mars 2009

Re : Récupérer les dimentions d'un fichier image

Merci pour le "petit" coup de main. Comme tu me l'a dis j'ai essayé d'adapter ton code au miens
.
Pour info chdir sert juste à redéfinir le dossier par défaut et n'est pas forcément le dossier du fichier. Dans "G:\_Chemdraw" il y'a d'autre sous-dossier c'est pour ça que j'ai rajouter pour avoir le nom du dossier :

Code:

Set fs = CreateObject("Scripting.FileSystemObject")
    dossier = fs.GetParentFolderName(cheminFichier)

Voici l'intégralité du code :

Code:

Public Function dimensionsImage(cheminFichier As Variant, dossier As Variant, Itm As Integer)
Dim objShell As Object, strFileName As Object
Dim objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(dossier)
Set strFileName = objFolder.Items.Item(cheminFichier)
    dimensionsImage = objFolder.getDetailsOf(strFileName, Itm)
Set objShell = Nothing
Set strFileName = Nothing
Set objFolder = Nothing
End Function

Sub bullimage()
'
'
' Macro mise à jour le 03/03/09 par CVO
    Dim fs As Object

        ChDir ("G:\_Chemdraw")
        cheminFichier = Application.GetOpenFilename(FileFilter:="Fichiers Image (*.jpg;*.gif), *.jpg;*.gif  ", Title:="Fichier Image")
        'Arrêt de la procédure si on clique sur Annuler
        If Trim(cheminFichier) = "Faux" Then Exit Sub
        
    Set fs = CreateObject("Scripting.FileSystemObject")
    dossier = fs.GetParentFolderName(cheminFichier)
    
    
    ActiveCell.AddComment
    ActiveCell.Comment.Visible = False
    ActiveCell.Comment.Text Text:=""
    ActiveCell.Comment.Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
    ActiveCell.Comment.Shape.Fill.BackColor.RGB = RGB(255, 255, 255)
    
       
    ActiveCell.Comment.Shape.Fill.UserPicture (cheminFichier)
    ActiveCell.Comment.Shape.LockAspectRatio = msoFalse
    ActiveCell.Comment.Shape.Width = Val(dimensionsImage(cheminFichier, dossier, 27))
    ActiveCell.Comment.Shape.Height = Val(dimensionsImage(cheminFichier, dossier, 28))
    
    ActiveCell.Hyperlinks.Add anchor:=ActiveCell, Address:=cheminFichier, TextToDisplay:=ActiveCell.Value
    
    ActiveCell.Offset(-1, 0).Copy
    ActiveCell.PasteSpecial (xlPasteFormats)
           
End Sub

Malheureusement ça ne marche pas : la dimension renvoyée est nulle et le commentaire est microscopique...
Je me demande si mes variables "cheminfichier"et "dossier" sont au bon format pour la fonction "dimensionsImage". Je m'interroge...

chris · 3 Mars 2009

Re : Récupérer les dimentions d'un fichier image

Bonjour

Dans un classeur à moi, cela fonctionne.

As-tu vérifié ce qui se passe en mode débug ?
As-tu bien windows XP ?

Syntaxerror · 4 Mars 2009

Re : Récupérer les dimentions d'un fichier image

Oui je travaille bien sous windows XP
Ce matin ca marche encore moins bien....
J'ai un bug avec le message d'erreur suivant :
Erreur d'execution xxxxxx....
La méthode 'namespace' de l'objet 'Ishelldispastch4' a échoué

C ballot...

Chris (aussi) ;-)

James007 · 4 Mars 2009

Re : Récupérer les dimentions d'un fichier image

Bonjour,

Est-ce-que tu as essayé une simple fonction UDF ...
avec le chemin complet saisi entre des guillemets ...

Code:

Function TailleFichier(Chemin As String)
Dim fso As Object
Dim oFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFile = fso.GetFile(Chemin)
TailleFichier = oFile.Size
End Function

A +

Syntaxerror · 4 Mars 2009

Re : Récupérer les dimentions d'un fichier image

Aïe ! Merci James007 mais j'ai bien peur même sans essayer que size renvoi la taille en octet du fichier.
Or moi, ce qu'il me faut c'est les dimension de l'image en pixel (hauteur x largeur) pour pouvoir redimensionner le commentaire dans lequel se trouve l'image.

Merci quand même pour ton aide

James007 · 4 Mars 2009

Re : Récupérer les dimentions d'un fichier image

Oops ... je n'avais pas lu tout le fil ... désolé ...

C'est forcément possible en API ... je ne l'ai jamais fait ...
Dès que j'ai un moment, je creuse ton problème ...

A+

James007 · 4 Mars 2009

Re : Récupérer les dimensions d'un fichier image

SyntaxError,

Si tu veux pousser le bouchon un peu plus loin en API 🙁et en anglais)
API: Copy an image to the Clipboard

A+

chris · 4 Mars 2009

Re : Récupérer les dimentions d'un fichier image

Bonjour

Peux-tu poster un classeur éventuellement simplifié avec juste ce code et un ou deux commentaires.

Il te manque peut-être une library dans les références mais cela t'aurais jeté dès le début.

Je me suis servie de cette API pour des logos d'en-tête et j'ai aussi refait un test sur un commentaire et je n'ai pas eu de PB.

MichelXld · 4 Mars 2009

Re : Récupérer les dimentions d'un fichier image

bonsoir à vous

Remplace

Code:

    ActiveCell.Comment.Shape.Width = Val(dimensionsImage(cheminFichier, dossier, 27))
    ActiveCell.Comment.Shape.Height = Val(dimensionsImage(cheminFichier, dossier, 28))

par

Code:

    ActiveCell.Comment.Shape.Width = Val(dimensionsImage(Dir(cheminFichier), dossier, 27))
    ActiveCell.Comment.Shape.Height = Val(dimensionsImage(Dir(cheminFichier), dossier, 28))

bonne soirée
michel

Syntaxerror · 4 Mars 2009

Re : Récupérer les dimensions d'un fichier image

@ James : API ? Mais je sais même pas ce que API veut dire... J'ai l'embarra du choix dans ces différentes définitions

@ Michelxld : effectivement avec un petit Dir, ça passe mieux... Cependant je retrouve le problème de départ : des commentaires avec une taille de 0x0 pixel. Je l'ai testé ce soir chez moi sous Vista. Je réessairai demain au boulot sous XP.

@Chris : un classeur ci-joint

@ n'importe quel modo de passage : pourrait il me corriger la faute d'orthographe que j'ai commise dans le titre. J'ai honte....

chris · 5 Mars 2009

Re : Récupérer les dimentions d'un fichier image

Bonjour

Chez moi ton classeur marche (sous XP) mais sous Vista cela ne marche pas car l'Api ne gère plus ou pas pour les images les paramètres 27 et 28.

On peut utiliser un autre paramètre qui contient les deux dimensions et le découper mais c'est + compliqué. Et cela nécessite de détecter quelle version est utilisée si on veut que le même code gère les 2 versions.

Quand je parlais du mode debug : il t'aurait permis de voir que tu passais à la fonction non pas le nom du fichier seul mais l'ensemble chemin nom, d'où le dysfonctionnement.

Syntaxerror · 5 Mars 2009

Re : Récupérer les dimentions d'un fichier image

Et...Ca marche (sous XP) !!!:-D
J'avais bien compris pour le mode debug mais quand j'ai regardé j'ai u l'erreur d'execution

Encore merci à tous pour le coup de main. On s'y remettra dans quelques année lorsque ma société aura passé tous les PC sous Vista...

En attendant je vous souhaite à tous une bonne journée

Effectuez une recherche sur Excel Downloads...

Récupérer les dimentions d'un fichier image

Syntaxerror

XLDnaute Junior

chris

XLDnaute Barbatruc

Syntaxerror

XLDnaute Junior

chris

XLDnaute Barbatruc

Syntaxerror

XLDnaute Junior

James007

XLDnaute Barbatruc

Syntaxerror

XLDnaute Junior

James007

XLDnaute Barbatruc

James007

XLDnaute Barbatruc

chris

XLDnaute Barbatruc

MichelXld

XLDnaute Barbatruc

Syntaxerror

XLDnaute Junior

Pièces jointes

chris

XLDnaute Barbatruc

Syntaxerror

XLDnaute Junior

Discussions similaires

Nous accordons de l'importance à votre vie privée