<JOB>
<COMMENT>
************************************************************
 URLEncode用
************************************************************
</COMMENT>
<OBJECT id="Stream" progid="ADODB.Stream" />
<OBJECT id="Stream2" progid="ADODB.Stream" />
<OBJECT id="StreamBin" progid="ADODB.Stream" />
<COMMENT>
************************************************************
 HTTP通信用
************************************************************
</COMMENT>
<OBJECT id="objHTTP" progid="Msxml2.ServerXMLHTTP" />
<OBJECT id="objDOMDoc" progid="Msxml2.DOMDocument" />

<SCRIPT language=VBScript>
' **********************************************************
' 認証データ
' **********************************************************
strEmail = "メールアドレス"	' またはユーザーID
strPass = "パスワード"
strVersion = "winofsql-imgupload-1.01"	' 内容は自由
' *********************************************************
' アップロード用データ
' ※ アルバムの RSS リンクより取得
' ( /user/ユーザーid/albumid/アルバムid )
' *********************************************************
strUserid = "ユーザーID"
strAlbumid = "アルバムID"
strImage = "画像のパス"
strImageTitle = "VBS_UPLOAD_IMAGE.jpg"	' Filename
strImageType = "image/jpeg"


' **********************************************************
' Google 認証用 URL
' **********************************************************
target_url = "https://www.google.com/accounts/ClientLogin"

' *********************************************************
' API へ向けて送信準備
' *********************************************************
Call objHTTP.Open( "POST",target_url, False )
' POST 用 HTTP ヘッダ
Call objHTTP.setRequestHeader("Content-Type", "application/x-www-form-urlencoded")

' *********************************************************
' 認証用データとその長さ
' *********************************************************
strData = "accountType=GOOGLE"
strData = strData & "&Email=" & rfc3986_convert(URLEncode(strEmail))
strData = strData & "&Passwd=" & rfc3986_convert(URLEncode(strPass))
strData = strData & "&service=lh2"
strData = strData & "&source=" &  rfc3986_convert(URLEncode(strVersion))
Call objHTTP.SetRequestHeader("Content-Length",Len(strData))

' *********************************************************
' 認証用データの送信
' *********************************************************
Dim lResolve : lResolve = 60 * 1000
Dim lConnect : lConnect = 60 * 1000
Dim lSend : lSend = 60 * 1000
Dim lReceive : lReceive = 60 * 1000
Call objHTTP.setTimeouts(lResolve, lConnect, lSend, lReceive)
Call objHTTP.Send(strData)

' *********************************************************
' 実処理に必要な認証済みトークンの取得
' *********************************************************
strResult = objHTTP.responseText

aData = Split(strResult,vbLf)
aAuth = Split(aData(2),"=")

' Authorization:
strAuth = "GoogleLogin auth=" & aAuth(1)
Wscript.Echo("ログインの結果" & vbCrLf & vbCrLf & strAuth)


' *********************************************************
' 画像アップロード用データ
' *********************************************************
'strUserid = "ユーザーID"
'strAlbumid = "アルバムID"	' Gata テスト用
target_url = "http://picasaweb.google.com/data/feed/api/user/"
target_url = target_url & strUserid & "/albumid/" & strAlbumid

Call objHTTP.Open( "POST",target_url, False )
Call objHTTP.SetRequestHeader("Authorization", strAuth )
Call objHTTP.SetRequestHeader("Content-Type", strImageType )
Call objHTTP.SetRequestHeader("Slug", strImageTitle )

' 最終バイナリストリーム
StreamBin.Open
StreamBin.Type = 1

' 画像を読み込む
StreamBin.LoadFromFile(strImage)

nLen = StreamBin.Size	' 画像サイズ
StreamBin.Position = 0
strData = StreamBin.Read(nLen)	' バイト配列を取得
StreamBin.Close

Call objHTTP.SetRequestHeader("Content-Length",nLen)

' *********************************************************
' アップロード実行
' *********************************************************
lResolve = 60 * 1000
lConnect = 60 * 1000
lSend = 60 * 1000
lReceive = 60 * 1000
Call objHTTP.setTimeouts(lResolve, lConnect, lSend, lReceive)
Call objHTTP.Send(strData)

' *********************************************************
' 結果の XML( テキスト )
' *********************************************************
Wscript.Echo("結果の XML" & vbCrLf & vbCrLf & objHTTP.responseText)

' *********************************************************
' DOM としてロードして title 取得
' *********************************************************
objDOMDoc.async = False
objDOMDoc.loadXML(objHTTP.responseText)
If (objDOMDoc.parseError.errorCode <> 0) Then
	Wscript.Echo("XMLロードエラー")
Else
	Set objNode = objDOMDoc.getElementsByTagName("title").item(0)
	Wscript.Echo("結果のタイトル" & vbCrLf & vbCrLf & objNode.firstChild.nodeValue)
End If


' ***********************************************************
' SHIFT_JIS を UTF-8 に変換して URLエンコード
' ※ 全ての文字をパーセントエンコーディングします
' ***********************************************************
Function URLEncode(str)

	Stream.Open
	Stream.Charset = "shift_jis"
	' shift_jis で入力文字を書き込む
	Stream.WriteText str
	' コピーの為にデータポインタを先頭にセット
	Stream.Position = 0
 
	Stream2.Open
	Stream2.Charset = "utf-8"
	' shift_jis を utf-8 に変換
	Stream.CopyTo Stream2
	Stream.Close

	' コピーの為にデータポインタを先頭にセット
	Stream2.Position = 0

	' バイナリで開く
	StreamBin.Open
 	StreamBin.Type = 1

	' テキストをバイナリに変換
	Stream2.CopyTo StreamBin
	Stream2.Close

	' 読み込みの為にデータポインタを先頭にセット
	StreamBin.Position = 0

	Buffer = ""
	StreamBin.Read(3)
	Do while not StreamBin.EOS
		LineBuffer = StreamBin.Read(16)
 
		For i = 1 to LenB( LineBuffer )
			CWork = MidB(LineBuffer,i,1)
			Cwork = AscB(Cwork)
			Cwork = Hex(Cwork)
			Cwork = Ucase(Cwork)
			if Len(Cwork) = 1 then
				Buffer = Buffer & "%0" & Cwork
			else
				Buffer = Buffer & "%" & Cwork
			end if
		Next
 
	Loop

	StreamBin.Close

	URLEncode = Buffer

End Function

' ***********************************************************
' 仕様を明確にする為に単純変換
' ***********************************************************
Function rfc3986_convert(str)

	Dim strResult,I,strWork

	strResult = str

	strResult = Replace(strResult,"%2D", "-")
	strResult = Replace(strResult,"%2E", ".")

	' 0〜9
	For I = &H30 to &H39
		strWork = Hex(I)
		strWork = "%" & Ucase(strWork)
		strResult = Replace(strResult,strWork, Chr(I))
	Next

	' A〜Z
	For I = &H41 to &H5A
		strWork = Hex(I)
		strWork = "%" & Ucase(strWork)
		strResult = Replace(strResult,strWork, Chr(I))
	Next

	strResult = Replace(strResult,"%5F", "_")

	' a〜z
	For I = &H61 to &H7A
		strWork = Hex(I)
		strWork = "%" & Ucase(strWork)
		strResult = Replace(strResult,strWork, Chr(I))
	Next

	strResult = Replace(strResult,"%7E", "~")
	
	rfc3986_convert = strResult

End Function
</SCRIPT>
</JOB>