génération de QR Code

Version imprimable

1 pièce(s) jointe(s)

Bonjour à tous,

J'ai trouvé sur différent forum comment généré un QR Code et ca fonctionne plutot pas mal.
Voici le code que j'utilise
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 Sub setQR(Rg1 As String, qr As String) 'Updated by Extendoffice 2018/8/22 Dim xSRg As Range Dim xRRg As Range Dim xObjOLE As OLEObject On Error Resume Next 'Set xSRg = Range(Rg1) 'Set xSRg = Application.InputBox("Please select the cell you will create QR code based on", "Kutools for Excel", , , , , , 8) 'If xSRg Is Nothing Then Exit Sub 'Set xRRg = Application.InputBox("Select a cell to place the QR code", "Kutools for Excel", , , , , , 8) 'If xRRg Is Nothing Then Exit Sub Set xRRg = Range(Rg1) Application.ScreenUpdating = False Set xObjOLE = ActiveSheet.OLEObjects.Add("BARCODE.BarCodeCtrl.1") xObjOLE.Object.Style = 11 xObjOLE.Object.Value = qr ActiveSheet.Shapes.Item(xObjOLE.Name).Copy ActiveSheet.Paste xRRg xObjOLE.Delete Application.ScreenUpdating = True End Sub
Jutilse cette fonction avec comme paramètre le range (variable Rg1) où je souhaite que mon QR code commence ainsi que le texte que contient mon QR Code (variable qr)

En fait, lorsqu'une cellule de l'excel change, ca appelle la fonction et met à jour mon qr code

Par contre au niveau de l'affichage ca fait un truc bizarre. Lorsque je me modifie successivement mes cellules le QR code se modifie mais ne remplace pas l'ancien. Et pire, il ne met pas par dessus mais en décallé (voir image ci dessous)
Pièce jointe 640127

En plus de cela, je n'ai pas du tout accès au QR code pour le déplacer ou le supprimer

Sauriez vous résoudre mon problème ?

Par avance merci

Cdlt

Marsup

15/06/2023, 19h04
binarygirl

A tout hasard:
C'est sûr que Application.ScreenUpdating = True est toujours exécuté ?
Ça me dérange un peu de voir On Error Resume Next car ça revient à masquer les erreurs. Pour débugger, je conseillerais de faire sauter cette ligne.

1 pièce(s) jointe(s)

Hello,
A noter qu'en utilisant l' API google chart on peut générer son QRCode par cette API ( voir ici)
Code à mettre dans un module VBA :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
#If VBA7 Then
    Public Declare Function URLDownloadToFile Lib "urlmon" _
                             Alias "URLDownloadToFileA" ( _
                             ByVal pCaller As LongPtr, _
                             ByVal szURL As String, _
                             ByVal szFileName As String, _
                             ByVal dwReserved As LongPtr, _
                             ByVal lpfnCB As LongPtr) _
                             As Long
#Else
    Public Declare Function URLDownloadToFile Lib "urlmon" _
                             Alias "URLDownloadToFileA" ( _
                             ByVal pCaller As Long, _
                             ByVal szURL As String, _
                             ByVal szFileName As String, _
                             ByVal dwReserved As Long, _
                             ByVal lpfnCB As Long) _
                             As Long
#End If

Code à mettre dans le VBA de la feuille où l'on affiche le QRCode dans un activeX Image ( le code ici fonctionne sur changement de sélection) :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Target.Value = "" Then
    Dim ret As Long
    Dim strURL As String
    Dim strFile As String
    strURL = "https://chart.googleapis.com/chart?chs=250x250&cht=qr&chof=gif&chl=" & Target.Value
    strFile = "D:\Temp\qrcode.gif"
    ret = URLDownloadToFile(0, strURL, strFile, 0, 0)
    If ret Then
        MsgBox "Failed to download image", vbExclamation
        Exit Sub
    End If
    Image1.Picture = LoadPicture(strFile)
    Kill strFile
End If
End Sub

Pièce jointe 640165

Les avantages :
Cela permet de ne pas utiliser d'activex externe
Les inconvénients:
Nécessite une liaison internet permanente.
Il peut y avoir des temps de latence dans l'obtention du QRCode.
Dépend de l'API google chart qui peut changer de statut ou disparaitre.
Statut actuel :

Citation:

Les outils de création de graphiques Google sont performants, simples à utiliser et offerts.

Ami calmant, J.P

16/06/2023, 09h48
marsupilami34

Bonjour et merci à tous pour votre aide.

Au final j'ai créer l'objet QR code dans lequel je viens changer sa valeur lors d'un changement de cellule.
Comme ca, je n'ai pas a créer systématique un nouvel objet

Cdlt

probleme code VBA

bonjour j'ai un petit probleme avec le code, message "doit être mis à jour pour compatibilité avec systèmes 64 bits, ... mettez à jour les instructions declare puis marquez les avec l'attribut PtrSafe", mais je ne sais pas comment faire, je n'ai pas pu tester la routine selectionchange du coup

