Amélioration fichier qr-code-google-multiple.xlsm office 2019

Bonjour, je cherche a améliorer le fichier créer a partir de l'API Google par Steelson que voici. Merci Steelson

Il faudrait lancer la création des Qrcode grâce à un bouton afin d'éviter que les Qrcode soit généré par erreur ou par modification de la base de données.

Les QRcode seront générer en moyenne une fois par mois de Janvier à Mai, puis 1 fois par semaine ou plus le restant de l'année et il serait préférable qu'ils soient générés uniquement lorsque cela est demandé.

Aussi il faudrait que la colonne s'adapte automatiquement au QRcode 100x100 généré, le Qrcode doit être entièrement dans la cellule destinataire.

J'ai ajouté le paramètre de marge :

Afin de limiter la marge en ligne et colonne à 0 qui est par défauts à 4.

Cependant, il ralentit beaucoup le travaille de la fonction, je l'ai peut être mal ajouté.

Const sMarginParameter As String = "chld=L|0"

essaie comme ceci

Option Explicit
'https://developers.google.com/chart/infographics/docs/qr_codes

Sub genererQRCodes()

    Dim Img As Object
    For Each Img In ActiveSheet.Pictures
        Img.Delete
    Next

    Dim i As Integer
    Columns("B:B").Select
    Selection.ColumnWidth = 20
    Cells.Select
    Selection.RowHeight = 110
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).row
        URL_QRCode_SERIES Cells(i, 1), i
    Next

End Sub

Function URL_QRCode_SERIES(ByVal QR_Value As String, x As Integer) As Variant

Dim oPic As Shape
Dim sURL As String
Dim vLeft, vTop
Dim PictureSize As Long
PictureSize = 100
vLeft = 20
vTop = 20

Const sRootURL As String = "https://chart.googleapis.com/chart?"
Const sSizeParameter As String = "chs="
Const sTypeChart As String = "cht=qr"
Const sDataParameter As String = "chl="
Const sJoinCHR As String = "&"

sURL = sRootURL & _
       sSizeParameter & PictureSize & "x" & PictureSize & sJoinCHR & _
       sTypeChart & sJoinCHR & _
       sDataParameter & UTF8_URL_Encode(VBA.Replace(QR_Value, " ", "+")) & sJoinCHR

Set oPic = ActiveSheet.Shapes.AddPicture(sURL, True, True, Range("B" & x).Left + 4, Range("B" & x).Top + 4, PictureSize, PictureSize)

End Function

Function UTF8_URL_Encode(ByVal sStr As String)
    'http://www.nonhostile.com/howto-convert-byte-array-utf8-string-vb6.asp
    Dim i As Long
    Dim a As Long
    Dim res As String
    Dim code As String

    res = ""
    For i = 1 To Len(sStr)
        a = AscW(Mid(sStr, i, 1))
        If a < 128 Then
            code = Mid(sStr, i, 1)
        ElseIf ((a > 127) And (a < 2048)) Then
            code = URLEncodeByte(((a \ 64) Or 192))
            code = code & URLEncodeByte(((a And 63) Or 128))
        Else
            code = URLEncodeByte(((a \ 144) Or 234))
            code = code & URLEncodeByte((((a \ 64) And 63) Or 128))
            code = code & URLEncodeByte(((a And 63) Or 128))
        End If
        res = res & code
    Next i
    UTF8_URL_Encode = res
End Function

Private Function URLEncodeByte(val As Integer) As String
    Dim res As String
    res = "%" & Right("0" & Hex(val), 2)
    URLEncodeByte = res
End Function

La fonction me permet maintenant d'utiliser un bouton de macro pour générer, ça c'est parfait.
Actuellement, les QRCode ce décalent un peu plus vers le bas à chaque ligne, il faudrait qu'il soit parfaitement au centre des cellules.

je te laisse régler les paramètres, notamment le 4 qui décale l'image du coin haut gauche de la cellule

Range("B" & x).Left + 4, Range("B" & x).Top + 4

ainsi que la hauteur et la largeur des lignes et colonnes

Bonjour, j'ai modifié à 0 l'ensemble des paramètres décalant les QR COdes afin qu'ils soit crée dans l'angle supérieur gauche des cellules, mais les QR Codes continus de ce décaler petit à petit vers le bas. Je n'arrive pas a trouver le paramètre qui est à l'origine de ce décalage.

Peut être qu'il manque un paramètre ?

C'est assez curiaux, d'autant que cela ne se décale qu'en hauteur quand on scrolle.

Il semble que Range("C" & x).Top soit en cause, mais pourquoi il n'aurait pa la même valeur partout ?

Incompréhensible, la seule solution serait de corriger cela en mettant une correction par ligne du type x/8 ou x/9 à voir

Set oPic = ActiveSheet.Shapes.AddPicture(sURL, True, True, Range("C" & x).Left + 4, Range("C" & x).Top + 4 - x / 8, PictureSize, PictureSize)

C'est assez curiaux, d'autant que cela ne se décale qu'en hauteur quand on scrolle.

Il semble que Range("C" & x).Top soit en cause, mais pourquoi il n'aurait pa la même valeur partout ?

Incompréhensible, la seule solution serait de corriger cela en mettant une correction par ligne du type x/8 ou x/9 à voir

Je suppose qu'il a la même valeur mais quelque chose nous échappe.

J'ai essayer votre solution est cela améliore légèrement le problème sans le corriger

Il y aurait il une solution pour placer la première image et placé les suivante à la hauteur des lignes ?

Je suis entrain de récupérer une ancienne macro qui avais pour but de centrer 1 image dans 1 emplacement.

Sub Test()
Set Emplacement1 = Range("B1:J4")
With ActiveSheet.Shapes("Image 34")
    .Left = Emplacement1.Left + Emplacement1.Width / 2 - .Width / 2
    .Top = Emplacement1.Top + Emplacement1.Height / 2 - .Height / 2
End With
End Sub