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