Discussion :

[chevrotine56]

Bonjour à tous,

J'ai un fichier qui genère des QRCodes (un par case)
Je voudrais enregistrer ce QR code comme image dans le dossier de mon fichier.

J'utilise le code suivant pour créer un graph et enregistrer ce graph en image.
mais je n'arrive pas a mettre le graphe derrière le QRCode;

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub enrgQR()
 
Dim derlig As Integer
Dim I As Integer
Dim QRname As String
Dim Plage As Range
 
   derlig = Cells(Rows.Count, 2).End(xlUp).Row
 
   For I = 6 To derlig
    QRname = Replace(Cells(I, 2).Value, Chr(10), "_")
    'Copie, en tant qu'image, les cellulesZ1
 
    Set Plage = Sheets("Feuil1").Range("C" & I)
    Plage.CopyPicture
    Feuil1.Paste
    'Crée un graphique temporaire
        With Feuil1.ChartObjects.Add(Plage.Left, Plage.Top, Plage.Width, Plage.Height).Chart
            .Paste
            'exporte l'image sur le disque dur, dans le même répertoire que ce classeur.
            .Export ThisWorkbook.Path & "\" & QRname & ".jpg", "JPG"
        End With
        With Feuil1
            'Supprime le graphique temporaire
            .ChartObjects(Feuil1.ChartObjects.Count).Delete
            'Supprime l'image dans la feuille.
            .Shapes(Feuil1.Shapes.Count).Delete
        End With
   Next
 
 
End Sub

Est ce que quelqu'un a une idée?

Merci

[Invité]

Bonjour,

A tester et à adapter :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
 
Sub Enregistrement_QRCode()
 
Dim I As Integer, DerLig As Integer, NbShapesDebut As Integer, NbShapesFin As Integer
Dim QRname As String
Dim ShChObj As ChartObject
Dim ShEnCours As Worksheet
 
    Application.ScreenUpdating = False
    Set ShEnCours = Sheets("Feuil1")
    With ShEnCours
 
         If .Shapes.Count = 0 Then
            NbShapesDebut = 1
         Else
            NbShapesDebut = .Shapes.Count
         End If
 
         DerLig = .Cells(.Rows.Count, 2).End(xlUp).Row
 
         For I = 6 To DerLig
             ' QRname = Replace(Cells(I, 2).Value, Chr(10), "_")
             QRname = .Range("B" & I)
             .Range("C" & I).CopyPicture
             DoEvents
             ShEnCours.Paste
             Selection.Name = QRname
             Application.CutCopyMode = False
         Next I
 
         NbShapesFin = .Shapes.Count
 
         For I = NbShapesDebut To NbShapesFin
             With .Shapes(I)
                  Set ShChObj = ShEnCours.ChartObjects.Add(.Left, .Top, .Width, .Height)
                  .Copy
                  QRname = .Name
                  With ShChObj
                       .Activate
                       .Chart.Paste
                       .Chart.Export ThisWorkbook.Path & "\" & QRname & ".jpg"
                       .Delete
                  End With
                  Application.CutCopyMode = False
                  Set ShChObj = Nothing
             End With
        Next I
 
        For I = NbShapesFin To NbShapesDebut Step -1
            .Shapes(I).Delete
        Next I
 
    End With
 
    Set ShEnCours = Nothing
 
    Application.ScreenUpdating = True
 
End Sub

[chevrotine56]

Bonjour,

Ca resoud une partie du problème, mais l'export fonctionne pas. y a un soucis avec le type d'objet.

Pièce jointe 548624

[Invité]

Bonjour,

Il n'y a rien dans les cellules de la colonne C, c'est normal ?
Pièce jointe 548639

[chevrotine56]

Bonjour,

Au debut il n'y a rien dans la colonne C, c'est là ou sont mis les QR code.

[Invité]

Bonjour,

A tester. Le problème vient du nom dans les cellules de la colonne B : Il ne faut pas de retour chariot dans le nom.

Il est possible que le code d'origine fonctionne. J'ai changé le code pour créer des shapes dans lesquelles j'importe l'image.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
 
Option Explicit
 
Public NbImages As Integer
 
Sub ToutReprendre()
 
Dim ShQrCode As Worksheet
Dim rPlage As Range, rCell As Range
Dim I As Integer, DerLig As Integer
 
    Application.ScreenUpdating = False
 
    Set ShQrCode = Sheets("Feuil1")
    With ShQrCode
 
         DerLig = .Cells(.Rows.Count, 2).End(xlUp).Row
         Set rPlage = .Range("B6:B" & DerLig)         '--- plage à traiter
 
         For Each rCell In rPlage
             QRCODE2 ShQrCode, rCell.Row
         Next
 
         EnrgQR ShQrCode
 
         For I = .Shapes.Count To 1 Step -1
             If Mid(.Shapes(I).Name, 1, 5) = "QR_PP" Then .Shapes(I).Delete
         Next
 
    End With
 
    Application.ScreenUpdating = True
 
    MsgBox NbImages - 1 & " QR codes créés !", vbInformation
 
    Set rPlage = Nothing
    Set ShQrCode = Nothing
 
 
End Sub
 
 
 
Sub QRCODE2(ByVal ShQrCode2 As Worksheet, ByVal kr As Long)
 
Dim sID As String, sLink As String
Dim MaShape As shape
Dim PosGauche As Double, PosHaut As Double, Largeur As Double, Hauteur As Double
 
   With ShQrCode2
 
        If .Cells(kr, 2) = "" Then Exit Sub
 
        sID = "QR_" & .Cells(kr, 2)
        With .Cells(kr, 3)
             .Activate
             PosGauche = .Left
             PosHaut = .Top
             Largeur = .Width
             Hauteur = .Height
        End With
 
        Set MaShape = .Shapes.AddShape(msoShapeRectangle, PosGauche, PosHaut, Largeur, Hauteur)
        With MaShape
             .Fill.UserPicture "http://chart.googleapis.com/chart?cht=qr&chs=400x400&chl=" & sID
             .Name = sID
             .Line.Visible = msoFalse
             .IncrementRotation -45
             .ZOrder msoBringToFront
        End With
        Set MaShape = Nothing
 
        .Cells(kr + 1, 2).Activate
 
   End With
 
End Sub
 
Sub EnrgQR(ByVal ShQrCode2 As Worksheet)
 
Dim I As Integer, DerLig As Integer
Dim QRname As String
Dim ShChObj As ChartObject
Dim PositionGauche As Double
 
    With ShQrCode2
 
         If .ChartObjects.Count > 0 Then
             For I = .ChartObjects.Count To 1 Step -1
                 .ChartObjects(I).Delete
             Next I
         End If
 
         PositionGauche = .Range("H1").Left
         If .Shapes.Count = 0 Then Exit Sub
 
         NbImages = 1
         For I = .Shapes.Count To 1 Step -1
             With .Shapes(I)
 
                  If Mid(.Name, 1, 5) = "QR_PP" Then
 
                     .Copy
                     QRname = .Name
 
                     Set ShChObj = ShQrCode2.ChartObjects.Add(PositionGauche, .Top, .Width, .Height)
                     With ShChObj
                          .Select
                          .Chart.Paste
                          .ShapeRange.Line.Visible = msoFalse
                          .Chart.Export ThisWorkbook.Path & "\" & QRname & ".jpg", "JPG"
                          NbImages = NbImages + 1
                          .Delete
                     End With
                     Application.CutCopyMode = False
                     Set ShChObj = Nothing
                     .Delete
 
                  End If
             End With
        Next I
 
    End With
 
End Sub