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

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
Orson83

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

Solution
fanch55
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...
Trier par date Trier par votes
fanch55 à dit:
Salut,
Classeur à tester
Cliquez pour agrandir...
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:
Vote positif 0 Vote négatif
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
 
Vote positif 0 Vote négatif
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
Cliquez pour agrandir...
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:
Vote positif 0 Vote négatif
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).
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
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
 
Vote positif 0 Vote négatif
Solution
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
Cliquez pour agrandir...
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😉
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

J
  • Résolu(e)
XL 2021 génération de QR code
Réponses
4
Affichages
916
JPaul78
J
P
  • Question Question
XL 2021 Création cartes de membres sous qr code avec excel
Réponses
2
Affichages
335
philmyl04
P
C
  • Résolu(e)
XL 2021 Inventaire automatique
Réponses
14
Affichages
799
Constantin
C
@
  • Question Question
XL pour MAC QR code et incrémentation Excel sur plusieurs étapes
Réponses
0
Affichages
683
@rnaud
@
M
  • Question Question
XL 2021 Créer un bouton pour générer une nouvelle ligne
2
Réponses
19
Affichages
253
mostefa mokhtar
M
C
  • Question Question
XL 2016 suivi de matériel (entrées / sorties entre autres), QR code et fonctionnement
Réponses
2
Affichages
1 K
sylvanu
sylvanu
gsx-air
  • Résolu(e)
Microsoft 365 Traiter un fichier CSV qui est ouvert
2
Réponses
16
Affichages
170
gsx-air
gsx-air
A
  • Question Question
XL 2010 Problème pour Générer plusieurs PDf en VBA
Réponses
5
Affichages
500
cp4
cp4
R
  • Question Question
Microsoft 365 Fusionner plusieurs onglets d'un classeur XLSX
Réponses
9
Affichages
340
Roran2024
R
F
  • Question Question
XL 2016 Générer un rapport pdf depuis excel
2
Réponses
22
Affichages
2 K
fraux
F
M
  • Question Question
Microsoft 365 Analyse de données, copie conditionnée
Réponses
7
Affichages
515
Max
M
M
  • Question Question
Microsoft 365 Comptabilité : Création d'un fichier automatique d'analyse de comptes
Réponses
2
Affichages
589
Max
M
A
  • Question Question
XL 2010 Dupliquer une plage plusieurs fois et imprimer
Réponses
12
Affichages
503
patricktoulon
patricktoulon
D
  • Question Question
Microsoft 365 Tableau gestion ticket restau
Réponses
3
Affichages
317
yoyo2018
Y
N
  • Résolu(e)
Microsoft 365 Aide pour insertion nombre aléatoire
2
Réponses
22
Affichages
841
NONO14
N
stefdenam
  • Question Question
Microsoft 365 Générer un QR Code EPC pour Facture en Excel
2
Réponses
22
Affichages
4 K
MaxDurand
M
A
  • Question Question
XL 2021 Générer des données à partir d'une ligne spécifique jusqu'à une autre
Réponses
5
Affichages
457
gbinforme
G
S
  • Résolu(e)
Microsoft 365 Envoi de la signature de l'utilisateur macro envoi de mail
Réponses
3
Affichages
269
spike29
S
D
  • Résolu(e)
Microsoft 365 Problème interférences entre macros
Réponses
14
Affichages
151
Phil69970
Phil69970
mromain
Génération de QR Codes
Réponses
1
Affichages
837
Cousinhub
Cousinhub
Retour