如何通过VBA上传图片到指定网址：https://666666.imgbb.com/

lingshimizi · 发表于 2021-1-2 19:55

各位大佬晚上好，首先祝大家元旦快乐希望大佬可以抽出宝贵的时间帮我解决一下这个问题
现在手里有几万张图片需要转换成链接，所以我现在想上传这些图片到这个网址网址：https://666666.imgbb.com/
用户名：666666
密码：123123abc

自己已经研究了两天了，不知道怎么办
已经从  http://club.excelhome.net/thread-1159783-1-1.html 这个大佬的帖子中学习过了，可还是上传的时候显示该页面不存在

我使用了这一段代码：
--------------------------------------------------------------------------------------
Sub Main()
Const Uid As String = "" '论坛UID
Const Hash As String = "" '上传的Hash，从Fiddler里取
Dim Boundary As String
Dim SendData
Dim FileFullName As String
Dim FileShortName As String
Dim Title As String
Dim Filetype As String

FileFullName = "D:\测试2.rar"
FileShortName = Mid(FileFullName, InStrRev(FileFullName, "") + 1)
Title = Left(FileShortName, InStrRev(FileShortName, ".") - 1)
Filetype = "rar"

'获取Boundary
Boundary = GetBoundary()
'获取上传所需的SendData
SendData = GetUpLoadSendData(Boundary, FileFullName, _
            "Filename", FileShortName, _
            "proid", "0", _
            "hash", Hash, _
            "uid", Uid, _
            "title", Title, _
            "filetype", Filetype, _
            "Filedata", FileShortName, _
            "Upload", "Submit Query")

'上传
With CreateObject("MSXML2.XMLHTTP")
      .Open "POST", "http://club.excelhome.net/misc.php?mod=swfupload&fid=2&action=swfupload&operation=upload", False
      .setRequestHeader "Content-Type", "multipart/form-data; boundary=" & Boundary
      .Send SendData
      Debug.Print .responsetext '出现一串数字则为成功。到论坛发帖的界面可看到“未使用的附件”的提示。
End With
End Sub

Function GetBoundary() As String
'生成Boundary
Dim i As Integer, r As Integer
Do While i < 30
      r = Int(Rnd * 75 + 48)
      If r < 58 Or (r > 64 And r < 91) Or r > 96 Then
         GetBoundary = GetBoundary & Chr(r)
         i = i + 1
      End If
Loop
GetBoundary = String(10, "-") & GetBoundary
End Function

Function GetUpLoadSendData(Boundary As String, FileFullName As String, ParamArray NameValue()) As Byte()
'NameValue()必须成双，前一个是名称，后一个是值
'NameValue()最后一对是文件流之后的名称值对
'NameValue()倒数第二对是文件流信息相关的两个数据

Dim DataBefore, DataAfter
Dim arrBytData(1 To 3), bytData() As Byte
Dim i As Long, j As Long, n As Long

