XL 2016 VBA - Impossible d'envoyer l'image du QR Code en fichier

  • Initiateur de la discussion Initiateur de la discussion Dudu2
  • Date de début Date de début

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 !

Dudu2

XLDnaute Barbatruc
Bonjour,

Dans le fichier joint, 2 boutons:

1653765233383.png
Ok, c'est simple, ça marche pas de problème !
1653764982927.png
KO, ça ne marche pas,
1653765044327.png
bien que le code utilisé fonctionne parfaitement pour une image "vraie" !!!

L'image du QR Code en fichier est vide ou non valide, je ne sais pas ???
1653765465425.png
 

Pièces jointes

Dernière édition:
Solution
re
bonjour @Dudu2 , @Phil69970

l'image blanche est due a la lenteur du clipboard sur les versions d'office excel a partir de la version 2016 et plus

une simple gestion d'attente du pictures.count du ch.chart peut parfois régler le problème

VB:
'----------------------------
'Génère un QR code en fichier
'----------------------------
Sub QRCodeToFile(Chaine As String, NomCompletFichier, _
                      Optional PicWidth As Integer = 120, _
                      Optional PicHeight As Integer = 120)
                     
    Dim Ch As ChartObject
    Dim Pic As Picture

    Set Pic = QRCodeToCell(Chaine, ActiveCell, PicWidth, PicHeight)
 
    'Create a Chart on the ActiveSheet
    Set Ch =...
non moi je suis un petit bricoleur qui fait semblant d'etre un grand
😉😆😅😂

pour rester sérieux
avantage methode request/object stream
pas de shape
pas de clipboard
pas de paste vide

c'est du direct request/fichier
c'est vieux comme le monde 😉
 
re
Bonjour j'ai retrouvé la méthode paste sans api et adapté
VB:
'----------------------------
'Génère un QR code en fichier
'----------------------------
Sub QRCodeToFile(Chaine As String, NomCompletFichier, Optional PicWidth As Integer = 120, Optional PicHeight As Integer = 120)
    Dim Ch As ChartObject, Pic As Picture
    Application.CutCopyMode = False    'on vide l'eventuelle image précédamment copiée(pour ne pas recoller la meme)
    DoEvents    'laisse quelques milliemes de seconde au clip pour se vider
    Set Pic = QRCodeToCell(Chaine, ActiveCell, PicWidth, PicHeight): Pic.CopyPicture
    Set Ch = ActiveSheet.ChartObjects.Add(0, 0, Pic.Width, Pic.Height)    'Create a Chart on the ActiveSheet
    With Ch.Chart
        Do While .Pictures.Count = 0: DoEvents: .Paste: Loop    ' on paste tant qu'il y a pas une image dans le chart
          .Export NomCompletFichier, FilterName:=Mid(NomCompletFichier, InStrRev(NomCompletFichier, ".") + 1)
    End With
    Pic.Delete: Ch.Delete    'Delete the image and the Chart
End Sub
 
re
Bonjour @Dudu2
tu a les deux solutions maintenant
pour l'avenir tu le saura (copy image et export par chart)= grosse bouff de mémoire sur 2016 et +
donc gestion d'attente
😉
pour ma part je préfère un do/ loop plutôt qu'un wait ou sleep
le do loop s’ arrête quand il y a une picture dans le chart

et pour eviter une image de mauvais format au cas ou la requête n'aboutie pas
VB:
'----------------------------
'Génère un QR code en fichier
'Code de PatrickToulon
'
'Arguments:
'---------
'- Chaine   : Chaine à encoder en QR Code
'- NomCompletFichier: Nom complet du fichier image du QR Code
'- PicWidth : Largeur de l'image du QR Code
'- PicHeight: Hauteur de l'image du QR Code
'----------------------------
Sub QRCodeToFile(Chaine As String, _
                 NomCompletFichier, _
                 Optional PicWidth As Integer = 120, _
                 Optional PicHeight As Integer = 120)

    Dim Link As String
    Dim ReQ As Object
    Dim oStream As Object

    'https://developers.google.com/chart/infographics/docs/qr_codes
    Link = "http://chart.googleapis.com/chart?cht=qr&chs=" & PicWidth & "x" & PicHeight & "&chl=" & Chaine

    If Len(Dir(NomCompletFichier)) > 0 Then Kill NomCompletFichier
    '
    Set ReQ = CreateObject("Microsoft.XMLHTTP")
    ReQ.Open "get", Link, False
    ReQ.send
    If ReQ.Status <> 200 Then MsgBox "la requete n'a pas abouti": Exit Sub
    '
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write ReQ.responsebody
    oStream.SaveToFile NomCompletFichier
    oStream.Close
End Sub
 
Dernière édition:
- 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

Réponses
32
Affichages
542
Réponses
10
Affichages
411
Retour