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

Dudu2 · 28 Mai 2022

Bonjour,

Dans le fichier joint, 2 boutons:

Ok, c'est simple, ça marche pas de problème !

KO, ça ne marche pas,

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 ???

Phil69970 · 28 Mai 2022

Bonjour @Dudu2

Si j'ai compris 🙄
As tu essayé comme cela ?

Et cela donne ==>

@Phil69970

patricktoulon · 29 Mai 2022

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 = ActiveSheet.ChartObjects.Add(0, 0, Pic.Width, Pic.Height)
 
    'Copy / Paste the image into the Chart
    Pic.Copy
    Ch.Activate
     Ch.Chart.Paste
     '----------------------------------------------'
     '----------------------------------------------'
    Do While Ch.Chart.Pictures.Count < 1: Loop
    '----------------------------------------------'
    '----------------------------------------------'
   
    'Force the Width of the image in the Chart otherwise a slight shift might appear in Chart
    Ch.Chart.Shapes(1).Width = Ch.Width
    Ch.Chart.Shapes(1).Height = Ch.Height
'Exit Sub
   
    'Export the Chart to the image file
    Ch.Chart.Export NomCompletFichier, FilterName:=Mid(NomCompletFichier, InStrRev(NomCompletFichier, ".") + 1)

    'Delete the image and the Chart
    Pic.Delete
    Ch.Delete
End Sub

mais ca n'est pas garanti sur des pcs faiblards il y a des ratés
c'est pour ca que perso j'utilise une api IsClipboardFormatAvailable
au moins je suis sur

donc avec l'api

VB:

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
#Else
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
#End If

Sub Test_QRCodeToCell()
    Call QRCodeToCell("Bonjour", ActiveCell, 100, 100)
End Sub

Sub Test_QRCodeToFile()
    Call QRCodeToFile("Bonjour", [I6].Value, 100, 100)
End Sub

'----------------------------
'Génère un QR code en cellule
'----------------------------
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

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

    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 Pic = ActiveSheet.Pictures.Insert(Link)
    Pic.Name = PicName
    Set QRCodeToCell = Pic
End Function

'----------------------------
'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
    Dim hPicAvail
    Set Pic = QRCodeToCell(Chaine, ActiveCell, PicWidth, PicHeight)
    
    'Create a Chart on the ActiveSheet
    Set Ch = ActiveSheet.ChartObjects.Add(0, 0, Pic.Width, Pic.Height)

    'Copy / Paste the image into the Chart
    Pic.Copy
   Do: DoEvents: hPicAvail = IsClipboardFormatAvailable(14): Loop While hPicAvail = 0
 Ch.Activate
    Ch.Chart.Paste
    Do While Ch.Chart.Pictures.Count < 1: Loop

    'Force the Width of the image in the Chart otherwise a slight shift might appear in Chart
    Ch.Chart.Shapes(1).Width = Ch.Width
    Ch.Chart.Shapes(1).Height = Ch.Height
    'Exit Sub

    'Export the Chart to the image file
    Ch.Chart.Export NomCompletFichier, FilterName:=Mid(NomCompletFichier, InStrRev(NomCompletFichier, ".") + 1)

    'Delete the image and the Chart
    Pic.Delete
    Ch.Delete
End Sub

a +😉

Dudu2 · 29 Mai 2022

Bonjour @Phil69970,
Merci pour ta réponse et ton essai. Mais si cela fonctionne chez toi, c'est cool mais pas chez moi.

Bonjour @patricktoulon,
Merci pour ton explication. Je savais que tu aurais une idée du pourquoi.
Cependant, un essai rapide (avec l'API) ne donne pas encore de résultat.
Je dois partir rouler (vélo) et je creuserai la question dans l'après-midi.

Dudu2 · 29 Mai 2022

Bon, en fait, il faut:
- d'une part que ScreenUpdating = True
- d'autre part temporiser un peu après le Coller
C'est bien un problème de lenteur ou désynchronisation du Coller par rapport au VBA qui pose problème.
Merci pour vos réponses.

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
    Dim ScreenUpdatingAtCallTime As Boolean
  
    ScreenUpdatingAtCallTime = Application.ScreenUpdating
  
    Set Pic = QRCodeToCell(Chaine, ActiveCell, PicWidth, PicHeight)
  
    'Create a Chart on the ActiveSheet
    Set Ch = ActiveSheet.ChartObjects.Add(0, 0, Pic.Width, Pic.Height)

    'Copy / Paste the image into the Chart
    Pic.Copy
    Ch.Activate
    Ch.Chart.Paste
  
    'Force et temporise le coller
    Application.ScreenUpdating = True
    DoEvents

    'Force the Width of the image in the Chart otherwise a slight shift might appear in Chart
    Ch.Chart.Shapes(1).Width = Ch.Width
    Ch.Chart.Shapes(1).Height = Ch.Height

    'Export the Chart to the image file
    Ch.Chart.Export NomCompletFichier, FilterName:=Mid(NomCompletFichier, InStrRev(NomCompletFichier, ".") + 1)

    'Delete the image and the Chart
    Pic.Delete
    Ch.Delete
  
    Application.ScreenUpdating = ScreenUpdatingAtCallTime
End Sub

Edit: Fichier supprimé. Voir ci-dessous

soan · 29 Mai 2022

Bonjour à tous,

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

quand on vous dit et qu'on vous répète que les nouvelles versions sont toujours meilleures que les anciennes ! j'crois qu'ils ont des ingénieurs, chez Microsoft, pour dégrader exprès la qualité d'leur logiciel : ça fait tourner leurs plateformes de maintenance logicielle, et bizarrement, c'est commercialement plus vendeur ! 😁 😂 🤣

soan

Dudu2 · 29 Mai 2022

Bonsoir @soan,

Je ne sais pas si c'est aussi perfide que ça. 😱

Quand par exemple je passe le ScreenUpdating à False, je peux attendre aussi longtemps que je veux (ci-dessous ça fait 2 à 3 secondes elapse), rien ne vient dans l'image. Ça ne fonctionne pas.

VB:

'Copy / Paste the image into the Chart
    Pic.Copy
    Ch.Activate
    Ch.Chart.Paste
 
    'PAS DE SCREENUPDATING !
    Application.ScreenUpdating = False
 
    'ATTENTE DE 2 OU 3 SECONDES ELAPSE
    Dim i As Integer
    For i = 1 To 30000
        DoEvents
    Next i
    For i = 1 To 30000
        DoEvents
    Next i
    For i = 1 To 30000
        DoEvents
    Next i

De plus c'est propre à cette image dont je ne sais pas bien comment elle se construit (j'ai juste pompé le code indiqué par Google).

