ngduychien
VIP
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
Hàm chèn QR Code tạo được vào Sheet đang mở
Và
Hàm lấy QR Code từ API
Mã:
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
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
Mã:
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