XL 2010 Générer plusieurs QR Codes avec bouton

Orson83

XLDnaute Impliqué
Bonjour le forum,
Ce post fait suite au thread QR Code dans cellule qui permet de générer un seul QR Code avec la touche ENTER.
Pour aller plus loin, j'aimerai pouvoir générer plusieurs QR Codes avec un seul bouton sur la base du travail déjà effectué par @Sequoyah (merci à lui).
Cela est-il possible ?
Je joins un modèle à finaliser dans ce post.
Merci à vous.
 

Pièces jointes

  • Modèle_QRCode-V1.xlsm
    26.9 KB · Affichages: 20
Solution
Code complet:
VB:
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...

Orson83

XLDnaute Impliqué
Salut,
Classeur à tester
Bonsoir fanch55, le forum,
Merci fanch55 pour cette proposition qui fonctionne très bien 👍
J'ai voulu ajouter un code pour effacer les urls et les images QR Codes mais il semblerait que mon code ci-dessous ne soit pas adapté :
VB:
Sub Btn_efface()
Range("D3:D12").ClearContents
Sheets("feuil1").Range("D3:D12").DrawingObjects.Delete
End Sub
Pouvez-vous le corriger SVP ?

Voici le code de Boisgontier qui permet de ne pas effacer les boutons
Code:
Sub EffaceShapesSaufBoutons()
   For Each i In ActiveSheet.Shapes
     If i.Type <> 8 And i.Type <> 12 Then
       ActiveSheet.Shapes(i.Name).Delete
     End If
   Next i
End Sub
 
Dernière édition:

riton00

XLDnaute Impliqué
Bonjour,

Peut-être un truc comme ça

VB:
Sub EffaceQRcode()
Dim img As Object
Range("D3:D12").ClearContents
Sheets("feuil1").Range("D3:D12").Hyperlinks.Delete
For Each img In ActiveSheet.Shapes
    If img.Type = 13 Then img.Delete
Next
End Sub

Slts
 

fanch55

XLDnaute Barbatruc
Re,
Dans votre cas, le plus simple :
VB:
Sub Btn_efface()
Dim Shp As Shape
    Range("D3:" & Range("D" & Rows.Count).End(xlUp).Address).ClearContents
    For Each Shp In ActiveSheet.Shapes
        If Shp.Name Like "QRCode_*" Then Shp.Delete
    Next
End Sub
 

Orson83

XLDnaute Impliqué
Re,
Dans votre cas, le plus simple :
VB:
Sub Btn_efface()
Dim Shp As Shape
    Range("D3:" & Range("D" & Rows.Count).End(xlUp).Address).ClearContents
    For Each Shp In ActiveSheet.Shapes
        If Shp.Name Like "QRCode_*" Then Shp.Delete
    Next
End Sub
Oups ! Petit soucis.
La cellule D2 génère un QR Code et le bouton efface toute la colonne D (y compris le titre).
Idéalement, il ne faudrait pas traiter les lignes 1 & 2 (ou cellules D1 &D2).
 
Dernière édition:

fanch55

XLDnaute Barbatruc
Oups ! Petit soucis.
La cellule D2 génère un QR Code et le bouton efface toute la colonne D (y compris le titre).
Idéalement, il ne faudrait pas traiter les lignes 1 & 2 (ou cellules D1 &D2).
Ok, pas prévu d'exécuter le code plusieurs fois, autant pour moi.
Corrigé:

VB:
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
 

Orson83

XLDnaute Impliqué
Ok, pas prévu d'exécuter le code plusieurs fois, autant pour moi.
Corrigé:

VB:
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
Merci.
Le titre en D2 génère toujours un QR Code, bizarre.
Je pense que cela vient du code qui génère les QR Codes :
VB:
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
Il manquerai le :
Code:
  If Plage.Row > 2
 

fanch55

XLDnaute Barbatruc
Code complet:
VB:
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
 

Orson83

XLDnaute Impliqué
Code complet:
VB:
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
Merci fanch55 👍
Je m'aperçois que finalement le bouton "Générer" se sert à rien car l'image QR est générée dès lors qu'on change de cellule.
Mais ça fera très bien l'affaire.
Très bonne soirée;)
 

Discussions similaires

Statistiques des forums

Discussions
313 243
Messages
2 096 509
Membres
106 644
dernier inscrit
7frd5