Code:

'https://developers.google.com/chart/infographics/docs/qr_codes
Link = "http://chart.googleapis.com/chart?cht=qr&chs=" & PicWidth & "x" & PicHeight & "&chl=" & Chaine
.../...
'Génère l'image QR Code
Set Pic = ActiveSheet.Pictures.Insert(Link)

Car si j'utilise une image "standard" copiée manuellement dans la feuille, je n'ai pas ce problème.

Je pense que c'est une config particulière qui, dans mon cas Excel 2016 (pas pour @Phil69970), nécessite ce ScreenUpdating à True. Mais je ne saurais en dire la raison.

Phil69970 · 29 Mai 2022

Le fil

Juste pour info :
Cela à fonctionner à partir du moment ou j'ai changé l'extension de JPG en PNG

Si cela peut aussi servir j'ai excel 2010 64 bits et Windows 10

@Phil69970

Dudu2 · 29 Mai 2022

@Phil69970,
Oui j'avais noté ta remarque. Et j'avais dans la foulée refait un essai en .PNG mais sans succès.
Et encore maintenant, cette séquence de 2 instructions, après le Coller du Chart est indispensable quelque soit le format de l'image. Et quelque soit l'état du ScreenUpdating en entrant dans la fonction.

VB:

    'Force l'affichage et temporise le coller
    Application.ScreenUpdating = True
    DoEvents

patricktoulon · 29 Mai 2022

bonsoir à tous
excel travail en gif un point c'est tout
copy--->paste sur conteneur = bitmap
copypicture--copy en wmf(plus rapide)FORMAT WINDOW META FICHIER
copy xlscreen,xlbitmap--> copy ce qu'il y a a l’écran (meme en dessous l'image ET EN BITMAP
dans tout les cas le .chart.export export en gif 16 bit (presque équivalent au bitmap
tu peux mettre (.png ou .jpeg ou .gif) le format sera le même
cependant "gif" est le mieux adapté

sachez tout de même que le format bitmap est le plus lourd !!!!!et par conséquent moins digeste pour le clipbord qui est mou du bulbe sur les versions office 1016 et +

faites moi plaisir
copypicture--> copy en meta fichier
' eventtuellement on boucle tant que le pictures.count =0
.paste ---on colle
' eventtuellement on boucle jusqu'a que que le pictures.count =1
export --> on exporte

et tout le monde peut aller à la plage

amis du soir bonsoir

LOL😉

patricktoulon · 29 Mai 2022

je suis de bonne humeur
je vous montre comment on travaille comme les grands
LOL😉😉😉😅😂🤣😅

VB:

Sub VaYDUDU()
Dim chemin$
chemin = Environ("userprofile") & "\DeskTop\Qr Code.jpg"

textToQrCode "salut Mon Dudu", chemin
End Sub
Function textToQrCode(Chaine As String, chemin$, _
                      Optional PicWidth As Integer = 120, _
                      Optional PicHeight As Integer = 120)
    Dim Link As String
    

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

    Dim ReQ As Object, oStream As Object
      'On Error Resume Next    'On ne gère pas les erreurs
    Set ReQ = CreateObject("Microsoft.XMLHTTP")
    ReQ.Open "get", Link, False
    ReQ.send
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write ReQ.responsebody
   oStream.SaveToFile chemin
    oStream.Close
End Function

bon je vous laisse apéro

Dudu2 · 29 Mai 2022

Salut mon Patrick,

Les pros font des choses sophistiquées, et c'est bien pour un amateur comme moi.
Mais pourquoi ça marche pas si je mets le fichier ailleurs ?
Le oStream n'a pas les autorisations ?

Edit: Ah non !
Il faudrait d'abord supprimer le fichier s'il existe !!
Alors les pros ils testent pas tout ? 😉

Dudu2 · 29 Mai 2022

Bon ok, merci @patricktoulon pour ton code de Pro !
Voici le fichier final avec ta méthode (j'ai conservé l'ancienne par pure vanité).
Quiconque ayant à faire avec un QR Code devrait le garder au chaud. 😎

Edit: Fichier supprimé. Voir ci-dessous

patricktoulon · 29 Mai 2022

re

oui tu peux faire un dir sur le chemin et un kill si il existe avant
c'est le moteur que j'ai donné
pour soigner ta vanité il fallait bien que je te laisse quelque chose a faire
😅😂🤣😇😇😇

Dudu2 · 29 Mai 2022

Merci Ô Grand Maître

Effectuez une recherche sur Excel Downloads...

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

Dudu2

XLDnaute Barbatruc

Pièces jointes

patricktoulon

Phil69970

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

soan

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Phil69970

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Discussions similaires

Nous accordons de l'importance à votre vie privée