Sub Btn_efface()
Dim Shp As Shape, Plage As Range
Set Plage = Range("D" & Rows.Count).End(xlUp)
If Plage.Row > 2 Then Range("D3:" & Plage.Address).ClearContents
For Each Shp In ActiveSheet.Shapes
If Shp.Name Like "QRCode_*" Then Shp.Delete
Next
End Sub
Public Sub Btn_Generer()
Dim Plage As Range
Set Plage = Range("D3:" & Range("D" & Rows.Count).End(xlUp).Address)
Plage.Value = Plage.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Plage As Range
Application.ScreenUpdating = False
Set Plage = Range("D3:" & Range("D" & Rows.Count).End(xlUp).Address)
If Not Intersect(Target, Plage) Is Nothing Then
For Each T In Target
If T.Row > 2 Then Call QRCodeToCell(T.Value, T.Offset(, 1), 70, 70) ' la taille du QRCode
Next
End If
End Sub
'----------------------------
'Génère un QR code en cellule
'
'Arguments:
'---------
'- Chaine : Chaine à encoder en QR Code
'- Cellule : Cellule où placer l'image du QR Code
'- PicWidth : Largeur de l'image du QR Code
'- PicHeight: Hauteur de l'image du QR Code
'
'- Return : Objet Picture de l'image du QR Code
'----------------------------
Function QRCodeToCell(Chaine As String, _
Cellule As Range, _
Optional PicWidth As Integer = 120, _
Optional PicHeight As Integer = 120) As Picture
Dim Link As String
Dim Pic As Picture
Dim PicName As String
If Chaine <> "" Then
'https://developers.google.com/chart/infographics/docs/qr_codes
Link = "http://chart.googleapis.com/chart?cht=qr&chs=" & PicWidth & "x" & PicHeight & "&chl=" & Chaine
Windows(Cellule.Parent.Parent.Name).Activate
Cellule.Parent.Activate
Cellule.Activate
PicName = "QRCode_" & Cellule.Address(0, 0)
'Supprime une Shape de ce nom éventuellement présente
For Each Pic In ActiveSheet.Pictures
If Pic.Name = PicName Then Pic.Delete
Next Pic
'Génère l'image QR Code
Set QRCodeToCell = ActiveSheet.Pictures.Insert(Link)
With QRCodeToCell
.Top = Cellule.Top + (Cellule.Height - .Height) / 2 'Position en hauteur à adapter
.Left = Cellule.Left + (Cellule.Width - .Width) / 2 'Position en largeur DANS LA CELLULE à adapter
.Name = PicName
End With
End If
End Function