Copier une image d'un tableur à un autre

[__xD]

Bonjour à tous,

ce post peut sembler bien similaire à d'autres : je cherche "simplement" à copier une image d'un classeur à un autre. J'ai fait quelques recherches mais tous les codes que je trouve sont dans le cas où l'on connait déjà l'emplacement de l'image ou dans le cas où on ne cherche à copier qu'une image.
Mon problème est plus compliqué : je dois rajouter des feuilles à un classeur qui peuvent contenir des images, mais je ne sais pas à l'avance si le fichier à ajouter en contient ou non. Et si il contient une image, il contient la plupart du temps du texte aussi...

Je cherche donc à mettre en place une sorte de boucle qui cherche une image, si elle en trouve elle copie l'image exactement au même endroit et au même format d'origine (c'est très important car le fichier d'origine possède déjà le format d'impression désiré par l'utilisateur et il ne doit pas y avoir de changement à ce niveau là), puis la macro copie également le texte présent sur le fichier...

Je débute en VBA et même si mon ajout d'annexe foncitonne bien, je n'y connais rien en manipulation d'image et il me manque ce cas de figure...

Je joins mes deux fichiers tests, merci à ceux qui me mettront sur la voie

 

[pierrejean]

Re : Copier une image d'un tableur à un autre

Bonjour _xD

A tester:

Sub AjoutAnnexe()
Dim classeurSource As Workbook, classeurDestination As Workbook
Set classeurDestination = ThisWorkbook
Set classeurSource = Application.Workbooks.Open(Application.GetOpenFilename(), , False, , , , , , , True)
With classeurDestination
    .Activate
    Sheets.Add After:=Sheets(Sheets.Count)
    classeurSource.Sheets(1).UsedRange.Copy
    .Sheets(Sheets.Count).Paste Link:=True
    For n = 1 To classeurSource.Sheets(1).Shapes.Count
       classeurSource.Sheets(1).Shapes(n).Copy
       ad = classeurSource.Sheets(1).Shapes(n).TopLeftCell.Address
       .Sheets(Sheets.Count).Select
       Range(ad).Select
       ActiveSheet.Paste
    Next n
End With
ActiveWindow.DisplayZeros = False
'Efface les zéros, problème si un zéro est déjà présent --> Demander à Jérome
'ne fonctionne pas avec les fichiers de la version au dessus !
classeurSource.Close False
End Sub

 

[kjin]

Re : Copier une image d'un tableur à un autre

bonjour,
Pas vraiment compris l'histoire...
Pourquoi la macro de copie dans le classeur de destination ?!
Si tel est le cas...dans wbSource

Public ws As Worksheet

Sub Copie()
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set wb = Workbooks.Open(ThisWorkbook.Path & "\wbDest.xls")
Application.Run "wbDest.xls!AjoutAnnexe", ws
End Sub

...et dans wbDest

Sub AjoutAnnexe(ws As Worksheet)
With ThisWorkbook
    ws.Copy after:=.Sheets(Sheets.Count)
    .Close True
End With
End Sub

Voir PJ
A+
kjin

 

[__xD]

Re : Copier une image d'un tableur à un autre

Bonjour Kjin, PJ,

J'ai mis la macro dans dans le classeur dest puisque c'est depuis ce classeur que l'on fait le choix de rajouter une annexe donc dans ma logique je clique sur le bouton, je choisis puis la macro ouvre le fichier le copie et le colle dans un nouvel onglet... non ?

Ton code fonctionne à merveille, merci beaucoup, mais je ne le comprends pas totalement
Peux-tu m'expliquer rapidement son fonctionnement ?
Il me reste un détail, je remarque que lorsque du texte est présent dans mes fichiers sa mise en forme n'est pas conservée (exemple, je passe de "cet exemple de texte" à "cet exemple de texte"), ce qui est assez embêtant pour l'utilisateur
Il me faudrait figer la mise en forme, savez-vous comment cela se traduit-il en vba ?

 