'连接文件流之前的各项名称值对
For i = 0 To UBound(NameValue) - 4 Step 2 '最后两对单独处理
      DataBefore = DataBefore & "--" & Boundary & vbCrLf
      DataBefore = DataBefore & "Content-Disposition: form-data; name=""" & NameValue(i) & """" & vbCrLf
      DataBefore = DataBefore & vbCrLf
      DataBefore = DataBefore & NameValue(i + 1) & vbCrLf
Next

'连接文件流此项的Content-Disposition
DataBefore = DataBefore & "--" & Boundary & vbCrLf
DataBefore = DataBefore & "Content-Disposition: form-data; name=""" & NameValue(i) & """; filename=""" & NameValue(i + 1) & """" & vbCrLf
DataBefore = DataBefore & "Content-Type: application/octet-stream" & vbCrLf
DataBefore = DataBefore & vbCrLf

'文件流前面的字符串转为流
arrBytData(1) = StrToUTF8Byte(DataBefore)

'文件转流
arrBytData(2) = FileToByte(FileFullName)

'文件流之后的字符串（一项）
DataAfter = "--" & Boundary & vbCrLf
DataAfter = DataAfter & "Content-Disposition: form-data; name=""" & NameValue(i) & """" & vbCrLf
DataAfter = DataAfter & vbCrLf
DataAfter = DataAfter & NameValue(i + 1) & vbCrLf
DataAfter = DataAfter & "--" & Boundary & "--"
arrBytData(3) = StrToUTF8Byte(DataAfter) '转为流

'合并字符流和文件流
ReDim bytData(UBound(arrBytData(1)) + UBound(arrBytData(2)) + UBound(arrBytData(3)) + 2)
For i = 1 To 3
      For j = 0 To UBound(arrBytData(i))
         bytData(n) = arrBytData(i)(j)
         n = n + 1
      Next
Next

GetUpLoadSendData = bytData
End Function

Function StrToUTF8Byte(strText)
'文本转UTF-8编码并去除BOM头
With CreateObject("adodb.stream")
      .Mode = 3 'adModeReadWrite
      .Type = 2 'adTypeText
      .Charset = "UTF-8"
      .Open
      .Writetext strText
      .Position = 0
      .Type = 1 'adTypeBinary
      .Position = 3 '去除UTF-8编码文本前面的BOM头（三个字节）
      StrToUTF8Byte = .Read()
      .Close
End With
End Function

Function FileToByte(strFileName As String)
'文件转流
   With CreateObject("Adodb.Stream")
      .Open
      .Type = 1 'adTypeBinary
      .LoadFromFile strFileName
      FileToByte = .Read
      .Close
End With
End Function

--------------------------------------------------------------------------------------

该网站带了API对接，可是不知道怎么用，就在网站的左上角

新人第一次发帖，期待各位大佬的指点

下面是各位大佬可能会用到的自定义公式：
大部分还是从这个帖子复制的：
不懂html也来学网抓（xmlhttp/winhttp+fiddler）
http://club.excelhome.net/thread-1159783-1-1.html
(出处: ExcelHome技术论坛)
向前辈致敬

Function GetBoundary() As String
'生成Boundary
Dim I As Integer, r As Integer
Do While I < 16
      r = Int(Rnd * 75 + 48)
      If r < 58 Or (r > 64 And r < 91) Or r > 96 Then
         GetBoundary = GetBoundary & Chr(r)
         I = I + 1
      End If
Loop
GetBoundary = String(4, "-") & "WebKitFormBoundary" & GetBoundary
End Function

Function GetUpLoadSendData(Boundary As String, filePath As String, Timestamp As String, Auth_token As String) As Byte()

Dim DataBefore, DataAfter
Dim arrBytData(1 To 3), bytData() As Byte
Dim I As Long, j As Long, n As Long

'文件流之前的字符串
DataBefore = DataBefore & "--" & Boundary & vbCrLf
DataBefore = DataBefore & "Content-Disposition: form-data; name=" & Chr(34) & "source" & Chr(34) & "; filename=" & Chr(34) & qqq & Chr(34) & vbCrLf
DataBefore = DataBefore & "Content-Type: image/jpeg" & vbCrLf
DataBefore = DataBefore & vbCrLf

'文件流前面的字符串转为流
arrBytData(1) = StrToUTF8Byte(DataBefore)

'文件转流
arrBytData(2) = FileToByte(filePath)

'文件流之后的字符串
DataAfter = "--" & Boundary & vbCrLf
DataAfter = DataAfter & "Content-Disposition: form-data; name=" & Chr(34) & " type " & Chr(34) & vbCrLf
DataAfter = DataAfter & vbCrLf
DataAfter = DataAfter & "file" & vbCrLf

DataAfter = "--" & Boundary & vbCrLf
DataAfter = DataAfter & "Content-Disposition: form-data; name=" & Chr(34) & " action " & Chr(34) & vbCrLf
DataAfter = DataAfter & vbCrLf
DataAfter = DataAfter & "upload" & vbCrLf

DataAfter = "--" & Boundary & vbCrLf
DataAfter = DataAfter & "Content-Disposition: form-data; name=" & Chr(34) & " timestamp " & Chr(34) & vbCrLf
DataAfter = DataAfter & vbCrLf
DataAfter = DataAfter & Timestamp & vbCrLf

DataAfter = "--" & Boundary & vbCrLf
DataAfter = DataAfter & "Content-Disposition: form-data; name=" & Chr(34) & " auth_token " & Chr(34) & vbCrLf
DataAfter = DataAfter & vbCrLf
DataAfter = DataAfter & Auth_token & vbCrLf

DataAfter = "--" & Boundary & vbCrLf
DataAfter = DataAfter & "Content-Disposition: form-data; name=" & Chr(34) & " album_id " & Chr(34) & vbCrLf
DataAfter = DataAfter & vbCrLf
DataAfter = DataAfter & "6Jn83D" & vbCrLf

DataAfter = "--" & Boundary & vbCrLf
DataAfter = DataAfter & "Content-Disposition: form-data; name=" & Chr(34) & " expiration " & Chr(34) & vbCrLf
DataAfter = DataAfter & vbCrLf
DataAfter = DataAfter & "P1W" & vbCrLf

DataAfter = DataAfter & "--" & Boundary & "--"
arrBytData(3) = StrToUTF8Byte(DataAfter) '转为流

'合并字符流和文件流
ReDim bytData(UBound(arrBytData(1)) + UBound(arrBytData(2)) + UBound(arrBytData(3)) + 2)
For I = 1 To 3
      For j = 0 To UBound(arrBytData(I))
         bytData(n) = arrBytData(I)(j)
         n = n + 1
      Next
Next

GetUpLoadSendData = bytData
End Function

Function StrToUTF8Byte(strText)
'文本转UTF-8编码并去除BOM头
With CreateObject("adodb.stream")
      .Mode = 3 'adModeReadWrite
      .Type = 2 'adTypeText
      .Charset = "UTF-8"
      .Open
      .Writetext strText
      .Position = 0
      .Type = 1 'adTypeBinary
      .Position = 3 '去除UTF-8编码文本前面的BOM头（三个字节）
      StrToUTF8Byte = .Read()
      .Close
End With
End Function

Function FileToByte(strFileName As String)
'文件转流
   With CreateObject("Adodb.Stream")
      .Open
      .Type = 1 'adTypeBinary
      .LoadFromFile strFileName
      FileToByte = .Read
      .Close
End With
End Function

lingshimizi · 发表于 2021-1-2 19:58

当然我的目的是要图片的链接，如果有其他方法非常感谢

lingshimizi · 发表于 2021-1-2 20:00

只需要帮我把图片成功传上去就可以了，剩下的我相信自己可以解决，非常感谢

zpy2 · 发表于 2021-1-3 06:20

lingshimizi 发表于 2021-1-2 19:58
当然我的目的是要图片的链接，如果有其他方法非常感谢

curl --location --request POST "https://api.imgbb.com/1/upload?expiration=600&key=YOUR_CLIENT_API_KEY" --form "image=R0lGODlhAQABAIAAAAAAAP///yH5BAEAAAAALAAAAAABAAEAAAIBRAA7"

需要key

lingshimizi · 发表于 2021-1-3 09:18

zpy2 发表于 2021-1-3 06:20
curl --location --request POST "https://api.imgbb.com/1/upload?expiration=600&key=YOUR_CLIENT_API_ ...

非常感谢您的回复

7a850eb392949184c993cf7e43305aba
cd99d232322357c06a065b33299362b7
48cfe7fc9b454d8b813bbc2268b3389f

这个点击添加就可以了，我刚添加了三个

lingshimizi · 发表于 2021-1-3 09:34

curl --location --request POST "https://api.imgbb.com/1/upload?&key=48cfe7fc9b454d8b813bbc2268b3389f" --form "image=R0lGODlhAQABAIAAAAAAAP///yH5BAEAAAAALAAAAAABAAEAAAIBRAA7"
（里面有四个参数：
Parameters
key (required)
The API key.
image (required)
A binary file, base64 data, or a URL for an image. (up to 32 MB)
name (optional)
The name of the file, this is automatically detected if uploading a file with a POST and multipart / form-data
expiration (optional)
Enable this if you want to force uploads to be auto deleted after certain time (in seconds 60-15552000)

参量
密钥（必填）
API密钥。
图片（必填）
二进制文件，base64数据或图像的URL。（最大32 MB）
名称（可选）
文件名，如果上传带有POST和multipart / form-data的文件，则会自动检测到该文件名
到期（可选）
如果您要强制在一定时间后（60秒至55552000秒）自动删除上载，请启用此选项）

这是人家提供的josn响应示例：
（说实话，完全不知道怎么用在VBA里面）
{
  "data": {
"id": "2ndCYJK",
"title": "c1f64245afb2",
"url_viewer": "https://ibb.co/2ndCYJK",
"url": "https://i.ibb.co/w04Prt6/c1f64245afb2.gif",
"display_url": "https://i.ibb.co/98W13PY/c1f64245afb2.gif",
"size": "42",
"time": "1552042565",
"expiration":"0",
"image": {
   "filename": "c1f64245afb2.gif",
   "name": "c1f64245afb2",
   "mime": "image/gif",
   "extension": "gif",
   "url": "https://i.ibb.co/w04Prt6/c1f64245afb2.gif",
},
"thumb": {
   "filename": "c1f64245afb2.gif",
   "name": "c1f64245afb2",
   "mime": "image/gif",
   "extension": "gif",
   "url": "https://i.ibb.co/2ndCYJK/c1f64245afb2.gif",
},
"medium": {
   "filename": "c1f64245afb2.gif",
   "name": "c1f64245afb2",
   "mime": "image/gif",
   "extension": "gif",
   "url": "https://i.ibb.co/98W13PY/c1f64245afb2.gif",
},
"delete_url": "https://ibb.co/2ndCYJK/670a7e48ddcb85ac340c717a41047e5c"
  },
  "success": true,
  "status": 200
}

lingshimizi · 发表于 2021-1-3 09:49

本帖最后由 lingshimizi 于 2021-1-3 10:40 编辑

这里有个图片

响应示例也可以在那个网页上找到

changhong8 · 发表于 2021-1-3 11:02

selenium可以实现批量上传文件，你研究下

changhong8 · 发表于 2021-1-3 11:09

lingshimizi · 发表于 2021-1-3 11:24

本帖最后由 lingshimizi 于 2021-1-3 11:28 编辑

changhong8 发表于 2021-1-3 11:09

这个确实可以一次拖进去好多个，可是我的是图片在两千个文件夹里面的，每个文件夹有1到30个图片后续可能增加到两万个文件夹
只需要成功传上去得到链接就好，后续的我可以自己想办法解决

		自动登录	找回密码
密码			免费注册

[求助] 如何通过VBA上传图片到指定网址：https://666666.imgbb.com/