Option Compare Database Option Explicit Global inet_Responded As Boolean Global inet_response As String Const adTypeBinary = 1 ' Binary file is encoded Const Folder = "Q:\AI_VISION\" ' THIS ROUTINE REQUIRES A DATABASE FORM TO HAVE AN INET (Internet Access Control) CREATED ON IT. ' ' The INET control needs to be named inet_master ' ' The form needs the following code to be inserted ' ' BUT!!! remove this DIM statement below, it's just a way of allowing this to compile. Dim Inet_Master REMOVE THIS LINE WHEN YOU'VE PASTED THE CODE INTO A FORM Private Sub Inet_Master_StateChanged(ByVal State As Integer) Dim vtData As Variant ' Data variable. Dim outputString As String Dim icString Select Case State Case 11 ' icError ' 11 MsgBox "An error occured. Check both your and the server's internet connection is working.", vbCritical, "Error" Case 12 ' icResponseCompleted ' 12 ' Get the first chunk. NOTE: specify a Byte ' array (icByteArray) to retrieve a binary file. vtData = Inet_Master.GetChunk(1024, icString) Do While LenB(vtData) > 0 outputString = outputString + vtData ' Get next chunk. vtData = Inet_Master.GetChunk(1024, icString) Loop inet_response = outputString inet_Responded = True End Select End Sub ' OK, THE REAL CODE STARTS HERE!!!! Function List_Files(folderspec, filespec) Dim fs, FLDR, files, fl Dim list As String Set fs = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set FLDR = fs.GetFolder(folderspec) Set files = FLDR.files list = "" If Err = 0 Then For Each fl In files If fl.name Like filespec Then list = list & fl.name & ";" Next Else MsgBox "List Files Error: " & Err.Description End If List_Files = list End Function Sub Wait_Server() Dim I As Integer 'wait for server response - should include the auth token For I = 1 To 100 DoEvents If inet_Responded Then Exit For Sleep 100 Next End Sub Public Function URLEncode( _ StringVal As String, _ Optional SpaceAsPlus As Boolean = False _ ) As String Dim StringLen As Long: StringLen = Len(StringVal) If StringLen > 0 Then ReDim result(StringLen) As String Dim I As Long, CharCode As Integer Dim Char As String, Space As String If SpaceAsPlus Then Space = "+" Else Space = "%20" For I = 1 To StringLen Char = Mid$(StringVal, I, 1) CharCode = Asc(Char) Select Case CharCode Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126 result(I) = Char Case 32 result(I) = Space Case 0 To 15 result(I) = "%0" & Hex(CharCode) Case Else result(I) = "%" & Hex(CharCode) End Select Next I URLEncode = Join(result, "") End If End Function Public Function EncodeFile(strPicPath As String) As String ' Variables for encoding Dim objXML Dim objDocElem ' Variable for reading binary picture Dim objStream ' Open data stream from picture Set objStream = CreateObject("ADODB.Stream") objStream.Type = adTypeBinary objStream.Open objStream.LoadFromFile (strPicPath) ' Create XML Document object and root node ' that will contain the data Set objXML = CreateObject("MSXml2.DOMDocument") Set objDocElem = objXML.createElement("Base64Data") objDocElem.DataType = "bin.base64" ' Set binary value objDocElem.nodeTypedValue = objStream.Read() ' Get base64 value EncodeFile = objDocElem.Text ' Clean all Set objXML = Nothing Set objDocElem = Nothing Set objStream = Nothing End Function Public Function EncodeFileOctet(strPicPath As String) As String ' Variable for reading binary picture Dim objStream ' Open data stream from picture Set objStream = CreateObject("ADODB.Stream") objStream.Type = adTypeBinary objStream.Open objStream.LoadFromFile (strPicPath) ' Encode it EncodeFileOctet = StrConv(objStream.Read(), vbUnicode) ' Clean all Set objStream = Nothing End Function Public Function GoogleVision(FName) Dim APIKey As String Dim strURL As String Dim strFormData As String Dim strHeaders As String GoogleVision = "FAILED" If File_Exists(FName) = False Then Debug.Print FName, "not found" Exit Function End If APIKey = "" INSERT YOUR OWN API KEY HERE inet_Responded = False inet_response = "no response" strURL = "https://vision.googleapis.com/v1/images:annotate?key=" & APIKey strHeaders = "Content-Type:application/json" '"TYPE": ' FACE_DETECTION ' LABEL_DETECTION ' SAFE_SEARCH_DETECTION ' IMAGE_PROPERTIES ' LOGO_DETECTION ' LANDMARK_DETECTION ' TEXT_DETECTION ' ' "maxResults": xxx ' ' USE THIS VERSION IF THE FILE IS ALREADY IN GOOGLES CLOUD STORE! ' strFormData = "{ ""requests"": [ { ""features"": [ { ""type"": ""LABEL_DETECTION"",""maxResults"": 10 }, { ""type"": ""SAFE_SEARCH_DETECTION"", }, { ""type"": ""FACE_DETECTION"", }]," _ ' & """image"": {""source"": { ""gcsImageUri"": ""[IMAGE]"" } } } ] }" ' ' strFormData = Replace(strFormData, "[IMAGE]", Fname) ' INSERT IMAGE NAME HERE, i.e. "gs://bucketsqw1/potd-160121.jpg" ' USE THIS VERSION TO PASS THE IMAGE IN THE REQUEST strFormData = "{ ""requests"": [ { ""features"": [ { ""type"": ""LABEL_DETECTION"",""maxResults"": 10 }, { ""type"": ""SAFE_SEARCH_DETECTION"", }, { ""type"": ""FACE_DETECTION"", }]," _ & """image"": {""content"": ""[IMAGE]"" } } ] }" strFormData = Replace(strFormData, "[IMAGE]", EncodeFile(FName & "")) Forms.Switchboard.Inet_Master.Execute strURL, "POST", strFormData, strHeaders Wait_Server If inet_response = "no response" Then Debug.Print inet_response Exit Function End If WriteFile Replace(FName, ".jpg", ".json"), inet_response GoogleVision = GoogleImageTags(inet_response) End Function Function GoogleFace(Json) Dim I As Integer Dim j As Integer Dim SX As Integer Dim SY As Integer Dim EX As Integer Dim EY As Integer Dim sarr() As String ' This does a very crude inspection of the JSON file to get the face vertices GoogleFace = "" If InStr(Json, "boundingpoly") < 1 Then Exit Function sarr = Split(Replace(Json, vbCr, ""), vbLf) For I = 0 To UBound(sarr) DoEvents If Trim(sarr(I)) = """fdboundingPoly"": {" Then SX = 9999 SY = 9999 EX = 0 EY = 0 End If If SX > 0 Then If InStr(sarr(I), """x""") > 0 Then j = GetNum(sarr(I)) If j <= SX Then SX = j Else EX = j End If End If If InStr(sarr(I), """y""") > 0 Then j = GetNum(sarr(I)) If j <= SY Then SY = j Else EY = j Exit For ' We've got four points, we can exit End If End If End If If InStr(sarr(I), "landmarks") > 0 Then Exit For ' We're passed the data, give up Next If SX = EX Or SY = EY Then GoogleFace = "" Else GoogleFace = SX & "," & SY & "," & EX & "," & EY End If End Function Function GoogleImageTags(inet_response) Dim sarr() As String Dim stats As String Dim tags As String Dim I As Integer ' Get some of the tag and adult likelyhood info from the JSON text sarr = Split(inet_response, vbLf) stats = "" tags = "" For I = 0 To UBound(sarr) DoEvents sarr(I) = Trim(sarr(I)) sarr(I) = Replace(sarr(I), vbCr, "") sarr(I) = Replace(sarr(I), vbLf, "") If InStr(sarr(I), "description") > 0 Then tags = tags & Trim(Replace(Replace(sarr(I), """description"":", ""), """", "")) End If If InStr(sarr(I), "adult"":") > 0 Or _ InStr(sarr(I), "spoof"":") > 0 Or _ InStr(sarr(I), "medical"":") > 0 Or _ InStr(sarr(I), "violence"":") > 0 Or _ InStr(sarr(I), "Likelihood"":") > 0 Then If InStr(sarr(I), "unlikely") < 1 Then stats = stats & Trim(Replace(Replace(sarr(I), """", ""), " ", "")) End If End If Next GoogleImageTags = tags & "|" & stats End Function Function GetNum(intxt) Dim txt As String Dim I As Integer For I = 1 To Len(intxt) If InStr("0123456789.-", Mid(intxt, I, 1)) > 0 Then txt = txt & Mid(intxt, I, 1) Next GetNum = val(txt) End Function Function TagClean(passval) Dim txt As String ' Generally get rid of spare comma's and other junk txt = Nz(passval, "") txt = Replace(txt, " ", " ") txt = Replace(txt, ",,", ",") txt = Replace(txt, " ", "¬") txt = Replace(txt, ",", " ") txt = Trim(txt) txt = Replace(txt, " ", ",") txt = Replace(txt, "¬", " ") TagClean = txt End Function Public Function MicrosoftVision(FName) Dim APIKey As String Dim strURL As String Dim strFormData As String Dim strHeaders As String MicrosoftVision = "FAILED" If File_Exists(FName) = False Then Debug.Print FName, "not found" Exit Function End If inet_Responded = False inet_response = "no response" APIKey = "" INSERT YOUR OWN API KEY HERE strURL = "https://api.projectoxford.ai/vision/v1.0/analyze?visualFeatures=" & URLEncode("Description,Adult,Faces,Color,Categories") ' ,Tags,Description,Faces,Adult" ' Use this for a URL 'strHeaders = "Content-Type:application/json" & vbCrLf & "Host: api.projectoxford.ai" & vbCrLf & "Ocp-Apim-Subscription-Key: " & APIKey 'strFormData = "{""url"":""http://www.filmphotoacademy.com/blog/uploads/masters/potd-161126.jpg""}" ' USE THIS VERSION TO PASS THE IMAGE IN THE REQUEST strHeaders = "Content-Type:application/octet-stream" & vbCrLf & "Host: api.projectoxford.ai" & vbCrLf & "Ocp-Apim-Subscription-Key: " & APIKey strFormData = EncodeFileOctet(FName & "") Forms.Switchboard.Inet_Master.Execute strURL, "POST", strFormData, strHeaders Wait_Server Debug.Print Replace(Replace(inet_response, "]", "]" & vbCrLf), """tags", vbCrLf & """tags") If inet_response = "no response" Then Debug.Print inet_response Exit Function End If WriteFile Replace(FName, ".jpg", "-ms.json"), inet_response MicrosoftVision = inet_response End Function Function GetJsonVar(intxt, var) Dim txt As String Dim I As Integer Dim j As Integer ' Pass it some JSON text and a field name in the text and it will try and find it txt = "" I = InStr(intxt, """" & var & """:") If I < 1 Then Exit Function txt = Mid(intxt, I + Len(var) + 3) ' 2 quotes and a colon If Left(txt, 1) <> "[" Then I = InStr(txt, ",") j = InStr(txt, "}") If I < 1 Then I = j If j < I Then I = j If I < 1 Then Exit Function txt = Left(txt, I - 1) Else ' It is an [ARRAY,ARRAY] I = InStr(txt, "]") txt = Mid(txt, 2, I - 2) End If txt = Replace(txt, """", "") ' May or may not have quotes, remove them anyway txt = Replace(txt, "[", "") txt = Replace(txt, "]", "") GetJsonVar = txt End Function Function MicrosoftFace(Json) ' Get the face params from a Microsoft JSON text Dim I As Integer Dim SX As Integer Dim SY As Integer Dim EX As Integer Dim EY As Integer Dim txt As String MicrosoftFace = "" I = InStr(Json, """faces""") If I > 0 Then txt = Mid(Json, I) SX = GetJsonVar(txt, "left") SY = GetJsonVar(txt, "top") EX = SX + GetJsonVar(txt, "width") EY = SY + GetJsonVar(txt, "height") MicrosoftFace = SX & "," & SY & "," & EX & "," & EY End If End Function Function MicrosoftImageTags(inet_response) Dim txt As String txt = "" txt = GetJsonVar(inet_response, "tags") & "|" If GetJsonVar(inet_response, "IsRacyContent") = "true" Then txt = txt & "Adult:RACY" txt = txt & "|" txt = txt & GetJsonVar(inet_response, "text") & "|" txt = txt & Replace(GetJsonVar(inet_response, "name"), "_", "") & "|" txt = txt & GetJsonVar(inet_response, "age") & "|" txt = txt & GetJsonVar(inet_response, "gender") Debug.Print txt MicrosoftImageTags = txt End Function Sub AI_Test_Folder() Dim Files() As String Dim I As Integer Dim txt As String Dim Body As String Dim WaitThree As Long ' Scans the CONST Folder (defined at top) ' ' For all .jpg files found pass them to both the Microsoft and Google vision APIs ' Store the results in file-ms.json and file-gl.json respectively Files = Split(List_Files(Folder, "*.jpg"), ";") For I = 0 To UBound(Files) DoEvents If File_Exists(Folder & Files(I)) = False Then GoTo skipit If Files(I) = "" Then GoTo skipit Debug.Print Files(I), I, UBound(Files), If File_Exists(Folder & Replace(Files(I), ".jpg", "-ms.json")) = False Then WaitThree = Timer + 3 ' Submission rate 1 every 3 seconds txt = MicrosoftVision(Folder & Files(I)) Body = Body & Files(I) & "|" & txt & vbCrLf Debug.Print "micro", End If If File_Exists(Folder & Replace(Files(I), ".jpg", ".json")) = False Then txt = GoogleVision(Folder & Files(I)) Body = Body & Files(I) & "|" & txt & vbCrLf Debug.Print "google", End If ' Wait if we need to Do While WaitThree > Timer DoEvents Sleep 500 Loop skipit: Next ' Save a list of all responses too WriteFile Folder & "\alist-ms.txt", Body End Sub