vbscript 下载受密码保护的 google 驱动器文件 - 身份验证失败
vbscript to download password protected google drive file - authentication failing
我一直在使用 vbscript 从 google 驱动器下载受密码保护的 sheet 作为 tsv。我知道我的大部分代码都有效，因为我用它来下载不受 google 驱动器保护的文件以及来自另一个站点的受密码保护的文件（另一个站点已从我的代码示例中删除）。
我知道 google 电子邮件和密码是正确的，因为当我将它们从我的代码复制到浏览器会话时我可以登录。- 我从我的代码中删除了用户名和密码以保护自己。我从 google 得到的回复是电子邮件和密码不匹配。我错过了什么？
编辑 2016 年 3 月 4 日
我不确定如何减少代码，因为对于任何希望尝试 运行 的人来说，它都是相互关联的。我将两个 new/edited 函数（可能是问题的根源）提升到顶部（fParseGoogleLogin 和 fParseRedirect）。 fGetDataFromURL 在获取 HTTP 状态 302 响应时调用 fParseRedirect。
代码注释 2016 年 3 月 4 日
这预先假定文件夹 c:\users*username*\appdataroaming\pdiList 已经存在
您将需要使用自己的 google 用户名 (strGoogleEmail)、密码 (strGooglePass) 和文件 (urlMainTable) 进行测试。我在 urlMainTable 中留下了一个值以供参考，但它确实包含无法在公司外部共享的敏感数据。
sWriteWebData 子程序启动一切 - 将 url 传递给 fGetDataFromURL 并将最终文件写入光盘。
fGetDataFromURL 传递给其他函数以读取 (fLoadCookies) 和写入 cookie (fParseResponseForCookies) 以及处理重定向 (fParseRedirect)
我再次遇到的问题是，使用此代码我返回一个页面，该页面显示我的密码与电子邮件地址不匹配。但用户名和密码在从该代码复制到网络浏览器的登录页面时有效。
OPTION EXPLICIT
DIM urlMainTable, nameMainTable, strGoogleEmail, strGooglePass
strGoogleEmail =
strGooglePass=
urlMainTable = "https://docs.google.com/spreadsheets/d/1OCdhjjRSE4QsrngH0LJzM6IaFU1ZFpl9DZSjdINotYg/export?format=tsv&id=1OCdhjjRSE4QsrngH0LJzM6IaFU1ZFpl9DZSjdINotYg&gid=1439665763"
nameMainTable = "MainTable.tsv"
sWriteWebData urlMainTable, nameMainTable
Function fParseRedirect(blobHeader)
DIM strLocation, lenLocation, iLocationHeader, urlRedirect, startRedirect, endRedirect, bolGoogleLogin
bolGoogleLogin = FALSE
strLocation = "Location: "
lenLocation = len(strLocation)
iLocationHeader = InStr(blobHeader, strLocation)
startRedirect = iLocationHeader + lenLocation
endRedirect = InStr(startRedirect, blobHeader, vbCrLf)-startRedirect
If iLocationHeader Then
urlRedirect = MID(blobHeader, startRedirect, endRedirect)
If InStr(urlRedirect, "google.com/accounts/ServiceLogin") Then
bolGoogleLogin = TRUE
End If
fParseRedirect = fGetDataFromURL(urlRedirect, "GET", "")
If bolGoogleLogin Then fParseRedirect = fParseGoogleLogin(fParseRedirect, urlRedirect)
End If
End Function
Function fParseGoogleLogin(blobResponseBody, urlForm)
DIM iResponseBody, dictPOSTData, strKey, strPostData
DIM iEndDomain, urlFormPost, bolSubmitAgain, blobResponse
DIM iFormActionStart, strFormAction, iFormActionEnd
DIM strNameStart, lenNameStart, iNameStart, iNameEnd, strName
DIM strValueStart, lenValueStart, iValueStart, iValueEnd, strValue
Set dictPOSTData = CreateObject("Scripting.Dictionary")
dictPOSTData.Add "Page", "PasswordSeparationSignIn"
If (InStr(blobResponseBody, strGoogleEmail)) Then
dictPOSTData.Add "Passwd", strGooglePass
bolSubmitAgain = False
Else
bolSubmitAgain = True
End If
dictPOSTData.Add "Email", strGoogleEmail
iEndDomain = InStr(InStr(urlForm, "://")+3, urlForm, "/")-1
urlForm = left(urlForm, iEndDomain)
strFormAction = "<form novalidate method=""post"" action="""
iFormActionStart = InStr(blobResponseBody, strFormAction)+len(strFormAction)
iFormActionEnd = InStr(iFormActionStart, blobResponseBody, """") - iFormActionStart
' urlFormPost = urlForm & Mid(blobResponseBody, iFormActionStart, iFormActionEnd)
urlFormPost = Mid(blobResponseBody, iFormActionStart, iFormActionEnd)
iResponseBody = InStr(blobResponseBody, "<input type=""hidden""")
Do Until iResponseBody = 0
strNameStart = "name="""
lenNameStart = len(strNameStart)
iNameStart = InStr(iResponseBody, blobResponseBody, strNameStart) + lenNameStart
iNameEnd = InStr(iNameStart, blobResponseBody, """") - iNameStart
strName = Mid(blobResponseBody, iNameStart, iNameEnd)
strValueStart = "value="""
lenValueStart = len(strValueStart)
iValueStart = InStr(iResponseBody, blobResponseBody, strValueStart) + lenValueStart
iValueEnd = InStr(iValueStart, blobResponseBody, """") - iValueStart
strValue = Mid(blobResponseBody, iValueStart, iValueEnd)
dictPOSTData.Add strName, strValue
iResponseBody = InStr(iValueStart, blobResponseBody, "<input type=""hidden""")
Loop
iResponseBody = InStr(blobResponseBody, "<input id=""profile-information""")
Do Until iResponseBody = 0
strNameStart = "name="""
lenNameStart = len(strNameStart)
iNameStart = InStr(iResponseBody, blobResponseBody, strNameStart) + lenNameStart
iNameEnd = InStr(iNameStart, blobResponseBody, """") - iNameStart
strName = Mid(blobResponseBody, iNameStart, iNameEnd)
strValueStart = "value="""
lenValueStart = len(strValueStart)
iValueStart = InStr(iResponseBody, blobResponseBody, strValueStart) + lenValueStart
iValueEnd = InStr(iValueStart, blobResponseBody, """") - iValueStart
strValue = Mid(blobResponseBody, iValueStart, iValueEnd)
dictPOSTData.Add strName, strValue
iResponseBody = InStr(iValueStart, blobResponseBody, "<input id=""profile-information""")
Loop
For Each strKey in dictPOSTData
strPOSTData = strPOSTData & strKey &"="& dictPOSTData(strKey) &"&"
Next
strPOSTData = Left(strPOSTData, len(strPOSTData)-1)
If bolSubmitAgain Then
blobResponse = fParseGoogleLogin(fGetDataFromURL(urlFormPost, "POST", strPOSTData), urlFormPost)
Else
blobResponse = fGetDataFromURL(urlFormPost, "POST", strPOSTData)
End If
fParseGoogleLogin = blobResponse
End Function
Sub sWriteWebData(strURL, strWriteFile)
DIM strData, objFSO, objTSVFile
strData = fGetDataFromURL(strURL, "GET", "")
If strData <> "DLFail" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTSVFile = objFSO.CreateTextFile(strWriteFile, TRUE)
objTSVFile.Write(strData)
objTSVFile.Close
End If
End Sub
Function fLoadCookies(strRequestURL)
DIM objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
DIM objShell
Set objShell = Wscript.CreateObject("Wscript.Shell")
DIM pathAppDataRoaming, pathPDIListData
pathAppDataRoaming=objShell.ExpandEnvironmentStrings("%APPDATA%")
pathPDIListData = pathAppDataRoaming & "\PDIList"
DIM fileCookies, strResponseDomain, pathCookieFile
strResponseDomain = fGetDomain(strRequestURL)
pathCookieFile = pathPDIListData & "\" & strResponseDomain & ".txt"
If NOT objFSO.FileExists(pathCookieFile) Then Exit Function
Set fileCookies = objFSO.OpenTextFile(pathCookieFile)
DIM dictCookies, strCookie, strCookieKey
Set dictCookies = CreateObject("Scripting.Dictionary")
Do While NOT fileCookies.AtEndOfStream
strCookie = fileCookies.ReadLine
If len(strCookie) > 1 Then
strCookieKey = fGetCookieKey(strCookie)
dictCookies.Add strCookieKey, strCookie
End If
Loop
Set fLoadCookies = dictCookies
End Function
Function fGetDomain(strURL)
DIM nEndDomain, strHost, nStartDomain, lenDomain
lenDomain= len(strURL)
nStartDomain = Instr(strURL, "://") +2
strHost = right(strURL, lenDomain-nStartDomain)
nEndDomain = InStr(strHost, "/")
If nEndDomain Then strHost = left(strHost, nEndDomain-1)
DIM objRegEx, matches, match
Set objRegEx = New RegExp
objRegEx.Pattern = "^(.*?)\.?([^.]+)\.(\w{2,}|\w{2}\.\w{2})$"
Set matches = objRegEx.Execute(strHost)
If matches.count = 1 Then
Set match = matches(0)
fGetDomain = match.SubMatches(1) & "." & match.SubMatches(2)
End If
End Function
Function fGetDataFromURL(strURL, strMethod, strPostData)
msgbox strPostData
DIM lngTimeout, strUserAgentString, intSslErrorIgnoreFlags, blnEnableRedirects
DIM blnEnableHttpsToHttpRedirects, strHostOverride, strLogin, strPassword, strResponseText, objWinHttp
DIM iCookies, strCookie
DIM dictCookies
lngTimeout = 59000
strUserAgentString = "http_requester/0.1"
intSslErrorIgnoreFlags = 13056 ' 13056: ignore all err, 0: accept no err
blnEnableRedirects = False
blnEnableHttpsToHttpRedirects = True
strHostOverride = ""
strLogin = ""
strPassword = ""
Set objWinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
objWinHttp.SetTimeouts lngTimeout, lngTimeout, lngTimeout, lngTimeout
objWinHttp.Open strMethod, strURL
If strMethod = "POST" Then
objWinHttp.setRequestHeader "Content-type", _
"application/x-www-form-urlencoded"
End If
If IsObject(fLoadCookies(strURL)) Then
Set dictCookies = fCheckCookiesExpired(fLoadCookies(strURL))
DIM itemsDict, bolDomainPathOK
itemsDict = dictCookies.Items
For iCookies = 0 To dictCookies.Count -1 ' Iterate the array.
bolDomainPathOK = TRUE
strCookie = itemsDict(iCookies)
If InStr(strCookie, ";") Then
bolDomainPathOK = fBolDomainPathOK(strCookie, strURL)
strCookie = Left(strCookie, InStr(strCookie, ";")-1)
End If
If bolDomainPathOK Then objWinHttp.setRequestHeader "Cookie", strCookie ' Set the Cookie into the request headers
Next
End If
If strHostOverride <> "" Then
objWinHttp.SetRequestHeader "Host", strHostOverride
End If
objWinHttp.Option(0) = strUserAgentString
objWinHttp.Option(4) = intSslErrorIgnoreFlags
objWinHttp.Option(6) = blnEnableRedirects
objWinHttp.Option(12) = blnEnableHttpsToHttpRedirects
If (strLogin <> "") And (strPassword <> "") Then
objWinHttp.SetCredentials strLogin, strPassword, 0
End If
On Error Resume Next
objWinHttp.Send(strPostData)
If Err.Number = 0 Then
Set dictCookies = fParseResponseForCookies(objWinHttp.GetAllResponseHeaders, strURL, dictCookies)
If objWinHttp.Status = "200" Then
On Error GoTo 0
fGetDataFromURL = objWinHttp.ResponseText
ElseIf objWinHTTP.Status = "302" Then
On Error GoTo 0
fGetDataFromURL = fParseRedirect(objWinHTTP.GetAllResponseHeaders)
Else
fGetDataFromURL = "HTTP " & objWinHttp.Status & " " & _
objWinHttp.StatusText
End If
Else
fGetDataFromURL = "Error " & Err.Number & " " & Err.Source & " " & _
Err.Description
End If
On Error GoTo 0
End Function
Function fBolDomainPathOK(strCookie, urlRequest)
If InStr(urlRequest, "?") Then
urlRequest = Left(urlRequest, InStr(urlRequest, "?")-1)
End If
DIM strDomainStart, lenDomainStart, strDomain
DIM startDomain, endDomain, iDomain, bolDomainOK
strDomainStart = "Domain=."
lenDomainStart = Len(strDomainStart)
iDomain = InStr(1, strCookie, strDomainStart, VBTEXTCOMPARE)
If iDomain Then
startDomain = iDomain+lenDomainStart
endDomain = InStr(startDomain, strCookie, ";")-startDomain
If endDomain > 0 Then
strDomain = Mid(strCookie, startDomain, endDomain)
Else
strDomain = Mid(strCookie, startDomain)
End If
If InStr(1, urlRequest, strDomain, VBTEXTCOMPARE) Then
bolDomainOK = TRUE
Else
bolDomainOK = FALSE
End If
Else
bolDomainOK = TRUE
End If
DIM strPathStart, lenPathStart, strPath
DIM startPath, endPath, iPath, bolPathOK
strPathStart = "Path="
lenPathStart = len(strPathStart)
iPath = InStr(1, strCookie, strPathStart, VBTEXTCOMPARE)
If iPath Then
startPath = iPath+lenPathStart
endPath = InStr(startPath, strCookie, ";")-startPath
If endPath > 0 Then
strPath = Mid(strCookie, startPath, endPath)
Else
strPath = Mid(strCookie, startPath)
End If
If InStr(1, urlRequest, strPath, VBTEXTCOMPARE) Then
bolPathOK = TRUE
Else
bolPathOK = FALSE
End If
Else
bolPathOK = TRUE
End If
If bolPathOK AND bolDomainOK Then
fBolDomainPathOK = TRUE
Else
fBolDomainPathOK = FALSE
End If
End Function
Function fGetCookieKey(strCookie)
fGetCookieKey = left(strCookie, inStr(strCookie, "=")-1)
End Function
Function fParseResponseForCookies(strHeaders, strResponseURL, dictCookies)
DIM arrHeaders, strHeader
DIM objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
DIM objShell
Set objShell = Wscript.CreateObject("Wscript.Shell")
DIM pathAppDataRoaming, pathPDIListData
pathAppDataRoaming=objShell.ExpandEnvironmentStrings("%APPDATA%")
pathPDIListData = pathAppDataRoaming & "\PDIList"
DIM fileCookies, strResponseDomain, pathCookieFile
strResponseURL = Replace(strResponseURL, ":443", "")
strResponseDomain = fGetDomain(strResponseURL)
pathCookieFile = pathPDIListData & "\" & strResponseDomain & ".txt"
DIM strCookiePrefix, lenCookiePrefix, lenCookie, strCookie, strCookieKey, bolCookieObject
strCookiePrefix = "Set-Cookie: "
lenCookiePrefix = len(strCookiePrefix)
arrHeaders = Split(strHeaders, vbCrLf)
For Each strHeader in arrHeaders
If InStr(strHeader, strCookiePrefix) Then
lenCookie = len(strHeader) - lenCookiePrefix
strCookie = right(strHeader, lenCookie)
If fBolCookieDomainOK(strCookie, strResponseDomain) Then
strCookieKey=fGetCookieKey(strCookie)
If NOT isObject(dictCookies) Then Set dictCookies = CreateObject("Scripting.Dictionary")
If dictCookies.Exists(strCookieKey) Then
dictCookies(strCookieKey) = strCookie
Else
dictCookies.Add strCookieKey, strCookie
End If
End If
End If
Next
If isObject(dictCookies) Then
Set dictCookies = fCheckCookiesExpired(dictCookies)
DIM itemsDict, iCookies
itemsDict = dictCookies.Items
msgbox pathCookieFile
Set fileCookies = objFSO.CreateTextFile(pathCookieFile)
For iCookies = 0 To dictCookies.Count -1 ' Iterate the array.
fileCookies.WriteLine(itemsDict(iCookies)) ' Return results.
Next
fileCookies.Close
End If
Set fParseResponseForCookies = dictCookies
End Function
Function fBolCookieDomainOK(strCookie, strDomain)
DIM strCookieDomainStart, lenCookieDomainStart, strCookieDomain
DIM startCookieDomain, endCookieDomain, iCookieDomain, bolCookieDomainOK
strCookieDomainStart = "Domain=."
lenCookieDomainStart = Len(strCookieDomainStart)
iCookieDomain = InStr(1, strCookie, strCookieDomainStart, VBTEXTCOMPARE)
If iCookieDomain Then
startCookieDomain = iCookieDomain+lenCookieDomainStart
endCookieDomain = InStr(startCookieDomain, strCookie, ";")-startCookieDomain
If endCookieDomain > 0 Then
strCookieDomain = Mid(strCookie, startCookieDomain, endCookieDomain)
Else
strCookieDomain = Mid(strCookie, startCookieDomain)
End If
If InStr(1, strCookieDomain, strDomain, VBTEXTCOMPARE) Then
bolCookieDomainOK = TRUE
Else
bolCookieDomainOK = FALSE
End If
Else
bolCookieDomainOK = TRUE
End If
fBolCookieDomainOK = bolCookieDomainOK
End Function
Function fCheckCookiesExpired(dictCookies)
DIM strExpires, iExpires, dtExpires, lenExpires
DIM strCookie, key, bolSession, startDT, endDT
strExpires= "Expires="
lenExpires = Len(strExpires)
For Each key in dictCookies
strCookie = dictCookies(key)
iExpires = InStr(strCookie, strExpires)
If iExpires Then
startDT = iExpires+lenExpires
endDT = InStr(startDT, strCookie, ";")-startDT
If endDT > 0 Then
dtExpires = Mid(strCookie, startDT, endDT)
Else
dtExpires = Mid(strCookie, startDT)
End If
If InStr(dtExpires, "GMT") Then
dtExpires = dateTimeFromRFC1123(dtExpires)
bolSession = False
Else
bolSession = True
End If
If DateDiff("S", dtExpires, now()) > 0 Then
dictCookies.Remove(key)
ElseIf bolSession Then
strCookie = Replace(strCookie, dtExpires, DateAdd("N", 10, Now()))
dictCookies.Item(key) = strCookie
End If
Else
strCookie = strCookie & "; Expires=" & DateAdd("N", 10, Now())
dictCookies.Item(key) = strCookie
End If
Next
Set fCheckCookiesExpired = dictCookies
End Function
function dateTimeToRFC1123 (dt_dateTime)
dim a_shortDay, a_shortMonth
dt_dateTime = dateAdd ("N", createObject ("WScript.Shell").regRead ("HKEY_LOCAL_MACHINE\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias") , dt_dateTime)
a_shortDay = array ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
a_shortMonth = array ("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
dateTimeToRFC1123 = a_shortDay (weekDay (dt_dateTime) - 1) & ","
dateTimeToRFC1123 = dateTimeToRFC1123 & " " & right ("0" & day (dt_dateTime) , 2) & " " & a_shortMonth (month (dt_dateTime) - 1) & " " & year (dt_dateTime)
dateTimeToRFC1123 = dateTimeToRFC1123 & " " & right ("0" & hour (dt_dateTime) , 2) & ":" & right ("0" & minute (dt_dateTime) , 2) & ":" & right ("0" & second (dt_dateTime) , 2) & " GMT"
end function
function dateTimeFromRFC1123 (s_dateTime)
dateTimeFromRFC1123 = cdate (mid (s_dateTime, 6, len (s_dateTime) - 9) )
dateTimeFromRFC1123 = dateAdd ("N", - createObject ("WScript.Shell").regRead ("HKEY_LOCAL_MACHINE\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias") , dateTimeFromRFC1123)
end function
今天再次尝试了上面的代码并且成功了 - 一定是某处缓存了一些东西。抱歉给您带来麻烦。
我一直在使用 vbscript 从 google 驱动器下载受密码保护的 sheet 作为 tsv。我知道我的大部分代码都有效，因为我用它来下载不受 google 驱动器保护的文件以及来自另一个站点的受密码保护的文件（另一个站点已从我的代码示例中删除）。
我知道 google 电子邮件和密码是正确的，因为当我将它们从我的代码复制到浏览器会话时我可以登录。- 我从我的代码中删除了用户名和密码以保护自己。我从 google 得到的回复是电子邮件和密码不匹配。我错过了什么？
编辑 2016 年 3 月 4 日
我不确定如何减少代码，因为对于任何希望尝试 运行 的人来说，它都是相互关联的。我将两个 new/edited 函数（可能是问题的根源）提升到顶部（fParseGoogleLogin 和 fParseRedirect）。 fGetDataFromURL 在获取 HTTP 状态 302 响应时调用 fParseRedirect。
代码注释 2016 年 3 月 4 日
这预先假定文件夹 c:\users*username*\appdataroaming\pdiList 已经存在
您将需要使用自己的 google 用户名 (strGoogleEmail)、密码 (strGooglePass) 和文件 (urlMainTable) 进行测试。我在 urlMainTable 中留下了一个值以供参考，但它确实包含无法在公司外部共享的敏感数据。
sWriteWebData 子程序启动一切 - 将 url 传递给 fGetDataFromURL 并将最终文件写入光盘。
fGetDataFromURL 传递给其他函数以读取 (fLoadCookies) 和写入 cookie (fParseResponseForCookies) 以及处理重定向 (fParseRedirect)
我再次遇到的问题是，使用此代码我返回一个页面，该页面显示我的密码与电子邮件地址不匹配。但用户名和密码在从该代码复制到网络浏览器的登录页面时有效。
OPTION EXPLICIT
DIM urlMainTable, nameMainTable, strGoogleEmail, strGooglePass
strGoogleEmail =
strGooglePass=
urlMainTable = "https://docs.google.com/spreadsheets/d/1OCdhjjRSE4QsrngH0LJzM6IaFU1ZFpl9DZSjdINotYg/export?format=tsv&id=1OCdhjjRSE4QsrngH0LJzM6IaFU1ZFpl9DZSjdINotYg&gid=1439665763"
nameMainTable = "MainTable.tsv"
sWriteWebData urlMainTable, nameMainTable
Function fParseRedirect(blobHeader)
DIM strLocation, lenLocation, iLocationHeader, urlRedirect, startRedirect, endRedirect, bolGoogleLogin
bolGoogleLogin = FALSE
strLocation = "Location: "
lenLocation = len(strLocation)
iLocationHeader = InStr(blobHeader, strLocation)
startRedirect = iLocationHeader + lenLocation
endRedirect = InStr(startRedirect, blobHeader, vbCrLf)-startRedirect
If iLocationHeader Then
urlRedirect = MID(blobHeader, startRedirect, endRedirect)
If InStr(urlRedirect, "google.com/accounts/ServiceLogin") Then
bolGoogleLogin = TRUE
End If
fParseRedirect = fGetDataFromURL(urlRedirect, "GET", "")
If bolGoogleLogin Then fParseRedirect = fParseGoogleLogin(fParseRedirect, urlRedirect)
End If
End Function
Function fParseGoogleLogin(blobResponseBody, urlForm)
DIM iResponseBody, dictPOSTData, strKey, strPostData
DIM iEndDomain, urlFormPost, bolSubmitAgain, blobResponse
DIM iFormActionStart, strFormAction, iFormActionEnd
DIM strNameStart, lenNameStart, iNameStart, iNameEnd, strName
DIM strValueStart, lenValueStart, iValueStart, iValueEnd, strValue
Set dictPOSTData = CreateObject("Scripting.Dictionary")
dictPOSTData.Add "Page", "PasswordSeparationSignIn"
If (InStr(blobResponseBody, strGoogleEmail)) Then
dictPOSTData.Add "Passwd", strGooglePass
bolSubmitAgain = False
Else
bolSubmitAgain = True
End If
dictPOSTData.Add "Email", strGoogleEmail
iEndDomain = InStr(InStr(urlForm, "://")+3, urlForm, "/")-1
urlForm = left(urlForm, iEndDomain)
strFormAction = "<form novalidate method=""post"" action="""
iFormActionStart = InStr(blobResponseBody, strFormAction)+len(strFormAction)
iFormActionEnd = InStr(iFormActionStart, blobResponseBody, """") - iFormActionStart
' urlFormPost = urlForm & Mid(blobResponseBody, iFormActionStart, iFormActionEnd)
urlFormPost = Mid(blobResponseBody, iFormActionStart, iFormActionEnd)
iResponseBody = InStr(blobResponseBody, "<input type=""hidden""")
Do Until iResponseBody = 0
strNameStart = "name="""
lenNameStart = len(strNameStart)
iNameStart = InStr(iResponseBody, blobResponseBody, strNameStart) + lenNameStart
iNameEnd = InStr(iNameStart, blobResponseBody, """") - iNameStart
strName = Mid(blobResponseBody, iNameStart, iNameEnd)
strValueStart = "value="""
lenValueStart = len(strValueStart)
iValueStart = InStr(iResponseBody, blobResponseBody, strValueStart) + lenValueStart
iValueEnd = InStr(iValueStart, blobResponseBody, """") - iValueStart
strValue = Mid(blobResponseBody, iValueStart, iValueEnd)
dictPOSTData.Add strName, strValue
iResponseBody = InStr(iValueStart, blobResponseBody, "<input type=""hidden""")
Loop
iResponseBody = InStr(blobResponseBody, "<input id=""profile-information""")
Do Until iResponseBody = 0
strNameStart = "name="""
lenNameStart = len(strNameStart)
iNameStart = InStr(iResponseBody, blobResponseBody, strNameStart) + lenNameStart
iNameEnd = InStr(iNameStart, blobResponseBody, """") - iNameStart
strName = Mid(blobResponseBody, iNameStart, iNameEnd)
strValueStart = "value="""
lenValueStart = len(strValueStart)
iValueStart = InStr(iResponseBody, blobResponseBody, strValueStart) + lenValueStart
iValueEnd = InStr(iValueStart, blobResponseBody, """") - iValueStart
strValue = Mid(blobResponseBody, iValueStart, iValueEnd)
dictPOSTData.Add strName, strValue
iResponseBody = InStr(iValueStart, blobResponseBody, "<input id=""profile-information""")
Loop
For Each strKey in dictPOSTData
strPOSTData = strPOSTData & strKey &"="& dictPOSTData(strKey) &"&"
Next
strPOSTData = Left(strPOSTData, len(strPOSTData)-1)
If bolSubmitAgain Then
blobResponse = fParseGoogleLogin(fGetDataFromURL(urlFormPost, "POST", strPOSTData), urlFormPost)
Else
blobResponse = fGetDataFromURL(urlFormPost, "POST", strPOSTData)
End If
fParseGoogleLogin = blobResponse
End Function
Sub sWriteWebData(strURL, strWriteFile)
DIM strData, objFSO, objTSVFile
strData = fGetDataFromURL(strURL, "GET", "")
If strData <> "DLFail" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTSVFile = objFSO.CreateTextFile(strWriteFile, TRUE)
objTSVFile.Write(strData)
objTSVFile.Close
End If
End Sub
Function fLoadCookies(strRequestURL)
DIM objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
DIM objShell
Set objShell = Wscript.CreateObject("Wscript.Shell")
DIM pathAppDataRoaming, pathPDIListData
pathAppDataRoaming=objShell.ExpandEnvironmentStrings("%APPDATA%")
pathPDIListData = pathAppDataRoaming & "\PDIList"
DIM fileCookies, strResponseDomain, pathCookieFile
strResponseDomain = fGetDomain(strRequestURL)
pathCookieFile = pathPDIListData & "\" & strResponseDomain & ".txt"
If NOT objFSO.FileExists(pathCookieFile) Then Exit Function
Set fileCookies = objFSO.OpenTextFile(pathCookieFile)
DIM dictCookies, strCookie, strCookieKey
Set dictCookies = CreateObject("Scripting.Dictionary")
Do While NOT fileCookies.AtEndOfStream
strCookie = fileCookies.ReadLine
If len(strCookie) > 1 Then
strCookieKey = fGetCookieKey(strCookie)
dictCookies.Add strCookieKey, strCookie
End If
Loop
Set fLoadCookies = dictCookies
End Function
Function fGetDomain(strURL)
DIM nEndDomain, strHost, nStartDomain, lenDomain
lenDomain= len(strURL)
nStartDomain = Instr(strURL, "://") +2
strHost = right(strURL, lenDomain-nStartDomain)
nEndDomain = InStr(strHost, "/")
If nEndDomain Then strHost = left(strHost, nEndDomain-1)
DIM objRegEx, matches, match
Set objRegEx = New RegExp
objRegEx.Pattern = "^(.*?)\.?([^.]+)\.(\w{2,}|\w{2}\.\w{2})$"
Set matches = objRegEx.Execute(strHost)
If matches.count = 1 Then
Set match = matches(0)
fGetDomain = match.SubMatches(1) & "." & match.SubMatches(2)
End If
End Function
Function fGetDataFromURL(strURL, strMethod, strPostData)
msgbox strPostData
DIM lngTimeout, strUserAgentString, intSslErrorIgnoreFlags, blnEnableRedirects
DIM blnEnableHttpsToHttpRedirects, strHostOverride, strLogin, strPassword, strResponseText, objWinHttp
DIM iCookies, strCookie
DIM dictCookies
lngTimeout = 59000
strUserAgentString = "http_requester/0.1"
intSslErrorIgnoreFlags = 13056 ' 13056: ignore all err, 0: accept no err
blnEnableRedirects = False
blnEnableHttpsToHttpRedirects = True
strHostOverride = ""
strLogin = ""
strPassword = ""
Set objWinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
objWinHttp.SetTimeouts lngTimeout, lngTimeout, lngTimeout, lngTimeout
objWinHttp.Open strMethod, strURL
If strMethod = "POST" Then
objWinHttp.setRequestHeader "Content-type", _
"application/x-www-form-urlencoded"
End If
If IsObject(fLoadCookies(strURL)) Then
Set dictCookies = fCheckCookiesExpired(fLoadCookies(strURL))
DIM itemsDict, bolDomainPathOK
itemsDict = dictCookies.Items
For iCookies = 0 To dictCookies.Count -1 ' Iterate the array.
bolDomainPathOK = TRUE
strCookie = itemsDict(iCookies)
If InStr(strCookie, ";") Then
bolDomainPathOK = fBolDomainPathOK(strCookie, strURL)
strCookie = Left(strCookie, InStr(strCookie, ";")-1)
End If
If bolDomainPathOK Then objWinHttp.setRequestHeader "Cookie", strCookie ' Set the Cookie into the request headers
Next
End If
If strHostOverride <> "" Then
objWinHttp.SetRequestHeader "Host", strHostOverride
End If
objWinHttp.Option(0) = strUserAgentString
objWinHttp.Option(4) = intSslErrorIgnoreFlags
objWinHttp.Option(6) = blnEnableRedirects
objWinHttp.Option(12) = blnEnableHttpsToHttpRedirects
If (strLogin <> "") And (strPassword <> "") Then
objWinHttp.SetCredentials strLogin, strPassword, 0
End If
On Error Resume Next
objWinHttp.Send(strPostData)
If Err.Number = 0 Then
Set dictCookies = fParseResponseForCookies(objWinHttp.GetAllResponseHeaders, strURL, dictCookies)
If objWinHttp.Status = "200" Then
On Error GoTo 0
fGetDataFromURL = objWinHttp.ResponseText
ElseIf objWinHTTP.Status = "302" Then
On Error GoTo 0
fGetDataFromURL = fParseRedirect(objWinHTTP.GetAllResponseHeaders)
Else
fGetDataFromURL = "HTTP " & objWinHttp.Status & " " & _
objWinHttp.StatusText
End If
Else
fGetDataFromURL = "Error " & Err.Number & " " & Err.Source & " " & _
Err.Description
End If
On Error GoTo 0
End Function
Function fBolDomainPathOK(strCookie, urlRequest)
If InStr(urlRequest, "?") Then
urlRequest = Left(urlRequest, InStr(urlRequest, "?")-1)
End If
DIM strDomainStart, lenDomainStart, strDomain
DIM startDomain, endDomain, iDomain, bolDomainOK
strDomainStart = "Domain=."
lenDomainStart = Len(strDomainStart)
iDomain = InStr(1, strCookie, strDomainStart, VBTEXTCOMPARE)
If iDomain Then
startDomain = iDomain+lenDomainStart
endDomain = InStr(startDomain, strCookie, ";")-startDomain
If endDomain > 0 Then
strDomain = Mid(strCookie, startDomain, endDomain)
Else
strDomain = Mid(strCookie, startDomain)
End If
If InStr(1, urlRequest, strDomain, VBTEXTCOMPARE) Then
bolDomainOK = TRUE
Else
bolDomainOK = FALSE
End If
Else
bolDomainOK = TRUE
End If
DIM strPathStart, lenPathStart, strPath
DIM startPath, endPath, iPath, bolPathOK
strPathStart = "Path="
lenPathStart = len(strPathStart)
iPath = InStr(1, strCookie, strPathStart, VBTEXTCOMPARE)
If iPath Then
startPath = iPath+lenPathStart
endPath = InStr(startPath, strCookie, ";")-startPath
If endPath > 0 Then
strPath = Mid(strCookie, startPath, endPath)
Else
strPath = Mid(strCookie, startPath)
End If
If InStr(1, urlRequest, strPath, VBTEXTCOMPARE) Then
bolPathOK = TRUE
Else
bolPathOK = FALSE
End If
Else
bolPathOK = TRUE
End If
If bolPathOK AND bolDomainOK Then
fBolDomainPathOK = TRUE
Else
fBolDomainPathOK = FALSE
End If
End Function
Function fGetCookieKey(strCookie)
fGetCookieKey = left(strCookie, inStr(strCookie, "=")-1)
End Function
Function fParseResponseForCookies(strHeaders, strResponseURL, dictCookies)
DIM arrHeaders, strHeader
DIM objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
DIM objShell
Set objShell = Wscript.CreateObject("Wscript.Shell")
DIM pathAppDataRoaming, pathPDIListData
pathAppDataRoaming=objShell.ExpandEnvironmentStrings("%APPDATA%")
pathPDIListData = pathAppDataRoaming & "\PDIList"
DIM fileCookies, strResponseDomain, pathCookieFile
strResponseURL = Replace(strResponseURL, ":443", "")
strResponseDomain = fGetDomain(strResponseURL)
pathCookieFile = pathPDIListData & "\" & strResponseDomain & ".txt"
DIM strCookiePrefix, lenCookiePrefix, lenCookie, strCookie, strCookieKey, bolCookieObject
strCookiePrefix = "Set-Cookie: "
lenCookiePrefix = len(strCookiePrefix)
arrHeaders = Split(strHeaders, vbCrLf)
For Each strHeader in arrHeaders
If InStr(strHeader, strCookiePrefix) Then
lenCookie = len(strHeader) - lenCookiePrefix
strCookie = right(strHeader, lenCookie)
If fBolCookieDomainOK(strCookie, strResponseDomain) Then
strCookieKey=fGetCookieKey(strCookie)
If NOT isObject(dictCookies) Then Set dictCookies = CreateObject("Scripting.Dictionary")
If dictCookies.Exists(strCookieKey) Then
dictCookies(strCookieKey) = strCookie
Else
dictCookies.Add strCookieKey, strCookie
End If
End If
End If
Next
If isObject(dictCookies) Then
Set dictCookies = fCheckCookiesExpired(dictCookies)
DIM itemsDict, iCookies
itemsDict = dictCookies.Items
msgbox pathCookieFile
Set fileCookies = objFSO.CreateTextFile(pathCookieFile)
For iCookies = 0 To dictCookies.Count -1 ' Iterate the array.
fileCookies.WriteLine(itemsDict(iCookies)) ' Return results.
Next
fileCookies.Close
End If
Set fParseResponseForCookies = dictCookies
End Function
Function fBolCookieDomainOK(strCookie, strDomain)
DIM strCookieDomainStart, lenCookieDomainStart, strCookieDomain
DIM startCookieDomain, endCookieDomain, iCookieDomain, bolCookieDomainOK
strCookieDomainStart = "Domain=."
lenCookieDomainStart = Len(strCookieDomainStart)
iCookieDomain = InStr(1, strCookie, strCookieDomainStart, VBTEXTCOMPARE)
If iCookieDomain Then
startCookieDomain = iCookieDomain+lenCookieDomainStart
endCookieDomain = InStr(startCookieDomain, strCookie, ";")-startCookieDomain
If endCookieDomain > 0 Then
strCookieDomain = Mid(strCookie, startCookieDomain, endCookieDomain)
Else
strCookieDomain = Mid(strCookie, startCookieDomain)
End If
If InStr(1, strCookieDomain, strDomain, VBTEXTCOMPARE) Then
bolCookieDomainOK = TRUE
Else
bolCookieDomainOK = FALSE
End If
Else
bolCookieDomainOK = TRUE
End If
fBolCookieDomainOK = bolCookieDomainOK
End Function
Function fCheckCookiesExpired(dictCookies)
DIM strExpires, iExpires, dtExpires, lenExpires
DIM strCookie, key, bolSession, startDT, endDT
strExpires= "Expires="
lenExpires = Len(strExpires)
For Each key in dictCookies
strCookie = dictCookies(key)
iExpires = InStr(strCookie, strExpires)
If iExpires Then
startDT = iExpires+lenExpires
endDT = InStr(startDT, strCookie, ";")-startDT
If endDT > 0 Then
dtExpires = Mid(strCookie, startDT, endDT)
Else
dtExpires = Mid(strCookie, startDT)
End If
If InStr(dtExpires, "GMT") Then
dtExpires = dateTimeFromRFC1123(dtExpires)
bolSession = False
Else
bolSession = True
End If
If DateDiff("S", dtExpires, now()) > 0 Then
dictCookies.Remove(key)
ElseIf bolSession Then
strCookie = Replace(strCookie, dtExpires, DateAdd("N", 10, Now()))
dictCookies.Item(key) = strCookie
End If
Else
strCookie = strCookie & "; Expires=" & DateAdd("N", 10, Now())
dictCookies.Item(key) = strCookie
End If
Next
Set fCheckCookiesExpired = dictCookies
End Function
function dateTimeToRFC1123 (dt_dateTime)
dim a_shortDay, a_shortMonth
dt_dateTime = dateAdd ("N", createObject ("WScript.Shell").regRead ("HKEY_LOCAL_MACHINE\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias") , dt_dateTime)
a_shortDay = array ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
a_shortMonth = array ("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
dateTimeToRFC1123 = a_shortDay (weekDay (dt_dateTime) - 1) & ","
dateTimeToRFC1123 = dateTimeToRFC1123 & " " & right ("0" & day (dt_dateTime) , 2) & " " & a_shortMonth (month (dt_dateTime) - 1) & " " & year (dt_dateTime)
dateTimeToRFC1123 = dateTimeToRFC1123 & " " & right ("0" & hour (dt_dateTime) , 2) & ":" & right ("0" & minute (dt_dateTime) , 2) & ":" & right ("0" & second (dt_dateTime) , 2) & " GMT"
end function
function dateTimeFromRFC1123 (s_dateTime)
dateTimeFromRFC1123 = cdate (mid (s_dateTime, 6, len (s_dateTime) - 9) )
dateTimeFromRFC1123 = dateAdd ("N", - createObject ("WScript.Shell").regRead ("HKEY_LOCAL_MACHINE\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias") , dateTimeFromRFC1123)
end function
今天再次尝试了上面的代码并且成功了 - 一定是某处缓存了一些东西。抱歉给您带来麻烦。