Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
Private Declare Function InternetReadBinaryFile Lib "wininet.dll" Alias "InternetReadFile" (ByVal hfile As Long, ByRef bytearray_firstelement As Byte, ByVal lNumBytesToRead As Long, ByRef lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
 
Function DownloadFile(sUrl As String, filePath As String, Optional overWriteFile As Boolean)
  Dim hInternet, hSession, lngDataReturned As Long, sBuffer() As Byte, totalRead As Long
  Const bufSize = 128
  ReDim sBuffer(bufSize)

  hSession = InternetOpen("", 0, vbNullString, vbNullString, 0)
  If hSession Then hInternet = InternetOpenUrl(hSession, sUrl, vbNullString, 0, INTERNET_FLAG_NO_CACHE_WRITE, 0)
  Set oStream = CreateObject("ADODB.Stream")
  oStream.Open
  oStream.Type = 1
 
  If hInternet Then
    iReadFileResult = InternetReadBinaryFile(hInternet, sBuffer(0), UBound(sBuffer) - LBound(sBuffer), lngDataReturned)
    ReDim Preserve sBuffer(lngDataReturned - 1)
    oStream.Write sBuffer
    ReDim sBuffer(bufSize)
    totalRead = totalRead + lngDataReturned
    Application.StatusBar = "Downloading file. " & CLng(totalRead / 1024) & " KB downloaded"
    DoEvents
 
    Do While lngDataReturned <> 0
      iReadFileResult = InternetReadBinaryFile(hInternet, sBuffer(0), UBound(sBuffer) - LBound(sBuffer), lngDataReturned)
      If lngDataReturned = 0 Then Exit Do
 
      ReDim Preserve sBuffer(lngDataReturned - 1)
      oStream.Write sBuffer
      ReDim sBuffer(bufSize)
      totalRead = totalRead + lngDataReturned
      Application.StatusBar = "Downloading file. " & CLng(totalRead / 1024) & " KB downloaded"
      DoEvents
    Loop
 
    Application.StatusBar = "Download complete"
    oStream.SaveToFile filePath, IIf(overWriteFile, 2, 1)
    oStream.Close
  End If
  Call InternetCloseHandle(hInternet)
  DownloadFile = 0

    
  
  
End Function

Public Function UrlEncode(ByRef szString As String) As String
       Dim szChar   As String
       Dim szTemp   As String
       Dim szCode   As String
       Dim szHex    As String
       Dim szBin    As String
       Dim iCount1  As Integer
       Dim iCount2  As Integer
       Dim iStrLen1 As Integer
       Dim iStrLen2 As Integer
       Dim lResult  As Long
       Dim lAscVal  As Long
       szString = Trim$(szString)
       iStrLen1 = Len(szString)
       For iCount1 = 1 To iStrLen1
           szChar = Mid$(szString, iCount1, 1)
           lAscVal = AscW(szChar)
           If lAscVal >= &H0 And lAscVal <= &HFF Then
              If (lAscVal >= &H30 And lAscVal <= &H39) Or _
                 (lAscVal >= &H41 And lAscVal <= &H5A) Or _
                 (lAscVal >= &H61 And lAscVal <= &H7A) Then
                 szCode = szCode & szChar
              Else
                 
                 szCode = szCode & "%" & Hex(AscW(szChar))
              End If
           Else
              szHex = Hex(AscW(szChar))
              iStrLen2 = Len(szHex)
              For iCount2 = 1 To iStrLen2
                  szChar = Mid$(szHex, iCount2, 1)
                  Select Case szChar
                         Case Is = "0"
                              szBin = szBin & "0000"
                         Case Is = "1"
                              szBin = szBin & "0001"
                         Case Is = "2"
                              szBin = szBin & "0010"
                         Case Is = "3"
                              szBin = szBin & "0011"
                         Case Is = "4"
                              szBin = szBin & "0100"
                         Case Is = "5"
                        szBin = szBin & "0101"
                         Case Is = "6"
                              szBin = szBin & "0110"
                         Case Is = "7"
                              szBin = szBin & "0111"
                         Case Is = "8"
                              szBin = szBin & "1000"
                         Case Is = "9"
                              szBin = szBin & "1001"
                         Case Is = "A"
                              szBin = szBin & "1010"
                         Case Is = "B"
                              szBin = szBin & "1011"
                         Case Is = "C"
                              szBin = szBin & "1100"
                         Case Is = "D"
                              szBin = szBin & "1101"
                         Case Is = "E"
                              szBin = szBin & "1110"
                         Case Is = "F"
                              szBin = szBin & "1111"
                         Case Else
                  End Select
              Next iCount2
              szTemp = "1110" & Left$(szBin, 4) & "10" & Mid$(szBin, 5, 6) & "10" & Right$(szBin, 6)
              For iCount2 = 1 To 24
                  If Mid$(szTemp, iCount2, 1) = "1" Then
                     lResult = lResult + 1 * 2 ^ (24 - iCount2)
                  Else: lResult = lResult + 0 * 2 ^ (24 - iCount2)
                  End If
              Next iCount2
              szTemp = Hex(lResult)
                    szCode = szCode & "%" & Left$(szTemp, 2) & "%" & Mid$(szTemp, 3, 2) & "%" & Right$(szTemp, 2)
           End If
           szBin = vbNullString
           lResult = 0
       Next iCount1
       UrlEncode = szCode
End Function
Sub 移除所有QRCode()
    For Each Shape In ActiveSheet.Shapes
        If Shape.Name = "qrcode_graph" Then Shape.Delete
    Next Shape
    For I = 1 To 1000
        Cells(I, 5).Value = ""
    Next I
End Sub
Function get_qrcode(src, dst)
On Error Resume Next

Dim link$, str As String

Text = UrlEncode(src.Value)
link = "https://api.qrserver.com/v1/create-qr-code/?size=150x150&data=" + Text
Kill "d:\kkk.png"
tmp = DownloadFile(link, "d:\kkk.png", True)
If Dir("d:\kkk.png") <> "" And FileLen("d:\kkk.png") = 0 Then
    get_qrcode = 1
    Exit Function
    
End If
FileCopy "d:\kkk.png", "d:\qr.png"


l = dst.Left + 5
t = dst.Top + 5
w = dst.Width - 10
h = dst.Height - 10

Set p = Application.ActiveSheet.Shapes.AddPicture("d:\kkk.png", False, True, l, t, w, h)
p.Name = "qrcode_graph"
p.Placement = xlMoveAndSize

get_qrcode = 0

End Function
Sub 更新QR_CODE()
    For Each cell In Selection
        v = cell.Value()
        If cell.Column <> 1 Then
            MsgBox ("Cell is not valid")
            Exit Sub
        End If
    Next cell
        
    For Each cell In Selection
        If Len(cell.Value) = 0 Then GoTo nextcell
        
        
        
        C = cell.Column
        R = cell.Row
        Rows(R).RowHeight = 75
        
        If Cells(R, 5).Value <> cell.Value Then
            If get_qrcode(cell, Cells(R, 5)) <> 0 Then
                MsgBox ("get qrcode failed")
            Else
                Cells(R, 5).Value = cell.Value
            End If
        End If
        
                                
nextcell:
    Next cell
    
End Sub