Copier coller une photo en VBA

Version imprimable

23/11/2016, 14h25
MoristO

1 pièce(s) jointe(s)

Copier coller une photo en VBA

Bonjour Les experts,

J'aurai besoin de votre précieuse aide, je suis entrain de générer une fiche candidat (fenêtre excel ) depuis une liste de candidat avec un simple clic sur le bouton Lance ( en haut a gauche dans l'onglet liste ),mon problème est que je n'arrive pas à copier coller les photos des candidats dans la fiche de chaque Candidat.

Ci-joint le fichier sur lequel je travaille.

Merci de m'aider à corriger/ajuster mon code VBA.Pièce jointe 225652

Dans ta feuille vierge Fiche Candidat tu insères deux contrôles Images ActiveX (Onglet developpeur > insérer > Contrôlre ActiveX) nommés Image1 et Image2
Dans ta feuille Liste tu insère le nom complet de chaque image (Colonnes P et Q)

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
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
Sub creation_fiche()
Dim DerLigne As Long, i As Long
Dim Feuil As String, Img As String
Dim Ws As Worksheet
 
Application.ScreenUpdating = False
With Worksheets("Liste")
    DerLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
    For i = 6 To DerLigne
        Feuil = " Candidat " & .Cells(i, 1)
        If Feuil <> "" Then
            If FeuilleExiste(Feuil) Then
                Set Ws = Worksheets(Feuil)
            Else
                Worksheets("Fiche candidat").Copy after:=Worksheets(Worksheets.Count)
                Set Ws = ActiveSheet
                Ws.Name = Feuil
            End If
 
            Img = .Cells(i, 16).Value
            If Dir(Img) <> "" Then Ws.OLEObjects("Image1").Object.Picture = LoadPicture(Img)
            Img = .Cells(i, 17).Value
            If Dir(Img) <> "" Then Ws.OLEObjects("Image2").Object.Picture = LoadPicture(Img)
 
            Ws.Range("K1") = .Cells(i, 1)
            Ws.Range("C7") = .Cells(i, 2)
            Ws.Range("C7") = .Cells(i, 3)
            Ws.Range("C8") = .Cells(i, 4)
            Ws.Range("I2") = .Cells(i, 5)
            Ws.Range("D2") = .Cells(i, 6)
            Ws.Range("C13") = .Cells(i, 7)
            Ws.Range("C14") = .Cells(i, 8)
            Ws.Range("C15") = .Cells(i, 9)
            Ws.Range("I13") = .Cells(i, 10)
            Ws.Range("I14") = .Cells(i, 11)
            Ws.Range("I15") = .Cells(i, 12)
            Ws.Range("B20") = .Cells(i, 13)
            Ws.Range("G23") = .Cells(i, 14)
            Ws.Range("B43") = .Cells(i, 15)
            Ws.Range("I52") = .Cells(i, 18)
            Ws.Range("D52") = .Cells(i, 19)
            Ws.Range("C64") = .Cells(i, 23)
            Ws.Range("C66") = .Cells(i, 24)
            Ws.Range("C68") = .Cells(i, 25)
        End If
    Next i
End With
End Sub
 
Private Function FeuilleExiste(ByVal F As String) As Boolean
 
On Error Resume Next
FeuilleExiste = Worksheets(F).Index
End Function

24/11/2016, 18h49
MoristO

Merci de ton aide !

j'ai eu un message d'erreur ''' If FeuillExiste(Feuil) Then ''' quand j'exécute le programme

Sinon quand tu dis (tu insères le nom complet de chaque image) tu parles de quel nom complet d'image ?

Merci d'avance
24/11/2016, 18h59
mercatog

J'ai changé ta fonction FeuilleExiste, regarde bien

Pour ta question, je veux dire nom + chemin complet des images

PS. pas la peine de coter les réponses
25/11/2016, 11h10
MoristO

Merci ,je n'ai pas fait attention j'ai copié que la premier partie du code.

Sinon dans mon export je n'ai pas le chemin complet, les images sont dans le fichier ,elles ne sont pas stockées dans mon Ordinateur.(fichier joint dans mon premier message )

