VBScriptからGoogleカレンダーにデータを投入するスクリプト

ちょっとツールとしてあれば便利かなぁとか思って作ったものです。
もともと、こういうのあるといいなぁって声があって、んじゃ作ってみっかなぁと考えた次第。
で、ネタもないので、今日はそれをエントリー。
エントリーするスクリプトは、今回作ったものそのままじゃないのですが、エッセンス的な。
元ネタはウェブアプリの一部抜粋。
Add Google Calendar event with VBScript | SnippetLib
ほとんどこいつを参考にしているんだけど、このままだとうまく動かないことがあったんで、
WScript.Echoデバッグ（おいおい）しながら試行錯誤したりして、とにかくスクリプト1回動かせばデータを投入できるようにしたと。
なお、元ネタにある通り、

NOTE: Google strongly recommends NOT using the username/password login authentication in web apps. Use AuthSub instead.

だそうで、ID/PWログインはなるべくウェブアプリではすんなってGoogleが言っているそうだ。
でも今回使ったスクリプトはウェブアプリじゃないしとりあえず。
以下スクリプト。

Option Explicit

Dim strUserID, strPassword, strProxy

'GoogleアカウントのユーザID、パスワード

strUserID   = "************@gmail.com"
strPassword = "************"

'プロキシ経由ならその情報
'strProxy    = "**.**.**.**:80"

'スケジュールデータ
Dim strPlanName, strPlace, strContents
Dim strStartYmdYYYY, strStartYmdMM, strStartYmdDD, strStartTimeHH, strStartTimeMM
Dim strEndYmdYYYY, strEndYmdMM, strEndYmdDD, strEndTimeHH, strEndTimeMM

Dim strStart, strEnd

strPlanName = "プロジェクト打ち合わせ"
strPlace = "A会議室"
strContents = "例のプロジェクトの作戦を考える"
strStartYmdYYYY = "2011"
strStartYmdMM = "07"
strStartYmdDD = "23"
strStartTimeHH = "09"
strStartTimeMM = "30"
strEndYmdYYYY = "2011"
strEndYmdMM = "07"
strEndYmdDD = "23"
strEndTimeHH = "11"
strEndTimeMM = "00"

'if 時刻指定のあるスケジュールの場合（年月日のみ指定のスケジュールではない場合）
	strStart     = strStartYmdYYYY & "-" & strStartYmdMM & "-" & strStartYmdDD & "T" & strStartTimeHH & ":" & strStartTimeMM & ":00.000+09:00"
	strEnd       = strEndYmdYYYY & "-" & strEndYmdMM & "-" & strEndYmdDD & "T" & strEndTimeHH & ":" & strEndTimeMM & ":00.000+09:00"
'Else　'年月日のみ指定のスケジュールの場合（時間指定がないスケジュールの場合）
'	strStart     = strStartYmdYYYY & "-" & strStartYmdMM & "-" & strStartYmdDD
'	strEnd       = strEndYmdYYYY & "-" & strEndYmdMM & "-" & strEndYmdDD
'	'Googleに送信する終了日は1日後
'	dDay		= DateAdd("d",1,DateValue(strEnd))
'	strEnd		= Year(dDay) & "-" & Right("0" & Month(dDay), 2) & "-" & Right("0" & Day(dDay), 2) 
'End If

Dim xmlhttp, lines, nvp, calentry, url, testUrl, testResponse, redirect

set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP.4.0")
'プロキシ経由なら次のコメントを外す
'xmlhttp.SetProxy 2,strProxy,""
xmlhttp.open "POST", "https://www.google.com/accounts/ClientLogin", false
xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xmlhttp.send "accountType=HOSTED_OR_GOOGLE&Email=" & strUserID & "&Passwd=" & strPassword & "&source=Gulp-CalGulp-1.05&service=cl"

If InStr(xmlhttp.responseText, "Error") > 0 then
	WScript.Echo "Googleカレンダーにログインできませんでした。" & vbcrlf & vbcrlf & "ID , Password を確認してください。"
	WScript.Quit
End If

lines = Split(xmlhttp.responseText, vbLf)
nvp = Split(lines(2), "=")

set xmlhttp = nothing

calentry = "<?xml version='1.0' ?><entry xmlns='http://www.w3.org/2005/Atom' " _
      & "xmlns:gd='http://schemas.google.com/g/2005'>" _
      & "<category scheme='http://schemas.google.com/g/2005#kind' " _
      & "term='http://schemas.google.com/g/2005#event'></category>" _
      & "<title type='text'>" & strPlanName & "</title>" _
      & "<content type='text'>" & strContents & "</content>" _
      & "<gd:transparency " _
      & "value='http://schemas.google.com/g/2005#event.opaque'>" _
      & "</gd:transparency>" _
      & "<gd:eventStatus " _
      & "value='http://schemas.google.com/g/2005#event.confirmed'>" _
      & "</gd:eventStatus>" _
      & "<gd:where valueString='" & strPlace & "'></gd:where>" _
      & "<gd:when startTime='" & strStart & "' endTime='" & strEnd & "'></gd:when>" _
      & "</entry>"

url = "https://www.google.com/calendar/feeds/default/private/full"

postEntry(url)

WScript.Echo "Googleカレンダーに登録しました。" 

function postEntry(url)

    set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP.4.0")
    xmlhttp.SetProxy 2,"moripro.sg.pref.iwate.jp:8080",""
    xmlhttp.open "POST", url, FALSE
    xmlhttp.setRequestHeader "Content-type", "application/atom+xml"
    xmlhttp.setRequestHeader "X-If-No-Redirect", "True"
    xmlhttp.setRequestHeader "Authorization", "GoogleLogin auth=" & nvp(1)
    xmlhttp.send calentry
    

    testResponse = InStr(xmlhttp.responseText, strPlanName)

    If testResponse = 0 then
        testUrl = InStr(url,"?gsessionid")

        If testUrl = 0 then
            redirect = xmlhttp.getResponseHeader("X-Redirect-Location")
            postEntry(redirect)
        Else
            postEntry(url)
        End If
    end if

    set xmlhttp = nothing
end function