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

Orson83 · 23 Novembre 2022

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.

fanch55 · 23 Novembre 2022

Salut,
Classeur à tester

Orson83 · 23 Novembre 2022

fanch55 à dit:
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

riton00 · 23 Novembre 2022

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 · 23 Novembre 2022

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 · 23 Novembre 2022

fanch55 à dit:

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).

fanch55 · 23 Novembre 2022

Orson83 à dit:
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 · 23 Novembre 2022

fanch55 à dit:

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 · 23 Novembre 2022

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 · 23 Novembre 2022

fanch55 à dit:

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😉

Effectuez une recherche sur Excel Downloads...

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

Orson83

XLDnaute Impliqué

Pièces jointes

fanch55

fanch55

XLDnaute Barbatruc

Pièces jointes

Orson83

XLDnaute Impliqué

riton00

XLDnaute Impliqué

fanch55

XLDnaute Barbatruc

Orson83

XLDnaute Impliqué

fanch55

XLDnaute Barbatruc

Orson83

XLDnaute Impliqué

fanch55

XLDnaute Barbatruc

Orson83

XLDnaute Impliqué

Discussions similaires

Nous accordons de l'importance à votre vie privée