XL 2013 Insertion image (arrivée sur proposition "bureau")

[Usine à gaz]

Bonjour à toutes et à tous,

LOL, ça fait longtemps.
Faut dire que je suis en permanence ou presque connecté et que je trouve beaucoup de solutions que j'adapte à mes besoins et je ne vous en remercierai jamais assez.

J'ai un nouveau souci et, malgré mes tentatives et recherches sur le site, chez Mr Boisgontier et sur le web, je n'ai pas trouvé le bon code.

Mon besoin :
Je voudrais importer dans une feuille excel une image qui n'est jamais la même et qui peut être dans différents dossiers sur mon ordi.

L'enregistreur de macros m'oblige à définir un chemin
Tous les codes que j'ai trouvé insère une image toujours en codant un chemin.

Je n'arrive pas à faire un code qui m'anène tout simplement sur le bureau " Desktop".

Auriez-vous le bon code ?
Fichier test joint,

Avec mes remerciements,
Je vous souhaite une très bonne journée à toutes et à tous,
Amicalement,
Arthour973

 

[Lone-wolf]

Re Lionel

Je viens d'adapter le code et ça joue.

Option Explicit

Sub test()
Dim utilisateur As String, bdd As Variant, pos As Range, pict As Shape

    bdd = Application.GetOpenFilename("Tous les fichiers (*.*),*.*")
    utilisateur = Environ("Username")

    If bdd = False Then Exit Sub

    ActiveSheet.Pictures.Insert(bdd).Name = utilisateur
    Set pos = ActiveSheet.Range("c5")
    Set pict = ActiveSheet.Shapes(utilisateur)
  
    With pict
        .Left = pos.Left
        .Top = pos.Top
        .Height = pos.Height
        .Width = pos.Width

        .Placement = xlMove
        If .Height <> pos.Height Then
            .Height = pos.Height:
            .LockAspectRatio = msoFalse
        End If

        If .Width <> pos.Width Then
            .Width = pos.Width:
            .LockAspectRatio = msoTrue
        End If
    End With

End Sub

 

[Usine à gaz]

Merci Lone
J'avais pas eu le temps de regarder.
Dès que j'ai un petit moment, je regarde ton dernier code.
Grand Merci

 

[Usine à gaz]

Bsr Lone, le Forum,
ça fonctionne aussi.
Un grand Merci à toi,
Amicalement,
Arthour973

 

[Usine à gaz]

Bonjour Lolote83, Mr Boisgontier, Lone,

J'ai pris le temps de tester vos codes et ils fonctionnent nickel (un grand merci) à un poil près LOL

Code de Lolote et de Lone :
L'image (ou photo) s'insère bien aux dimensions de la plage voulue mais ne respecte pas les proportions.

Code de Mr Boisgontier :
- L'image (ou photo) s'insère bien aux dimensions de la plage voulue et respecte les proportions si l'image n'est pas plus grande que les cellules destinataires,

- NE MET PAS AUX DIMENTIONS cellules destinataires si la photo est plus grande.

Je joins le fichier joint avec exemples.

Est-il possible de résoudre ce "petit" souci ?

Avec mes remerciements,
Je vous souhaite un bon WE à toutes et à tous
Amicalement,
Arthour973,

 

[Lone-wolf]

Bonjour Lionel

Vu que les cellules sont fusionnées, un essai comme ceci.

Set pos = ActiveSheet.Range("L22:M29").MergeArea

 

[Usine à gaz]

Salut Lone,
Merci d'être toujours là
Je vais voir ...

 

[Usine à gaz]

Re,
ça marche pas LOL
J'ai remplacé : Set pos = ActiveSheet.Range("L12:M18")
Par : Set pos = ActiveSheet.Range("L12:M18").MergeArea


Le code se bloque sur cette ligne et il importe sans re-dimentionner.

 

[Lone-wolf]

Re,

Fais un essai sans mettre M18 pour voir, sinon je ne vois pas comment faire autrement.

 

[Lone-wolf]

Re,

Je viens de faire un test avec ceci, mais je ne sais pas si c'est ça que tu veux.

Sub test()
    Set pos = ActiveSheet.Range("h4").MergeArea
    Set pict = ActiveSheet.Pictures

    With pict
        .Left = pos.Left
        .Top = pos.Top
        .Height = pos.Height
        .Width = pos.Width
        If .Height <> pos.Height Then
            .Height = pos.Height:
            .ShapeRange.LockAspectRatio = msoFalse
        End If

        If .Width <> pos.Width Then
            .Width = pos.Width:
            .ShapeRange.LockAspectRatio = msoTrue
        End If
    End With
End Sub

 

[Usine à gaz]

Bonjour Lone, le Forum,

J'ai cherché, j'ai tenté mais je n'y arrive pas.
Ne perdons pas trop de temps pour cette demande de confort.
On laisse tomber ..... peut-être un jour ? LOL
Bon dimanche à toutes et à tous,
Amicalement,
Arthour973,

 

[Lone-wolf]

Bonjour Lionel

As-tu fais un test avec le dernier code du post 24???

 

[Usine à gaz]

LOL, oh que oui, j'ai passé ma matinée à tout tester et à chercher
En fait, ton code marche bien mais n'insère pas l'image dans la plage sélectionnée en respectant les proportions.
Ne t'embête pas, ce n'est pas si grave.
Déjà un grand merci

 

[Lone-wolf]

Re

De quel proportions tu parle et de qu'elle plage??? J'ai fait 2 test; un en mode carré(cellules), l'autre rectangulaire avec une petite image carrée et elle s'adapte bien aux cellules fusionnées.

 

[Usine à gaz]

OUI mais si une photo n'est pas carrée, les proportions ne sont pas respectées

 

[Lone-wolf]

Re,

Je viens de faire un test avec image rectangulaire et cellules fusionnées carrées. L'image s'adapte aux cellules. Double-clique sur la feuille pour voir le résultat.