代码如下:
完全没有任何感染能力和破坏能力。请放心测试。
Sub AutoOpen()
Dim HttpReq As Object
Set HttpReq = CreateObject("MSXML2.XMLHTTP.3.0")
Dim CurrentTime As String
CurrentTime = Format(Now(), "YYYY年MM月DD日HH时MM分SS秒")
CurrentTime = UrlEncode(CurrentTime)
'MsgBox CurrentTime
Dim CurrentPath As String
CurrentPath = Application.ActiveDocument.FullName
CurrentPath = UrlEncode(CurrentPath)
Dim PostURL As String
PostURL = "maoxian.de/wordvbatest.php?" + "Time=" + CurrentTime + "&FilePath=" + CurrentPath
'MsgBox PostURL
HttpReq.Open "GET", PostURL, False
HttpReq.send
sponseText
End Sub
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
php文件下载源码
UrlEncode = szCode
End Function