Discussion :

[amandon]

J'ai un souci pour crée des qrcode pour une liste d'identifiant

je vous explique pour l'instant j'ai un document ou il y a entre autre 2 colonne : la premiere avec l'identifiant et la seconde avec les codes correspondant à la premiere en forme de police

Voila j'aimerai remplacer les codes barres par les QRcodes pour des raisons pratiques.

J'ai réussi à créer en VBA pour creer un qr code pour la premiere cellule de ma liste mais pas pour les autres

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
 
Sub QR()
Dim Link As String
 
Link = "http://chart.googleapis.com/chart?cht=qr&chs=145x135&chl=" & ActiveSheet.Range("B3").Value
 
Worksheets("Feuil1").Range("C3").Activate
Worksheets("Feuil1").Pictures.Insert (Link)
End Sub

aprés j'aimerai adapter la taille du qrcode généré

et j'aimerai de plus que ça soit généré automatiquement quand quelque chose est écris dans la colonne 1.

[EricDgn]

Bonjour,

Une façon de faire.
Dans la Feuil1 insérer ce code:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Worksheet_Change(ByVal Target As Range)
   '--- mise à jour sur changement de l'id en colonne 1
   If Target.Column = 1 Then
      QR Target.Row
   End If
End Sub
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   '--- mise à jour sur double-clic de l'id en colonne 1
   If Target.Column = 1 Then
      QR Target.Row
   End If
End Sub

et dans un module, celui-ci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub QR(kr As Long)
   Dim sID As String, sLink As String, sPict As Object
   With ActiveSheet
      sID = .Cells(kr, 1)
      sLink = "http://chart.googleapis.com/chart?cht=qr&chs=145x135&chl=" & sID
      .Cells(kr, 3).Activate
      Set sPict = .Pictures.Insert(sLink)
      With sPict
         .Name = "QR_" & sID
         .Width = 60
         .Height = 60
      End With
      .Cells(kr + 1, 1).Activate
      Set sPict = Nothing
   End With
End Sub

Vu qu'il faut un certain temps pour que l'image du QR code se charge, il n'est pas simple de faire une mise à jour de tous les QR code en une fois. Il est plus simple de le faire pièce à pièce à l'aide du double-clic.
Il n'est pas vérifié qu'il n'y a pas de doublon au niveau des id.
Attention: vu que les images ne sont pas transparentes, certaines peuvent se superposer sans que cela soit visible!
Le code ci-dessus ne s'est pas occupé de supprimer l'image éventuellement déjà déposée (et peut donc provoquer des superpositions).

Bonne continuation.

[amandon]

J'ai essayé mais ça n'a pas l'air de fonctionner mais je pense qui'il beug. je vous joint le fichier.
je pense que techniquement il serait plus simple d'avoir un bouton pour actualiser les QRCODE plutot que de double cliquer sur les cases.

je vous remercie d'avance

[EricDgn]

Oui, cela ne fonctionne pas vu que les textes des codes étaient censés se trouver en colonne 1.
Une version améliorée, avec les codes inscrits en colonne 2, et qui supprime les QRcodes qui sont "modifiés" dans une cellule.
Il y a du code VBA à la fois dans un module et dans la feuille Feuil1.

Dans le module;

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Option Explicit
 
Public sQR As String '--- pour conserver valeur code avant sa modification
 
Sub QR_LigneActive()
   QRCODE ActiveCell.Row
End Sub
 
Sub QRCODE(kr As Long)
   Dim sID As String, sLink As String, sPict As Object
   With ActiveSheet
      sID = .Cells(kr, 2)        '--- 2 = colonne où se trouve le texte à traiter
      If sID = "" Then Exit Sub  '=== EXIT SUB ===
      SupprimerQR "QR_" & sID
      sLink = "http://chart.googleapis.com/chart?cht=qr&chs=145x135&chl=" & sID
      .Cells(kr, 3).Activate
      Set sPict = .Pictures.Insert(sLink)
      With sPict
         .Name = "QR_" & sID
         '--- change la taille
         .Width = 60
         .Height = 60
         '--- change la position
         .Left = .Left + 5
         .Top = .Top + 5
         '--- pour info
         Debug.Print .Name & " ajouté", , .Left, .Top
      End With
      .Cells(kr + 1, 2).Activate
      Set sPict = Nothing
   End With
End Sub
 
Sub ListerShapes()
   Dim shape As Excel.shape
   For Each shape In ActiveSheet.Shapes
      Debug.Print shape.ID, shape.Name
   Next
End Sub
 
Sub SupprimerQR(sCode As String)
   '--- supprime image ayant le même nom,
   '--- mais ne supprime pas image qui se trouverait à la même place avec un autre nom
   '--- chose qui se produit lorsque l'on change le texte du code dans la cellule
   '--- => utiliser Worksheet_SelectionChange() pour détecter le code avant modification
   Dim shape As Excel.shape
   For Each shape In ActiveSheet.Shapes
      If shape.Name = sCode Then
         Debug.Print sCode & " supprimé ID:"; shape.ID
         shape.Delete
      End If
   Next
End Sub

Dans la feuille Feuil1:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
   '--- mise à jour sur changement de l'id en colonne 2
   If Target.Column = 2 Then
      SupprimerQR "QR_" & sQR
      QRCODE Target.Row
   End If
End Sub
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   '--- mise à jour sur double-clic de l'id en colonne 2
   If Target.Column = 2 Then
      QRCODE Target.Row
   End If
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   sQR = Target.Value   '--- récupère la valeur du code avant sa modification
End Sub

Bonne continuation.

[amandon]

Super merci beaucoup

il y a un petit soucis d'erreur d'exécution 13 quand je selectionne plusieurs case c'est pas bloquant mais pénible

et pour le bouton est ce possible qu'il actualise toute les cases sachant que dans la colonne 2 ça n'ira pas plus loin que 25 N°DEFGEN.


Bonne soirée

Cordialement

[EricDgn]

Pour le problème de la sélection multiple:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   sQR = Target.Cells(1, 1).Value  '--- récupère la valeur du code avant sa modification
End Sub

mais cela fera une mise à jour uniquement pour la cellule qui se trouve dans le coin supérieur gauche de la plage sélectionnée (et pas pour toute la plage sélectionnée).

Pour faire une mise à jour de tous les codes inscrits dans la plage B6:B30 (soit 25 valeurs)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Sub ToutReprendre()
   Dim rPlage As Range, rCell As Range
   Set rPlage = Range("B6:B30")           '--- plage à traiter
   For Each rCell In rPlage
      QRCODE rCell.Row
      DoEvents
   Next
End Sub

mais il est possible qu'Excel se bloque si la connexion internet est lente.

Bonne continuation.