Tạo QR Code bằng VBA sử dụng API của Google

[ngduychien]

Trong quá trình thiết kế AddIns phụ vụ nhu cầu của cá nhân, tôi có tìm kiếm và sử dụng ba hàm này để tạo QR Code. Chia sẻ cùng anh em trên group nhé.
Hàm lấy QR Code từ API

Sub InsertQR()
    Dim xHttp: Set xHttp = CreateObject("Microsoft.XMLHTTP")
    Dim bStrm: Set bStrm = CreateObject("Adodb.Stream")
    Dim Size: Size = 250 'dalam Pixels
    Dim QR, Name, val
    Dim Invalid: Invalid = "\/:*?" & """" & "<>|"
    For Each val In Selection
        Name = val.Value
        For intChar = 1 To Len(Name)
            If InStr(Invalid, LCase(Mid(Name, intChar, 1))) > 0 Then
                MsgBox "The file: " & vbCrLf & """" & Name & """" & vbCrLf & vbCrLf & " is invalid!"
                Exit Sub
            End If
        Next
        QR = "http://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl=" & Name
        xHttp.Open "GET", QR, False
        xHttp.Send
        With bStrm
            .Type = 1 '//binary
            .Open
            .write xHttp.responseBody
            .savetofile ThisWorkbook.Path & Application.PathSeparator & Name & ".png", 2 '//overwrite
            .Close
        End With
    Next
End Sub

Hàm chèn QR Code tạo được vào Sheet đang mở

Function ShowPic(PicFile As String) As String
    Dim AC As Range
    On Error GoTo Done
    Set AC = Application.Caller
    ActiveSheet.Shapes.AddPicture(ThisWorkbook.Path & Application.PathSeparator & PicFile, False, True, AC.Left, AC.Top, 30, 30).Name = "QR"
    ShowPic = ""
    Exit Function
Done:
    ShowPic = "Error"
End Function

Và

Sub PutTheQR()
    Dim val As String
    val = ActiveCell.Offset(0, -1).Value
    Do While val <> ""
    ActiveCell.FormulaR1C1 = "=ShowPic(RC[-1])"
    ActiveCell.ClearContents
    ActiveCell.Offset(1, 0).Activate
    val = ActiveCell.Offset(0, -1).Value
    Loop
End Sub

 

[vbano1]

Với code trên cần ghi rõ: Để code thực thi được theo đúng ý đồ, cần có kết nối internet ^^
Hi vọng chủ topic sớm có bài, làm sao tạo ra QR code ngay cả khi máy tính đang offline không có mạng internet ^^

 

[Mật vụ FBI]

@vbano1 có thể xem file tạo offline

Bạn cần đăng nhập để thấy link