调用QQ DLL 截屏返回BASE64

[Visual Basic] 纯文本查看 复制代码

Option Explicit
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function CameraSubArea Lib "CameraDll.dll" (ByVal a As Long) As Long
Private Declare Function MessageBox Lib "user32.dll" Alias "MessageBoxA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) As Long

Function ShortName(LongPath As String) As String
Dim ShortPath As String
Dim pos As String
Dim Ret As Long
Const MAX_PATH = 260
If LongPath = "" Then Exit Function
ShortPath = Space$(MAX_PATH)
Ret& = GetShortPathName(LongPath, ShortPath, MAX_PATH)
If Ret& Then
pos = InStr(1, ShortPath, " ")
ShortName = Left$(ShortPath, pos - 2)
End If
End Function

Private Sub Command1_Click()
ShellEx "rundll32.exe " & ShortName(App.Path & "\CameraDll.dll") & " CameraSubArea"
Call Command2_Click
End Sub

Private Sub Command2_Click()
Me.Picture1.Picture = Clipboard.GetData()
SavePicture Clipboard.GetData(), "d:\1.png"
Dim s As IStream
Set s = PictureToStream(Me.Picture1.Picture)
Set Me.Picture2.Picture = StreamToPicture(s)
End Sub

Private Sub Command3_Click()
Dim stri As String
stri = Base64Encode("d:\1.png", "C:\Users\lenovo\Desktop\vb\2E3.ORG\1.txt")
Dim a As String, b As String
Dim TextLine
Open App.Path & "\1.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, TextLine
a = a & TextLine
Loop
Close #1

Debug.Print Trim(a)
End Sub




