Problème copie d'image

Version imprimable

Voir 40 message(s) de cette discussion en une page

Bonjour,

dans ma boucle de test, certaines image ne sont pas mise en page, la cellule reste blanche, soit la sélection et le "copy" par ActiveSheet.Shapes(shp.Name).Copy ne se font pas, soit "ActiveSheet.Paste" ne s'exécute pas. J'ai vérifié la boucle s'exécute bien jusqu'au bout mais il y a des manques d'image sur certaines lignes de façon aléatoire.

Je n'arrive pas à déterminer avec le pas à pas

Avez-vous eu ce problème ?
peut-on changer (de façon simple) la méthode pour copier/coller une image. j'ai vu beaucoup de choses mais complexe pour moi...
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 Sub test() Dim Delta1 As Integer Dim i1 As Integer Dim s As Variant Application.ScreenUpdating = False Delta1 = 6 ' Feuille des images Set catalogue = Workbooks("Image.xlsm").Sheets("Image") ' Feuille contenant la mise en page Set edition = Workbooks("Mise en page.xlsm").Sheets("Edition") For i1 = 1 To 50 ' Sélection de l'image catalogue.Activate Range("D" & i1).Select For Each shp In ActiveSheet.Shapes If shp.Top = catalogue.Range("D" & i1).Top Then ActiveSheet.Shapes(shp.Name).Copy ' Positionnement sur la mise en page de l'édition edition.Activate 'Delta1 = Delta1 + 5 Range("B" & Delta1 + 2).Select ' Copie de la nouvelle image ActiveSheet.Paste 'Delta1 = Delta1 + 5 End If Next Delta1 = Delta1 + 5 Next i1 Application.ScreenUpdating = True End Sub

salut retraité
prend un fichier vierge ,met lui des images ou shapes en colonne"D" ou tu veux a partir de la ligne 1 jusqu'a la ligne 50 juste 2 ou 3 pour l'exemple

et lance ce code
l'explication est dans les commentaires

il te sera facile d'adapter ca sur deux classeurs
il ne te reste plus qu'a boucler sur les noms des copies pour les positionner (((((leur nom c'est l'adress de destination)))))
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Sub test() Dim tabloimage() Delta = 8 'on rassemble les images dans un tableau For Each shap In ActiveSheet.Shapes If shap.TopLeftCell.Row >= 1 And shap.TopLeftCell.Row <= 50 And shap.TopLeftCell.Column = 4 Then i = i + 1: ReDim Preserve tabloimage(1 To i): shap.Name = "B" & Delta: tabloimage(i) = shap.Name: Delta = Delta + 7 End If Next 'maintenant on va les grouper,copier,degrouper et coller la copie du groupe en colonne b a partir de la ligne 8 ' on degroupe les image de la copie 'elles devraient porter comme nom l'address des cellules de destination selon delta +2 +5 donc 7 With ActiveSheet With .Shapes.Range(tabloimage): .Group.Copy: .Ungroup: End With .Cells(8, 2).Select .Paste .Shapes(.Shapes.Count).Ungroup End With End Sub
voila en fait tu copie une seule fois mais toutes les shapes en meme temps
ce qui devrait limiter tes activate entre deux classeur
et je suis pratiquement sur que meme avec deux classeurs les activates ne sont pas necessaires a tester
fait moi plaisir teste et observe
;)

Merci Patrick,

j'ai intégré ton code et j'ai l'erreur :

"erreur d'exécution 1004 Erreur définie par l'application ou l'objet" sur la ligne :
Code:

1 2 With .Shapes.Range(tabloimage)
Je pense que dans :
Code:

1 2 3 4 5 For Each shap In ActiveSheet.Shapes If shap.TopLeftCell.Row >= 1 And shap.TopLeftCell.Row <= 5 And shap.TopLeftCell.Column = 4 Then i = i + 1: ReDim Preserve tabloimage(1 To i): shap.Name = "B" & Delta: tabloimage(i) = shap.Name: Delta = Delta + 7 End If
il faut mettre
Code:

