none
VBA Excel : générer un QR Code RRS feed

  • Question

  • Bonjour,

    J'ai une excellente fonction vba pour générer des QR codes que j'ai trouvée sur la toile. Merci à son auteur que je ne connais pas !

    Cependant, j'aimerai lui apporter deux modifications :

    - 1. actuellement le QR code est bordé de blanc, or j'aimerai réduire cet espace voir le supprimer;

    - 2. j'aimerai l'agrandir.

    Je remercie toute personne qui m'apportera son aide pour déterminer, dans le code ci-dessous, l'endroit où l'on peut modifier cela. Je pense qu'il doit s'agir de "Line.Visible = False", mais je ne sais pas où l'inclure dans le code.

    Voici le code :

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

    Function URL_QRCode_SERIES( _
        ByVal QR_Value As String, _
        Optional ByVal PictureSize As Long = 150, _
        Optional ByVal DisplayText As String = "", _
        Optional ByVal Updateable As Boolean = True) As Variant

    Dim oPic As Shape, oRng As Excel.Range
    Dim vLeft As Variant, vTop As Variant
    Dim sURL As String

    Const PictureName = "imgQRCode"
    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 = "&"

    If Updateable = False Then
        URL_QRCode_SERIES = "outdated"
        Exit Function
    End If

    Set oRng = Application.Caller.Offset(, 1)

    On Error Resume Next
    Set oPic = oRng.Parent.Shapes(PictureName)
    If Err Then
        Err.Clear
        vLeft = oRng.Left '+ 4
        vTop = oRng.Top
    Else
        vLeft = oPic.Left
        vTop = oPic.Top
        PictureSize = Int(oPic.Width)
        oPic.Delete
    End If
    On Error GoTo 0

    If Len(QR_Value) = 0 Then
        URL_QRCode_SERIES = CVErr(xlErrValue)
        Exit Function
    End If

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

    Set oPic = oRng.Parent.Shapes.AddPicture(sURL, True, True, vLeft, vTop, PictureSize, PictureSize)
    oPic.Name = PictureName
    URL_QRCode_SERIES = DisplayText
    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

    dimanche 8 décembre 2019 07:07

Toutes les réponses

  • Bonjour,

    J'ai une excellente fonction vba pour générer des QR codes que j'ai trouvée sur la toile. Merci à son auteur que je ne connais pas !

    Cependant, j'aimerai lui apporter deux modifications :

    - 1. actuellement le QR code est bordé de blanc, or j'aimerai réduire cet espace voir le supprimer;

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

    Valeur jusqu'à 520 environ

    - 2. j'aimerai l'agrandir.

    Function URL_QRCode_SERIES( _
        ByVal QR_Value As String, _
        Optional ByVal PictureSize As Long = 150, _
        Optional ByVal DisplayText As String = "", _
        Optional ByVal Updateable As Boolean = True) As Variant


    Bonjour,

    je répond un peu tard mais j'ai beaucoup travaillé dessus et si ça peut aider d'autres personnes c'est avec plaisir,


    Il est possible également de déplacer l'image en jouant avec des + x et des - x à la fin des vLeft et vTop

    On Error Resume Next
    Set oPic = oRng.Parent.Shapes(PictureName)
    If Err Then
        Err.Clear
        vLeft = oRng.Left '+ 4
        vTop = oRng.Top

    • Proposé comme réponse Axel.R vendredi 26 mars 2021 18:51
    vendredi 26 mars 2021 18:32