レンタルサーバーは簡単な PHP が必要ですが、既存のアプリケーションでもかまいません。
通常は、POST で処理されるので、その場合は、以下も参照して下さい。
VBScript でバッチ mixi ボイス投稿
今回は、以下の程度の PHP を用意して呼び出しも URL を作成するだけの簡単な処理です。
$link = mysql_connect($host, $user, $pass);
if ( !$link ) {
print mystr( "接続エラー" );
exit();
}
mysql_select_db( $db, $link );
$result = mysql_query($_GET['text']);
mysql_free_result($result);
mysql_close($link);
これを呼び出す為に、open Method (IXMLHTTPRequest) を使用しますが、必ず
このオブジェクトを使って、ServerXMLHTTP は使用しないで下さい。
ServerXMLHTTP は、連続使用ができないという不思議なバグがあります。
今は正しく動くようです
基本認証が必要無い場合は、Call objHTTP.Open("GET",strTargetUrl & strData,False)
でかまいません。更新文字列は UPDATE を先にすれば存在しない場合は結果的になにもしま
せんので、後の INSERT が成功します。既に存在する場合は後の insert がエラーになります
が、重複が許可される場合は新規に追加されるでしょう。
実際は、プログラムでそのへんをコントロールして存在チェックが必要無いようにする事で
レスポンスに無駄がなくなります。
※ どうしても存在チェックが必要な場合はいったん呼び出して、結果をチェックする必要
※ が出てきますが、そのような設計だと、整合性が保たれる保証の確率が下がるので避けま
※ しょう。
Dim objHTTP,Stream,Stream2,StreamBin
' ***********************************************************
' ( 連続実行を想定しているので、クライアント用オブジェクト )
' ***********************************************************
Set objHTTP = Wscript.CreateObject("MSXML2.XMLHTTP")
' ***********************************************************
' キャラクタセット変換用
' ***********************************************************
Set Stream = Wscript.CreateObject("ADODB.Stream")
Set Stream2 = Wscript.CreateObject("ADODB.Stream")
' ***********************************************************
' URLエンコード用
' ***********************************************************
Set StreamBin = Wscript.CreateObject("ADODB.Stream")
Dim strTargetUrl : strTargetUrl = "URL"
Dim strUser :strUser = "user"
Dim strPass : strPass = "pass"
' ***********************************************************
' 投稿
' ***********************************************************
Function WEBSend(strSql)
Dim strData
strData = "?text=" & EUC_URLEncode(strSql)
Call objHTTP.Open("GET",strTargetUrl & strData,False,strUser,strPass)
Call objHTTP.Send()
End Function
' ADOの事前処理
strUpdate = "update mytable "
strUpdate = strUpdate & " set "
strUpdate = strUpdate & "cno = " & objRs1.Fields( "cno" ).Value & ","
strUpdate = strUpdate & "cname = '" & objRs1.Fields( "cname" ).Value & "',"
strUpdate = strUpdate & "udate = '" & objRs1.Fields( "udate" ).Value & "',"
strUpdate = strUpdate & "comment = '" & objRs1.Fields( "comment" ).Value & "'"
strUpdate = strUpdate & " where cno = " & objRs1.Fields( "cno" ).Value
Call WEBSend( strUpdate )
strUpdate = "insert into mytable (cno,cname,udate,comment)"
strUpdate = strUpdate & " values("
strUpdate = strUpdate & objRs1.Fields( "cno" ).Value & ","
strUpdate = strUpdate & "'" & objRs1.Fields( "cname" ).Value & "',"
strUpdate = strUpdate & "'" & objRs1.Fields( "udate" ).Value & "',"
strUpdate = strUpdate & "'" & objRs1.Fields( "comment" ).Value & "')"
Call WEBSend( strUpdate )
' ADOの終了処理
' ***********************************************************
' SHIFT_JIS を EUC-JP に変換して URLエンコード
' ***********************************************************
Function EUC_URLEncode(str)
Dim Buffer,LineBuffer,i,CWork
Stream.Open
Stream.Charset = "shift_jis"
' shift_jis で入力文字を書き込む
Stream.WriteText str
' コピーの為にデータポインタを先頭にセット
Stream.Position = 0
Stream2.Open
Stream2.Charset = "euc-jp"
' shift_jis を euc-jp に変換
Stream.CopyTo Stream2
Stream.Close
' コピーの為にデータポインタを先頭にセット
Stream2.Position = 0
' バイナリで開く
StreamBin.Open
StreamBin.Type = 1
' テキストをバイナリに変換
Stream2.CopyTo StreamBin
Stream2.Close
' 読み込みの為にデータポインタを先頭にセット
StreamBin.Position = 0
Buffer = ""
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
EUC_URLEncode = Buffer
End Function
posted by
at 2010-12-17 16:36
|
VBScript
|
|
※ エキスパートモードで表示しています
アーカイブとカテゴリページはこのように簡単に設定できますが、タグページは HTML 設定を直接変更して、以下の『タグページでのみ表示される内容』の記述方法で設定する必要があります