[kjin]

Re : Copier une image d'un tableur à un autre

Re, salut PierreJean

Ton code...

Euh oui ! l'un ou l'autre
A+
kjin

 

[__xD]

Re : Copier une image d'un tableur à un autre

??
Mon code est désormais celui de PierreJean

Sub AjoutAnnexe()
Dim classeurSource As Workbook, classeurDestination As Workbook
Set classeurDestination = ThisWorkbook
Set classeurSource = Application.Workbooks.Open(Application.GetOpenFilename(), , False, , , , , , , True)
With classeurDestination
    .Activate
    Sheets.Add After:=Sheets(Sheets.Count)
    classeurSource.Sheets(1).UsedRange.Copy
    .Sheets(Sheets.Count).Paste Link:=True
    For n = 1 To classeurSource.Sheets(1).Shapes.Count
       classeurSource.Sheets(1).Shapes(n).Copy
       ad = classeurSource.Sheets(1).Shapes(n).TopLeftCell.Address
       .Sheets(Sheets.Count).Select
       Range(ad).Select
       ActiveSheet.Paste
    Next n
End With
ActiveWindow.DisplayZeros = False
'Efface les zéros, problème si un zéro est déjà présent --> Demander à Jérome
'ne fonctionne pas avec les fichiers de la version au dessus !
classeurSource.Close False

End Sub

Il me faudrait la petite phrase en plus qui dit "Koutata, ne touche pas à la mise en forme d'origine "

 

[pierrejean]

Re : Copier une image d'un tableur à un autre

Re

Teste celle ci

Sub AjoutAnnexe()
Dim classeurSource As Workbook, classeurDestination As Workbook
Set classeurDestination = ThisWorkbook
Sheets.Add After:=Sheets(Sheets.Count)
Set classeurSource = Application.Workbooks.Open(Application.GetOpenFilename(), , False, , , , , , , True)
classeurSource.Sheets(1).UsedRange.Copy Destination:=ThisWorkbook.ActiveSheet.Range("A1")
    For n = 1 To classeurSource.Sheets(1).Shapes.Count
       classeurSource.Sheets(1).Shapes(n).Copy
       ad = classeurSource.Sheets(1).Shapes(n).TopLeftCell.Address
       classeurDestination.Activate
       Sheets(Sheets.Count).Select
       Range(ad).Select
       ActiveSheet.Paste
    Next n
ActiveWindow.DisplayZeros = False
classeurSource.Close False
End Sub

 

[__xD]

Re : Copier une image d'un tableur à un autre

Bonjour,

Je suis désolée pour ce temps de réponse, je n'ai plus eu internet pendant quelques temps . Cette méthode fonctionne à merveille concernant la copie, mais après plusieurs bugs, j'ai réalisé que le lien est effectivement mis en place lorsqu'il s'agit... de texte ! Lorsque je veux copier une image, elle est bien copiée mais par contre j'ai systématiquement l'erreur "la méthode paste a échoué" ce qui m'amène à poser cette question : peut-on utiliser link:= true lorsqu'il s'agit d'une image ?

De plus, le code ne conserve pas la mise en forme, en revanche, en utilsant le code ci dessous, la mise en forme est conservée :

Sub Macro2()  

Dim classeurSource As Workbook, classeurDestination As Workbook
Set classeurDestination = ThisWorkbook
Set classeurSource = Application.Workbooks.Open(Application.GetOpenFilename(), , False, , , , , , , True)
    
    For Each exWS In classeurSource.Worksheets
    classeurDestination.Sheets.Add After:=classeurDestination.Sheets(1 _
        )
    Windows(classeurSource.Name).Activate
    exWS.Select
    Selection.Copy
    exWS.Copy After:=classeurDestination.Sheets(1 _
        )
    
    Next exWS
    
    
    
End Sub

Je suis donc en train d'essayer de mettre en commun ces deux codes...