merci de m'aider :D

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
#If VBA7 Then
    Public Declare Function URLDownloadToFile Lib "urlmon" _
                             Alias "URLDownloadToFileA" ( _
                             ByVal pCaller As LongPtr, _
                             ByVal szURL As String, _
                             ByVal szFileName As String, _
                             ByVal dwReserved As LongPtr, _
                             ByVal lpfnCB As LongPtr) _
                             As Long
#Else
    Public Declare Function URLDownloadToFile Lib "urlmon" _
                             Alias "URLDownloadToFileA" ( _
                             ByVal pCaller As Long, _
                             ByVal szURL As String, _
                             ByVal szFileName As String, _
                             ByVal dwReserved As Long, _
                             ByVal lpfnCB As Long) _
                             As Long
#End If

Ami calmant, J.P[/QUOTE]

Hello,
A essayer :

Code:

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
#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" ( _
        ByVal pCaller As LongPtr, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As LongPtr _
      ) As Long
    Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
      Alias "DeleteUrlCacheEntryA" ( _
        ByVal lpszUrlName As String _
      ) As Long
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" ( _
        ByVal pCaller As Long, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As Long _
      ) As Long
    Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
      Alias "DeleteUrlCacheEntryA" ( _
        ByVal lpszUrlName As String _
      ) As Long
#End If

Ami calmant, J.P

13/11/2023, 20h33
jakboregar

encore un souci, désolé

C'est mieux, merci beaucoup, mais maintenant dans la routine de la feuille j'ai le message "sub ou fonction n'existe pas" pour ret = URLDownloadToFile(0, strURL, strFile, 0, 0)

j'ai bien copié les déclarations dans un module, pas de signalement d'erreur

ça risque d'être pareil pour deletecache

Hello,
oops :oops: , il faut mettre les routines en Public et pas en Private sinon on ne les voit que dans le module où elles sont :

Code:

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
#If VBA7 Then
    Public Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" ( _
        ByVal pCaller As LongPtr, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As LongPtr _
      ) As Long
    Public Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
      Alias "DeleteUrlCacheEntryA" ( _
        ByVal lpszUrlName As String _
      ) As Long
#Else
    Public Declare Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" ( _
        ByVal pCaller As Long, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As Long _
      ) As Long
    Public Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
      Alias "DeleteUrlCacheEntryA" ( _
        ByVal lpszUrlName As String _
      ) As Long
#End If

Ami calmant, J.P

14/11/2023, 11h53
jakboregar

objet image1

super merci, j'aurai dû y penser
comme je ne suis pas cador VBA j'ai encore un souci avec image1.picture = (...) message objet requis
j'ai essayé de nommer une cellule "image1", ou de placer une image appelée image1, sans succès
désolé du dérangement
gilles
14/11/2023, 15h54
jurassic pork

Citation:

Envoyé par jakboregar

comme je ne suis pas cador VBA j'ai encore un souci avec image1.picture = (...) message objet requis
j'ai essayé de nommer une cellule "image1", ou de placer une image appelée image1, sans succès
désolé du dérangement
gilles

Il faut insérer un contrôle ActiveX Image dans sa feuille :
Développeur/Mode Création
Développeur/Insérer/Contrôle Activex/Image
Si c'est le premier contrôle ActiveX Image inséré dans la feuille il s'appellera image1
17/11/2023, 18h05
jakboregar

ça marche

Citation:

Envoyé par jurassic pork

Il faut insérer un contrôle ActiveX Image dans sa feuille :
Développeur/Mode Création
Développeur/Insérer/Contrôle Activex/Image
Si c'est le premier contrôle ActiveX Image inséré dans la feuille il s'appellera image1

super merci
j'ai paramétré autosize ! comme ça plus d'image tronquée
j'ai créé une image blanche pour effacer le QRcode si besoin, mais il y apeut être un autre moyen
en tous cas merci bien du temps consacré à mes questions

Citation:

Envoyé par jurassic pork

Hello,
oops :oops: , il faut mettre les routines en Public et pas en Private sinon on ne les voit que dans le module où elles sont :

Code:

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
#If VBA7 Then
    Public Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" ( _
        ByVal pCaller As LongPtr, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As LongPtr _
      ) As Long
    Public Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
      Alias "DeleteUrlCacheEntryA" ( _
        ByVal lpszUrlName As String _
      ) As Long
#Else
    Public Declare Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" ( _
        ByVal pCaller As Long, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As Long _
      ) As Long
    Public Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
      Alias "DeleteUrlCacheEntryA" ( _
        ByVal lpszUrlName As String _
      ) As Long
#End If

Ami calmant, J.P

Bonjour à tous,

Je me permets de revenir sur cette discussion, car j'ai essayé ce générer un qr code avec cette méthode.

Le souci c'est que quand je veux ouvrir l'image j'ai l'erreur suivant: "il semble que nous ne prenions pas en charge ce type de fichier".

Quelqu'un saurait pourquoi ?

Merci d'avance

Marsup