レンタルサーバーは簡単な 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
|
【VBScriptの最新記事】