XL 2016 commentaire doit s'adapter à une image importé

rodger85 · 4 Février 2023

Bonjour
je sais importer une image pour l'incorporer dans un commentaire mais le problème c'est l'image qui s'adapte au commentaire et pas l'inverse voici le code utilisé

VB:

With ActiveCell
.ClearComments
.AddComment
.Comment.Shape.Fill.UserPicture nf 'nf = Application.GetOpenFilename("Fichier jpg, *.*")
'---------------------------
' ce qui permet de donner une dimension au commentaire
' mais je voudrais que le commentaire s'adapte à la taille de l'image importé automatiquement
' et si j'enleve les 2 lignes du dessou je me retrouve avec un petit commentaire
 .Comment.Shape.Height = 450
 .Comment.Shape.Width = 635 ' = 22,41 cm
 '-----------------------------------
     .Comment.Shape.IncrementTop 24
     .Comment.Shape.Left = 300 '397
     .Comment.Visible = True
     .Comment.Shape.ZOrder msoBringToFront
     End With

Merci d'avance

mapomme · 5 Février 2023

Re,

Juste pour saluer @patricktoulon ,

Un fichier avec des images pour tester.

mapomme · 5 Février 2023

Bonjour @rodger85 ,

Avec de la grosse artillerie, voir le fichier joint.

patricktoulon · 5 Février 2023

Bonjour @mapomme
perso pour moi la grosse artillerie c'est ce genre de truc

VB:

Sub test()
    Dim nf, x, dimention_image
    nf = Application.GetOpenFilename("Fichier jpg, *.*")
    If nf = False Then Exit Sub
    Dim Img As Object
    PtoPX = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72
    With CreateObject("WIA.ImageFile")
    .LoadFile nf
        dimention_image = Array(.Width / PtoPX, .Height / PtoPX) ' dimention en point
    End With
    With ActiveCell
        .ClearComments: .AddComment
        .Comment.Shape.Height = dimention_image(1): .Comment.Shape.Width = dimention_image(0)
        ActiveCell.Comment.Shape.Fill.UserPicture nf
    End With
End Sub

rodger85 · 5 Février 2023

Bonjour mapomme
effectivement cela marche
je vais l'adapter à ma macro mais ce que je me suis aperçu
c'est qu'il faut lui adapter un DPI correct entre 150 et 300
puisque la macro s’appuie sur le DPI utilisé (X et Y)
mais ce n'est pas un problème
mais pourquoi dite vous "grosse artillerie"
car c'est la macro la plus simple et la plus efficace
que j'ai vu dans toute mes recherches
je vous tiens au courant
rodger

patricktoulon · 5 Février 2023

Bonjour
ma version s'appuie sur le DPI utilisé

patricktoulon · 5 Février 2023

le commentaire fait exactement la dimension de l'image
pour le test j'ai insérer 2 fois la même image dans la feuille sans la dimentionner
et une fois avec ma macro pour le commentaire
résultat

rodger85 · 5 Février 2023

évidement il y a un truc qui cloche
mais cela est de ma faute
je n'avais pas envoyé la macro en entière
c'est le "Dim nf, x" qui bloque
parque j'ai déja un " Dim nf As Variant"
voici la macro en entière

VB:

Sheets("Song").Select
Dim Fichier As String
Dim Chem As String
Dim nf As Variant
Chem = Worksheets("DonnéeGT100").Range("A70").Value
ChDrive Chem
ChDir Chem
nf = Application.GetOpenFilename("Fichier jpg, *.*")
If nf = False Then Exit Sub
With ActiveCell

 .ClearComments
 .AddComment
 .Comment.Shape.Fill.UserPicture nf
 .Comment.Shape.Height = 450
 .Comment.Shape.Width = 635 ' = 22,41 cm
 .Comment.Shape.IncrementTop 24
 .Comment.Shape.Left = 300 '397
 .Comment.Visible = True
 .Comment.Shape.ZOrder msoBringToFront
     End With
   
     Application.ScreenUpdating = True

j'ai essayé diverses manieres de l'integrer mais je n'y arrive pas

patricktoulon · 5 Février 2023

re
déjà là c'est toi qui dimensionne le comm et non a la dimension de l'image
après même comme ca le code est propre et semble fonctionnel
mais ca ne correspond pas à ta demande

patricktoulon · 5 Février 2023

et en fouillant bien mes vieux trucs et là je suis allé loin dans mes archives

VB:

Sub testavecIPictureDisp()
    Dim nf, pict As IPictureDisp, W&, H&
    nf = Application.GetOpenFilename("Fichier jpg, *.*")
    If nf = False Then Exit Sub
    Dim Img As Object
    dpi = Val(CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI"))
    ptopx = dpi / 72
    Set pict = LoadPicture(nf)
    With pict
        W = Round(.Width / 2540 * dpi) / ptopx
        H = Round(.Height / 2540 * dpi) / ptopx
    End With


    With ActiveCell
        .ClearComments: .AddComment
        .Comment.Shape.Height = H: .Comment.Shape.Width = W
        ActiveCell.Comment.Shape.Fill.UserPicture nf
    End With
End Sub

le result est le même

patricktoulon · 5 Février 2023

re
et une autre avec StdPicture

Code:

Sub TestAvecStdPicture()
    Dim nf, pict As New StdPicture, W&, H&
    nf = Application.GetOpenFilename("Fichier jpg, *.*")
    If nf = False Then Exit Sub
    Dim Img As Object
    dpi = Val(CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI"))
    PtoPX = dpi / 72
    Set pict = LoadPicture(nf)
    With pict
        W = Round(.Width / 2540 * dpi) / PtoPX
        H = Round(.Height / 2540 * dpi) / PtoPX
    End With


    With ActiveCell
        .ClearComments: .AddComment
        .Comment.Shape.Height = H: .Comment.Shape.Width = W
        ActiveCell.Comment.Shape.Fill.UserPicture nf
    End With
End Sub

voilà tu a 3 façons de connaitre la dimension d'une image
c'est @mapomme qui disait toute à l'heure "sortir la grosse artillerie "

mapomme · 5 Février 2023

Re,

Juste pour saluer @patricktoulon ,

Un fichier avec des images pour tester.

patricktoulon · 5 Février 2023

re
je teste ça tout a l'heure je suis sur un autre truc là

mapomme · 5 Février 2023

patricktoulon à dit:
re
je teste ça tout a l'heure je suis sur un autre truc là

Rien à tester, c'est le même code que dans mon premier message.
Me too, je vais me mettre sur un autre truc : la sieste thérapeutique.

patricktoulon · 5 Février 2023

re
oui ça fonctionne mais c'est pas l'artillerie lourde du moins pour moi

rodger85 · 5 Février 2023

merci à vous deux
maintenant cela marche
j'ai juste enlevé "Dim nf As Variant" de ma macro
comme ça j'ai pu insérer la votre (celle de mapomme)je garde les autres en réserve au cas ou.
deux semaines de recherche ,et voila des réponses efficace en peu de temps
Merci encore pour cette rapidité je pense que je reviendrai
car j'ai d'autres trucs qui sont un peu bizarre dans certaines de mes macros
rien de grave en soi ,mais il faut que je fasse un fichier qui marche seul
parque mes macros sont toutes imbriquées entre elles
Rodger85

XL 2016 commentaire doit s'adapter à une image importé

rodger85

XLDnaute Nouveau

mapomme

mapomme

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

rodger85

XLDnaute Nouveau

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

rodger85

XLDnaute Nouveau

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

rodger85

XLDnaute Nouveau

Discussions similaires