Option Explicit
Private Const BASE64CHR As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
Private psBase64Chr(0 To 63) As String
Private Declare Function GetProcessVersion Lib "kernel32" (ByVal ProcessId As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Function ShellEx(ByVal FileName As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus, Optional ByVal DelayTime As Long = -1)
'与SHELL函数一样的参数,不过是阻塞执行.(同步)
'FileName - 目标文件名
'WindowStyle - 程序运行时窗口的样式
'DelayTime - 等待的时间,单位为ms
'备注:
' DelayTime设置为-1时表示一直等待,直到目标程序运行结束
Dim i As Long, j As Long

i = Shell(FileName, WindowStyle)
Do
If GetProcessVersion(i) = 0 Then Exit Do
Sleep 10
j = j + 1
DoEvents
If DelayTime <> -1 And j > DelayTime \ 10 Then Exit Do
Loop
End Function

Public Function ShellOnce(ByVal FileName As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus)
'与SHELL函数一样的参数,但只将目标执行一次
'FileName - 目标文件名
'WindowStyle - 程序运行时窗口的样式
Static i As Long

If i <> 0 Then '如果有PID值就判断其是否正在执行
If GetProcessVersion(i) <> 0 Then Exit Function '如果正在执行,函数返回
End If
i = Shell(FileName, WindowStyle)
End Function

'从一个经过Base64的字符串中解码到源字符串
Public Function DecodeBase64String(str2Decode As String) As String
DecodeBase64String = StrConv(DecodeBase64Byte(str2Decode), vbUnicode)
End Function

'从一个经过Base64的字符串中解码到源字节数组
Public Function DecodeBase64Byte(str2Decode As String) As Byte()

Dim lPtr As Long
Dim iValue As Integer
Dim iLen As Integer
Dim iCtr As Integer
Dim Bits(1 To 4) As Byte
Dim strDecode As String
Dim Str As String
Dim Output() As Byte

Dim iIndex As Long

Dim lFrom As Long
Dim lTo As Long

InitBase

'//除去回车
Str = Replace(str2Decode, vbCrLf, "")

'//每4个字符一组（4个字符表示3个字）
For lPtr = 1 To Len(Str) Step 4
iLen = 4
For iCtr = 0 To 3
'//查找字符在BASE64字符串中的位置
iValue = InStr(1, BASE64CHR, Mid$(Str, lPtr + iCtr, 1), vbBinaryCompare)
Select Case iValue 'A~Za~z0~9+/
Case 1 To 64:
Bits(iCtr + 1) = iValue - 1
Case 65 '=
iLen = iCtr
Exit For
'//没有发现
Case 0: Exit Function
End Select
Next

'//转换4个6比特数成为3个8比特数
Bits(1) = Bits(1) * &H4 + (Bits(2) And &H30) \ &H10
Bits(2) = (Bits(2) And &HF) * &H10 + (Bits(3) And &H3C) \ &H4
Bits(3) = (Bits(3) And &H3) * &H40 + Bits(4)

'//计算数组的起始位置
lFrom = lTo
lTo = lTo + (iLen - 1) - 1

'//重新定义输出数组
ReDim Preserve Output(0 To lTo)

For iIndex = lFrom To lTo
Output(iIndex) = Bits(iIndex - lFrom + 1)
Next

lTo = lTo + 1

Next
DecodeBase64Byte = Output
End Function

'将一个Base64字符串解码，并写入二进制文件
Public Sub DecodeBase64StringToFile(strBase64 As String, strFilePath As String)
Dim fso As New Scripting.FileSystemObject, _
i As Long

If fso.FileExists(strFilePath) Then
fso.DeleteFile strFilePath, True
End If

i = FreeFile
Open strFilePath For Binary Access Write As i
Put i, , DecodeBase64Byte(strBase64)
Close i
Set fso = Nothing
End Sub

'将一个Base64编码文件解码，并写入二进制文件
Public Sub DecodeBase64FileToFile(strBase64FilePath As String, strFilePath As String)
Dim fso As New Scripting.FileSystemObject
Dim ts As TextStream

If Not fso.FileExists(strBase64FilePath) Then Exit Sub

Set ts = fso.OpenTextFile(strBase64FilePath)
DecodeBase64StringToFile ts.ReadAll, strFilePath
End Sub

'将一个字节数组进行Base64编码，并返回字符串
Public Function EncodeBase64Byte(sValue() As Byte) As String
Dim lCtr As Long
Dim lPtr As Long
Dim lLen As Long
Dim sEncoded As String
Dim Bits8(1 To 3) As Byte
Dim Bits6(1 To 4) As Byte

Dim i As Integer

InitBase

For lCtr = 1 To UBound(sValue) + 1 Step 3
For i = 1 To 3
If lCtr + i - 2 <= UBound(sValue) Then
Bits8(i) = sValue(lCtr + i - 2)
lLen = 3
Else
Bits8(i) = 0
lLen = lLen - 1
End If
Next

'//转换字符串为数组，然后转换为4个6位(0-63)
Bits6(1) = (Bits8(1) And &HFC) \ 4
Bits6(2) = (Bits8(1) And &H3) * &H10 + (Bits8(2) And &HF0) \ &H10
Bits6(3) = (Bits8(2) And &HF) * 4 + (Bits8(3) And &HC0) \ &H40
Bits6(4) = Bits8(3) And &H3F

'//添加4个新字符
For lPtr = 1 To lLen + 1
sEncoded = sEncoded & psBase64Chr(Bits6(lPtr))
Next
Next

'//不足4位，以=填充
Select Case lLen + 1
Case 2: sEncoded = sEncoded & "=="
Case 3: sEncoded = sEncoded & "="
Case 4:
End Select

EncodeBase64Byte = sEncoded
End Function

'对字符串进行Base64编码并返回字符串
Public Function EncodeBase64String(str2Encode As String) As String
Dim sValue() As Byte
sValue = StrConv(str2Encode, vbFromUnicode)
EncodeBase64String = EncodeBase64Byte(sValue)
End Function

'对文件进行Base64编码并返回编码后的Base64字符串
Public Function EncodFileToBase64String(strFileSource As String) As String
Dim lpdata() As Byte, _
i As Long, _
n As Long, _
fso As New Scripting.FileSystemObject

If Not fso.FileExists(strFileSource) Then Exit Function

i = FreeFile

Open strFileSource For Binary Access Read Lock Write As i

n = LOF(i) - 1

ReDim lpdata(0 To n)
Get i, , lpdata
Close i

EncodFileToBase64String = EncodeBase64Byte(lpdata)
End Function

'对文件进行Base64编码，并将编码后的内容直接写入一个文本文件中
Public Sub EncodFileToBase64File(strFileSource As String, strFileBase64Desti As String)
Dim fso As New FileSystemObject, _
ts As TextStream

Set ts = fso.CreateTextFile(strFileBase64Desti, True)
ts.Write (EncodFileToBase64String(strFileSource))
ts.Close
Set ts = Nothing
Set fso = Nothing
End Sub

Private Sub InitBase()
Dim iPtr As Integer
'初始化 BASE64数组
For iPtr = 0 To 63
psBase64Chr(iPtr) = Mid$(BASE64CHR, iPtr + 1, 1)
Next
End Sub


'----------------------------------------------------------------

'Base64编码函数，参数sFileName:与编码文件路径，sCodeName:编码文件存储路径
Function Base64Encode(ByVal sFileName As String, ByVal sCodeName As String) As String
Dim sCodeTable(0 To 63) As Byte '编码表
Dim tmpBytes3(1 To 3) As Byte '临时存储原字节码
Dim tmpBytes4(1 To 4) As Byte '临时存储字节分解吗

Dim i As Long, k As Long
Dim sFileLen As Long '文件长度
Dim n As Long
Dim m As Long

Dim result As String '返回生成Base64
'初始化编码表
For i = 0 To 25
sCodeTable(i) = i + 65 '大写字母
sCodeTable(i + 26) = i + 97 '小写字母
Next
For i = 52 To 61
sCodeTable(i) = i - 4
Next
sCodeTable(62) = Asc("+")
sCodeTable(63) = Asc("/")

'文件长度
sFileLen = FileLen(sFileName)
n = sFileLen \ 3 '整除3
m = sFileLen Mod 3 '除以3的余数

'打开文件
Open sFileName For Binary As #1 Len = 32760
Open sCodeName For Binary As #2 Len = 32760

For i = 1 To n
Get #1, , tmpBytes3 '读取3个字节到tmpBytes
'八3个字节分解为4个字节
tmpBytes4(1) = (tmpBytes3(1) And 252) / 4 '截取前6bit
tmpBytes4(2) = (tmpBytes3(1) And 3) * 16 + (tmpBytes3(2) And 240) / 16 '截取第二个6bit
tmpBytes4(3) = (tmpBytes3(2) And 15) * 4 + (tmpBytes3(3) And 192) / 64 '截取第三个6bit
tmpBytes4(4) = tmpBytes3(3) And 63 '截取第三个6bit
For k = 1 To 4
tmpBytes4(k) = sCodeTable(tmpBytes4(k))
Next
Put #2, , tmpBytes4 '将编码写入编码文件
'DoEvents '测试时使用，编译时可以注释掉===========================================
Next

'如果文件大小不是3的整数倍
If m = 1 Then
Get #1, , tmpBytes3(1)
tmpBytes3(2) = 0
tmpBytes4(1) = (tmpBytes3(1) And 252) / 4 '截取前6bit
tmpBytes4(2) = (tmpBytes3(1) And 3) * 16 + (tmpBytes3(2) And 240) / 16 '截取第二个6bit
Put #2, , sCodeTable(tmpBytes4(1))
Put #2, , sCodeTable(tmpBytes4(2))
Put #2, , CByte(Asc("="))
Put #2, , CByte(Asc("="))
ElseIf m = 2 Then
Get #1, , tmpBytes3(1)
Get #1, , tmpBytes3(2)
tmpBytes3(3) = 0
tmpBytes4(1) = (tmpBytes3(1) And 252) / 4 '截取前6bit
tmpBytes4(2) = (tmpBytes3(1) And 3) * 16 + (tmpBytes3(2) And 240) / 16 '截取第二个6bit
tmpBytes4(3) = (tmpBytes3(2) And 15) * 4 + (tmpBytes3(3) And 192) / 64 '截取第三个6bit
Put #2, , sCodeTable(tmpBytes4(1))
Put #2, , sCodeTable(tmpBytes4(2))
Put #2, , sCodeTable(tmpBytes4(3))
Put #2, , CByte(Asc("="))
End If
'关闭文件
Close #2
Close #1
Base64Encode = result

End Function


Public Function strCut(strContent, strStart, strEnd) As String '通用字符截取函数 by 混子√
Dim strHTML, S1, S2 As String
strHTML = strContent
On Error Resume Next
S1 = InStr(strHTML, strStart) + Len(strStart)
S2 = InStr(S1, strHTML, strEnd)
strCut = Mid(strHTML, S1, S2 - S1)
End Function

自己顶.....................