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

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

  • Modèle_QRCode-V1.xlsm
    26.9 KB · Affichages: 18
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
Orson83

Orson83

XLDnaute Impliqué
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
riton00

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
 
Vote positif 0 Vote négatif
fanch55

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
 
Vote positif 0 Vote négatif
Orson83

Orson83

XLDnaute Impliqué
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
fanch55

fanch55

XLDnaute Barbatruc
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
Orson83

Orson83

XLDnaute Impliqué
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
fanch55

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
 
Vote positif 0 Vote négatif
Solution
Orson83

Orson83

XLDnaute Impliqué
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

Discussions similaires

M
  • Question
Autres Générer une étiquette pour imprimante thermique
Réponses
3
Affichages
203
fanch55
fanch55
M
  • Question
Microsoft 365 Créer une macro avec bouton "enregistrer une macro"
Réponses
9
Affichages
258
Staple1600
Staple1600
piga25
  • Question
XL 2016 Sauvegarde dès l'ouverture fichier modèle (xltm) en fichier (xlsm ) avec modification code Workbook_Open
Réponses
10
Affichages
97
piga25
piga25
P
  • Question
XL 2016 Affecter à un bouton plusieurs possibilité
Réponses
3
Affichages
337
Eric KERGRESSE
E
Q
  • Question
Microsoft 365 Créer un formulaire pour duplication d'onglet avec tableau
Réponses
6
Affichages
202
job75
job75
D
  • Résolu(e)
Microsoft 365 macro afficher/masquer avec un seul bouton
Réponses
5
Affichages
388
sylvanu
sylvanu
S
  • Question
XL 2016 Générer des codes aléatoires à une liste d'élèves
2
Réponses
21
Affichages
2 K
stuka
S
A
  • Question
Microsoft 365 Incrémentation VBA : Impression automatique adresses client papier autocollant thermique - Excel gestion de commandes - Génération QR codes
Réponses
4
Affichages
978
sylvanu
sylvanu
O
  • Question
Microsoft 365 Créer bouton qui désactiver ou active deux codes qui se trouve dans ThisWorkbook
Réponses
5
Affichages
374
odohe
O
M
  • Question
XL 2016 Extraire plusieurs chaînes de caractères d'une même cellule
Réponses
14
Affichages
385
Mam's
M

Membres actuellement en ligne

17 membres et 111 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 207
Messages
2 086 231
Membres
103 161
dernier inscrit
Rogombe bryan