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 |