1 2 i = i + 1: ReDim Preserve tabloimage(1 To i): shap.Name = "B" & Delta: tabloimage(i) = shap.Name: Delta = Delta + 5
La première image est à mettre en B8, la seconde en B13, puis B18 et ainsi de suite

Autre point, dans une deuxième temps, après la mise au point je veux retailler les images, j'imagine quelque chose comme cela :
Code:

1 2 .ShapeRange.ScaleHeight 0.4693333333, msoFalse, msoScaleFromTopLeft
entre .Paste et .Shapes au niveau de :
Code:

1 2 3 .Paste .Shapes(.Shapes.Count).Ungroup

16/05/2018, 11h34
patricktoulon

re

re
bonjour
regarde tes variables local je peux pas deviner la raison

et avant tout testeavec 2 fichiers vierges avant de l'intégrer dans ton fichier

1 pièce(s) jointe(s)

Voilà le résultat en pièces jointes de mon test, fichier neuf, 3 images en D1, D2 et D3

la variable Delta = 23 n'est pas normale, cela correspond à la 4éme image (8,13,18,23) hors il n'y en a que 3, donc pas d'arrêt ?

le message est :
"L'élément portant ce nom est introuvable"

j'ai ajouté des activate dans le code sinon ça plantait dès le début

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
 
Sub test()
 
Dim Delta As Integer
Dim i As Integer
Dim tabloimage()
Application.ScreenUpdating = False
Delta = 8
 
' Feuille du classeur contenant les images
Set catalogue = Workbooks("Catalogue.xlsm").Sheets("test")
' Feuille du classeur contenant la mise en page
Set edition = Workbooks("mise en page.xlsm").Sheets("edition")
 
'on rassemble les images dans un tableau
catalogue.Activate
    For Each shap In ActiveSheet.Shapes
        If shap.TopLeftCell.Row >= 1 And shap.TopLeftCell.Row <= 3 And shap.TopLeftCell.Column = 4 Then
            i = i + 1: ReDim Preserve tabloimage(1 To i): shap.Name = "B" & Delta: tabloimage(i) = shap.Name: Delta = Delta + 5
        End If
    Next
    'maintenant on va les grouper,copier,degrouper et coller la copie du groupe en colonne b a partir de la ligne 8
    ' on degroupe les image de la copie
    'elles devraient porter comme nom l'address des  cellules de destination selon delta  +2 +5 donc 7
    edition.Activate
    With ActiveSheet
        With .Shapes.Range(tabloimage): .Group.Copy: .Ungroup: End With
        .Cells(8, 2).Select
        .Paste
        .Shapes(.Shapes.Count).Ungroup
    End With
 
Application.ScreenUpdating = True
End Sub

16/05/2018, 13h14
patricktoulon

re

donne moi ,tes deux fichiers neufs avec tes 3 images je regarderais tout a l'heure
pour le moment occupé en compta
16/05/2018, 13h36
retraite83

2 pièce(s) jointe(s)

C'est très sympa de ta part, merci

voilà mes 2 fichiers

2 pièce(s) jointe(s)

re
voila
tu a meme pas besoins d'ouvrir ton classeur source d'image ca le fait tout seul
une simple petite adaptation de l'exemple que je t'avais donné
verifie le chemin de es-catalogues j'ai considéré qu'il etaient au meme endroit c'est peut etre pas le cas

