โปรแกรมสร้าง QR Code ด้วย VB Excel

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

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

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