VBA调用 M3U8批量下载器方式实现下载加密m3u8
前面有一篇文章说到，可以用VBA的http方式调用M3U8批量下载器 V1.4.5https://www.52pojie.cn/thread-1256288-1-1.html但是这种方式只能对链接进行post，如果遇到是对m3u8内容加密的，那么这种方式就无效了。
在对于前一篇文章说到https://www.52pojie.cn/thread-1258605-1-1.html，是对m3u8内容加密的，那么这种情况如何使用http方式调用M3U8批量下载器 V1.4.5进行下载呢？
首先根据上一篇文章，已经对m3u8内容进行解密了，这里就详细说如何postm3u8内容
Sub cutepostdata()
Dim htmlurl As String
Dim body() As Byte
Dim response As String
'目标网站
htmlurl = "https://www.h2sheji.com/demo/player/dplayer/drm.php?utype=m3u8&url=https://www.h2sheji.com/demo/player/m3u8/drmss.m3u8"
Dim http As Object
'获取网页源代码
Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
With http
.Open "GET", htmlurl, False
.Send
body = .responseBody
response = encoding(body, "utf-8")
End With
Dim reg As Object
Dim m3u8url As String
'正则匹配m3u8地址
Set reg = CreateObject("VbScript.regexp")'创建正则项目
With reg
.Pattern = "'vurl':'.+(?=,)" '正则表达式
m3u8url = .Execute(response)(0)
End With
m3u8url = Mid(m3u8url, 9, Len(m3u8url) - 9)
'获取m3u8文本
With http
.Open "GET", m3u8url, False
.Send
body = .responseBody
response = encoding(body, "utf-8")
End With
Dim m3u8text As String
'根据js替换字符串
m3u8text = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(response, "_", "A"), "-", "h"), "*", "I"), "!", "N"), "@", "O"), "(", "s"), ")", "X"), "/", "B")
'base64解码
m3u8text = encoding(b64decode(m3u8text), "utf-8")
'根据要求要构建一个json，因为vba无法进行对象的反序列化（如果有大佬会的，可以在评论区教我，先谢谢），所以用最原始的方式拼接字符串
Dim data As String
data = "{""data"":""" & m3u8text & """}"
Dim title As String
title = "demodrm"
'根据要求对内容进行gbk编码,然后base64编码，最后加上"base64:"的前缀
data = "base64:" & b64encode(encodegbk(data))
'根据要求对标题和内容进行拼接
data = title & "," & data
'根据要求再次对内容进行gbk编码,然后base64编码，拼接最终的请求体，并需要进行URL编码
data = "data=" & Application.WorksheetFunction.EncodeURL(b64encode(encodegbk(data)))
With http
'按要求使用post方式，选择同步模式
.Open "POST", "http://127.0.0.1:8787/", False
'必须设置请求头，请求类型是提交表单
.setRequestheader "Content-Type", "application/x-www-form-urlencoded"
'发送请求体
.Send (data)
'解析响应体
body = .responseBody
response = encoding(body, "gbk")
End With
Debug.Print response
End Sub
其中需要用到的自定义函数
Public Function encodegbk(body As String) As Byte() '将字符串gbk编码转换为字节数组
Dim i As Long
Dim gbkbyte() As Byte
Dim gbkl As Long
gbkl = 0
For i = 1 To Len(body)
Dim thischr As String
thischr = Mid(body, i, 1)
If Asc(thischr) < &HFF And Asc(thischr) > 0 Then
ReDim Preserve gbkbyte(0 To gbkl)
gbkbyte(gbkl) = Asc(thischr)
gbkl = gbkl + 1
Else
thischr = hex(Asc(thischr))
ReDim Preserve gbkbyte(0 To gbkl + 1)
gbkbyte(gbkl) = Application.WorksheetFunction.Hex2Dec(Mid(thischr, 1, 2))
gbkbyte(gbkl + 1) = Application.WorksheetFunction.Hex2Dec(Mid(thischr, 3, 2))
gbkl = gbkl + 2
End If
Next i
encodegbk = gbkbyte
End Function
Public Function encoding(body() As Byte, CodeBase As String) As String
Dim ado As Object
Set ado = CreateObject("Adodb.Stream")
With ado '把提取到的数据转换编码
.Type = 1 '二进制
.mode = 3 '读写模式
.Open '打开对象
.Write body '写入需要转换编码的数据
.Position = 0 '位置的起始
.Type = 2 '字符串
.Charset = CodeBase '需转换成的编码
encoding = .readtext '编码转换结果
End With
End Function
Public Function b64encode(body() As Byte) As String
'获取字节数组长度
Dim top As Long
top = UBound(body)
'将二进制数组转换为二进制8位编码字符串
Dim byte2() As String
ReDim byte2(0 To top)
Dim temp As Long
For temp = 0 To top Step 1
byte2(temp) = Application.WorksheetFunction.Dec2Bin(body(temp), 8)
Next temp
'二进制8位编码字符串合并，并用“x”补全长度body为3的倍数的8倍
Dim bodylist As String
bodylist = Join(byte2, "")
If (top + 1) Mod 3 <> 0 Then
bodylist = bodylist & Application.WorksheetFunction.Rept("x", (3 - (top + 1) Mod 3) * 8)
End If
'将bodylist由6个一组拆分
ReDim byte2(0 To Len(bodylist) / 6 - 1)
For temp = 0 To Len(bodylist) / 6 - 1 Step 1
byte2(temp) = Mid(bodylist, temp * 6 + 1, 6)
Next temp
'将base64数组转换为base64索引
Dim base64key() As Byte
ReDim base64key(0 To Len(bodylist) / 6 - 1)
For temp = 0 To Len(bodylist) / 6 - 1 Step 1
If byte2(temp) = "xxxxxx" Then
base64key(temp) = "64"
Else
base64key(temp) = Application.WorksheetFunction.Bin2Dec(Replace(byte2(temp), "x", "0"))
End If
Next temp
'载入base64索引表
Dim Base64Char As String
Base64Char = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
Dim arrBase64Char() As Byte
arrBase64Char = VBA.StrConv(Base64Char, vbFromUnicode)
'转换为base64编码且合并
Dim base64() As String
ReDim base64(0 To Len(bodylist) / 6 - 1)
For temp = 0 To Len(bodylist) / 6 - 1 Step 1
base64(temp) = Chr(arrBase64Char(base64key(temp)))
Next temp
'输出base64字符串
b64encode = Join(base64, "")
End Function
Public Function b64decode(body As String) As Byte()
'获取base64字符串长度
Dim top As Long
top = Len(body)
'载入base64索引表
Dim Base64Char As String
Base64Char = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
'将base64字符串切分为base64索引数组
Dim base64()
ReDim base64(0 To top - 1)
Dim temp As Long
For temp = 0 To top - 1 Step 1
base64(temp) = InStr(1, Base64Char, Mid(body, temp + 1, 1), vbBinaryCompare) - 1
Next temp
'将索引转换为二进制6位字符串
For temp = 0 To top - 1 Step 1
If base64(temp) = 64 Then
base64(temp) = "xxxxxx"
Else
base64(temp) = Application.WorksheetFunction.Dec2Bin(base64(temp), 6)
End If
Next temp
'合并二进制6位字符串且去除尾部填充
Dim base64list As String
base64list = Replace(Join(base64, ""), "x", "")
If Len(base64list) Mod 8 <> 0 Then
base64list = Left(base64list, (Len(base64list) \ 8) * 8)
End If
'将bodylist由8个一组拆分
ReDim base64(0 To Len(base64list) / 8 - 1)
For temp = 0 To Len(base64list) / 8 - 1 Step 1
base64(temp) = Mid(base64list, temp * 8 + 1, 8)
Next temp
'将二进制8位编码字符串转换为字节数组
Dim bytes() As Byte
ReDim bytes(0 To Len(base64list) / 8 - 1)
For temp = 0 To Len(base64list) / 8 - 1 Step 1
bytes(temp) = Application.WorksheetFunction.Bin2Dec(base64(temp))
Next temp
'输出字节数组
b64decode = bytes
End Function
哥，不会用网站批量下载器了，上个月用还能会。
私信发不了图片，我发到您这篇关于批量下载的帖子下面问您吧，望您解答
我下载中国大学慕课的视频，不是付费的，应该是输入那个课程的i即可
但是我输入读出目录，再输入我要下载的视频，我输入0-43如下图就出现说可能操作有误
我看操作了，应该不需要填cookie和token呀，但是不行，请您指出我的操作错误
前几个月还会用，现在好像我傻了，抱歉多次打扰您{:301_975:}
本帖最后由 ycf0616 于 2020-12-29 19:39 编辑
我又来了，老哥，自己试了楞长时间，还是没有下成功
我又好好读了一下您写的cookie编辑和软件介绍
还是配置文件出错
“
读取cookie配置文件出错，尝试直接读取cookie
cookie读取成功
”
我心态崩了呀，记得以前就是cookie里面把网页cookie黏贴进去就可以，还有改那个txt的格式为utf-8
现在还是不行，哎 本帖最后由 miqi1314 于 2020-9-15 14:51 编辑
厉害，支持原创！ {:1_921:}太厉害了，不懂大佬在说啥 看着很高深的样子 顶一下 虽然看不懂但是肯定很牛逼 真是佩服，想学却不会，尴尬。 能微信联系吗？ 的确牛逼，一直在关注，从来没看懂:lol 楼主，您的软件上能不能加个考虫的下载 看看学习学习