code declenché par ton bouton dans ton classeur d'edition

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Option Explicit
Sub test()
    Dim tabloimage(), WindoWname As String, WbKSource As Workbook, delta As Long, shap, i As Long
    delta = 8
    WindoWname = ThisWorkbook.Name
    Set WbKSource = Workbooks.Open(ThisWorkbook.Path & "\ES-Catalogue.xlsm")
    'on rassemble les images dans un tableau
    With WbKSource.Sheets("Param Services")
        For Each shap In .Shapes
            If shap.TopLeftCell.Row >= 1 And shap.TopLeftCell.Row <= 50 And shap.TopLeftCell.Column = 4 Then
                i = i + 1: ReDim Preserve tabloimage(1 To i): shap.Name = "B" & delta: tabloimage(i) = shap.Name: delta = delta + 5
            End If
        Next
        With .Shapes.Range(tabloimage): .Group.Copy: .Ungroup: End With
    End With
    Windows(WindoWname).Activate
    With ActiveSheet
        Cells(8, 2).Select: .Paste: .Shapes(1).Ungroup
        For Each shap In .Shapes
            If shap.Name <> "Button 1" Then shap.Left = .[B1].Left: shap.Top = .Range(shap.Name).Top
        Next
    End With
    'on ferme la source image on en a plus besoins
    Application.DisplayAlerts = False
    WbKSource.Close
End Sub

17/05/2018, 11h46
retraite83

2 pièce(s) jointe(s)

merci pour ton code, jamais je n'aurai pu faire cela seul…

Je suis en train de faire fonctionner ton code sans encore l'adapter chez moi, j'ai une erreur:

erreur 70 permission refusée (regarde la pièce jointe)

mes 2 classeurs sont dans le même répertoire

je te joins aussi un fichier où l'on voit les 3 images groupées avant le bug
17/05/2018, 11h52
patricktoulon

1 pièce(s) jointe(s)

re

re
ca fonctionne avec mes fichiers alors ca vient de tes fichiers ou encore de 2016 et l'accessibilité des objects dynamiques(en terme de temps) qui est vraiment un probleme sur cette version de excel
j'ai pas 2016 a porté aujourd'hui je ne peux pas tester mais ca m'etonnerais pas
met un msgbox"bonjour" juste avant cette ligne et laisse une seconde afficher le message et clique ok pour voir

demo chez moi 2007
Pièce jointe 381316
17/05/2018, 11h56
retraite83

oui le bonjour s'affiche bien avant l'erreur
17/05/2018, 12h02
patricktoulon

1 pièce(s) jointe(s)

re

non tu m'a pas compris c'est de ma faute
il faut que tu le mette au bon endroit le msgbox

Code:

Cells(8, 2).Select: .Paste: MsgBox "coucou": .Shapes(1).Ungroup

si ca marche comme ca il faudra faire une gestion d'attente
dans cette demo on vois bien les shaps groupées avant la fermeture du msgbox
Pièce jointe 381324
17/05/2018, 12h10
retraite83

Oui le petit coucou apparait bien...
17/05/2018, 12h23
patricktoulon

re

oui je sais bien mais est ce que ca fonctionne la separation apres?
avec la ligne tel que je te l'ai donné?????????
17/05/2018, 12h41
retraite83

Non quand je fais "ok" sur la msgbox j'ai ensuite la même erreur : erreur 70 permission refusée
17/05/2018, 12h51
patricktoulon

re

tu a essayé avec mes fichiers ou les tiens
17/05/2018, 12h58
retraite83

Avec les miens puis avec ceux en pièces jointes du #8 (les tiens je pense)
17/05/2018, 13h11
patricktoulon

re

purré on est pas arrivé
les miens fonctionnent chez toi ou pas ?
17/05/2018, 13h16
retraite83

si ce sont ceux que je charge à partir du post #8 non même pb qu'avec les miens
17/05/2018, 13h22
patricktoulon

re

purré je vais supputer

essaie ca dans le me mien pas les tiens

Code:

Cells(8, 2).Select: .Paste: .Shapes(2).Ungroup

en meme temps se serait logique mais bon visiblement 2007 et 2016 fonctionnent pas pareil

allez accelere teste ca ;)

Voir 40 message(s) de cette discussion en une page

Fuseau horaire GMT +2. Il est actuellement 06h39.