Merci d'avance et Forza OCK !

Voilà, pas besoin d'activeX image

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
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Sub creation_fiche()
Dim DerLigne As Long, i As Long
Dim Ws As Worksheet
Dim Feuil As String
Dim Shp As Shape
 
Application.ScreenUpdating = False
With Worksheets("Liste")
    DerLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
    For i = 6 To DerLigne
        Feuil = " Candidat " & .Cells(i, 1)
        If Feuil <> "" Then
            If FeuilleExiste(Feuil) Then
                Set Ws = Worksheets(Feuil)
                For Each Shp In Ws.Shapes
                    Shp.Delete
                Next Shp
            Else
                Worksheets("Fiche candidat").Copy after:=Worksheets(Worksheets.Count)
                Set Ws = ActiveSheet
                Ws.Name = Feuil
            End If
 
            Ws.Range("K1") = .Cells(i, 1)
            Ws.Range("C7") = .Cells(i, 2)
            Ws.Range("C7") = .Cells(i, 3)
            Ws.Range("C8") = .Cells(i, 4)
            Ws.Range("I2") = .Cells(i, 5)
            Ws.Range("D2") = .Cells(i, 6)
            Ws.Range("C13") = .Cells(i, 7)
            Ws.Range("C14") = .Cells(i, 8)
            Ws.Range("C15") = .Cells(i, 9)
            Ws.Range("I13") = .Cells(i, 10)
            Ws.Range("I14") = .Cells(i, 11)
            Ws.Range("I15") = .Cells(i, 12)
            Ws.Range("B20") = .Cells(i, 13)
            Ws.Range("G23") = .Cells(i, 14)
            Ws.Range("B43") = .Cells(i, 15)
            Ws.Range("I52") = .Cells(i, 18)
            Ws.Range("D52") = .Cells(i, 19)
            Ws.Range("C64") = .Cells(i, 23)
            Ws.Range("C66") = .Cells(i, 24)
            Ws.Range("C68") = .Cells(i, 25)
            CopyImage .Cells(i, 16), Ws.Range("B28")
            CopyImage .Cells(i, 17), Ws.Range("H28")
        End If
    Next i
End With
End Sub
 
Private Function FeuilleExiste(ByVal F As String) As Boolean
 
On Error Resume Next
FeuilleExiste = Worksheets(F).Index
End Function
 
 
Private Sub CopyImage(ByVal Img As String, ByVal Rng As Range)
 
On Error GoTo Fin
Worksheets("Liste").Shapes(Img).Copy
Rng.PasteSpecial
 
With Rng.Worksheet
    With .Shapes(.Shapes.Count)
        .Left = Rng.Left
        .Top = Rng.Top
        .Width = 4 * Rng.Width
        .Height = 11 * Rng.Height
    End With
End With
Fin:
End Sub

25/11/2016, 12h28
joe.levrai
Bonjour,

rien à voir avec la tambouille réelle de la discussion, mais ceci est-il normal ?
Code:

1 2 Ws.Range("C7") = .Cells(i, 2) Ws.Range("C7") = .Cells(i, 3)
25/11/2016, 12h36
mercatog

Joe la réponse est non ce n'est pas normal ;)
25/11/2016, 14h05
MoristO

Merci beaucoup mercatog ! ca marche à merveille.

MoristO

Remplace la sub CopyImage par celle ci (pour éviter le 4 et le 11 multiplicateurs)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Private Sub CopyImage(ByVal Img As String, ByVal Rng As Range)
 
On Error GoTo Fin
Worksheets("Liste").Shapes(Img).Copy
Rng.PasteSpecial
 
With Rng.Worksheet
    With .Shapes(.Shapes.Count)
        .Left = Rng.Left
        .Top = Rng.Top
        .Width = Rng.MergeArea.Width
        .Height = Rng.MergeArea.Height
    End With
End With
Fin:
End Sub

19/02/2017, 20h12
MoristO

Copier Coller un export avec des photos en VBA

Merci à vous tous !