SQLの窓

2017年08月13日


VBScript : Windows標準のオブジェクト(CDO.Message)とGMail(Yahoo!メール) を使ってメール送信

Windows7,Windows8,Windows10
(いずれも64ビット) で動作しました。

※ Gmail の場合、安全性の低いアプリの許可を『有効』にする必要があります

▼ 有効にしないと以下のメッセージ
メッセージを SMTP サーバーに送信できませんでした。転送エラー コードは 0x80040217 です。サーバーからの応答は次のとおりです。not available
メールサービスとしては、Gmail と Yahoo メールが使用可能でした。有料メールでは nifty メールで動作を確認しています。( Hotmail は CDO では使用できず、一般的に TLS の 587 で使用できます ) コマンドプロンプトから、以下のようにしてテストしています cscript mail.vbs 最近 では、ssl を使わないとメール送信できませんので、smtpusessl が true になっています。 mail.vbs
' ***********************************************************
' 使用するパラメータ
' ***********************************************************
strFrom = "わたしです <ユーザ名@gmail.com>"
'strFrom = "わたしです <ユーザ名@yahoo.co.jp>"

strTo = "あなたです <宛先>"

strServer = "smtp.gmail.com"
'strServer = "smtp.mail.yahoo.co.jp"

nPort = 465
strUser = "ユーザ名"
strPass = "パスワード"

' ***********************************************************
' オブジェクト
' ***********************************************************
Set Cdo = WScript.CreateObject("CDO.Message")

' ***********************************************************
' 自分のアドレスと宛先
' ***********************************************************
Cdo.From = strFrom
Cdo.To = strTo

' ***********************************************************
' 件名と本文
' ***********************************************************
Cdo.Subject	= "件名の文字列 / " & Now()
Cdo.Textbody = "テキスト本文" & vbCrLf & "改行は vbCrLf"

' ***********************************************************
' CC BCC HTMLメール( CC BCC はどちらか片方  )
' ※ 両方指定すると CC
' ***********************************************************
Cdo.Cc = "ユーザ名@yahoo.co.jp,ユーザ名@hotmail.co.jp"
'Cdo.Bcc = "ユーザ名@yahoo.co.jp,ユーザ名@hotmail.co.jp"
Cdo.Htmlbody = "<img src=""http://winofsql.jp/image/winofsql.png"">"

' ***********************************************************
' ファイル添付あり
' ***********************************************************
Cdo.AddAttachment( "C:\Users\lightbox\Desktop\画像\_img.jpg" )
Cdo.AddAttachment( "C:\Users\lightbox\Downloads\del.gif" )

' ***********************************************************
' 設定
' ***********************************************************
Cdo.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
Cdo.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strServer
Cdo.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = nPort
Cdo.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = true

Cdo.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
Cdo.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/sendusername") = strUser
Cdo.Configuration.Fields.Item _ 
 ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strPass

' ***********************************************************
' 設定の反映
' ***********************************************************
Cdo.Configuration.Fields.Update

' ***********************************************************
' 送信
' ***********************************************************
on error resume next
Cdo.Send
if Err.Number <> 0 then
	strMessage = Err.Description
else
	strMessage = "送信が完了しました"
end if
on error goto 0

Wscript.Echo strMessage

関連する記事

Windows 標準の CDO.Message で簡単にバッチ処理からメールを送る
Basp21 を使ってバッチ処理からメールを送る

変更履歴
2013-01-09 : 初回投稿
2013-07-27 : Yahoo メールと Nifty メールでテスト
2014-02-28 : 添付ファイル、cc、bcc、HTML メール を追加


posted by lightbox at 2017-08-13 23:19 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする

2015年02月06日


VBScript で Seesaaブログへ禁止ワード一括登録( アップロード )

2015-02-06 更新

Google Chrome で拡張子 .vbs が悪者扱いされるので、.wsf に変更して内容も更新しました。再度動作確認も行いました

2013/01/19 更新

Seesaa の最新仕様にあわせて更新しました。
パッケージにデフォルトの『禁止WORD.txt』を同梱しました
実行は、コマンドラインより実行するようにしたので、readme.txt をご覧ください

▼ readme.txt の内容
禁止WORD.txt は、ファイル名を変更せずに使って下さい。内容はいままで運用で使ったものをセットしていますが、適宜変更または追加して下さい。内容は酷い内容なので、ご注意ください。

コマンドプロンプトを開き、今開いているファイル(readme.txt)があるフォルダがカレントになるようにします。

Windows VISTA 以降なら、エクスプローラで、SHIFT キーを押しながらこのフォルダ右クリックして『コマンドウインドウをここで開く』を実行します

以下をコマンドラインから実行します

cscript ignore_words.wsf メールアドレス パスワード ブログID

ブログの ID は、自分のブログ一覧を表示して、ブログタイトルのリンクを取り出すと以下のようになります。

(例)
http://blog.seesaa.jp/cms/home/switch?blog_id=2868467&goto=/cms/article/regist/input

blog_id=2868467 とありますが、2868467 の部分を使用します。
処理としては、ブラウザの代りに処理させるので、実際のやりとりを HTML のコードをページ毎に読んで基本処理部分を構築しています。実際の送信処理で送られる内容は、F12 の開発者ツールで比較的簡単に確認できます。 VBScript では、扱うデータが SHIFT_JIS なので、ADODB.Stream を使って UTF-8 に変換した上で% エンコーディングを行っています。
<JOB>
<SCRIPT language="VBScript">
' ***********************************************************
' サーバーオブジェクトを使用しています
' ***********************************************************
Set objHTTP = Wscript.CreateObject("Msxml2.ServerXMLHTTP")
lResolve = 60 * 1000
lConnect = 60 * 1000
lSend = 60 * 1000
lReceive = 60 * 1000

' ***********************************************************
' キャラクタセット変換用
' ***********************************************************
Set Stream = Wscript.CreateObject("ADODB.Stream")
Set Stream2 = Wscript.CreateObject("ADODB.Stream")
' ***********************************************************
' URLエンコード用
' ***********************************************************
Set StreamBin = Wscript.CreateObject("ADODB.Stream")
' ***********************************************************
' POST データ読み込み用
' ***********************************************************
Set Fs = CreateObject( "Scripting.FileSystemObject" )
' ***********************************************************
' 正規表現用
' ***********************************************************
Set regEx = New RegExp

Wscript.Echo "開始します。しばらくお待ち下さい"

' ログインページの取得
Call objHTTP.Open("GET","https://ssl.seesaa.jp/auth",False)
Call objHTTP.setTimeouts(lResolve, lConnect, lSend, lReceive)
Call objHTTP.Send()

' ページ全体
strPage = objHTTP.responseText

' 投稿用のキーを取得
regEx.IgnoreCase = True
regEx.Global = True
regEx.Pattern = "authpost""><input value=""([^""]+)"""
Set Matches = regEx.Execute( strPage )
For Each Match in Matches
	strPostKey = Match.SubMatches(0)
	Exit For
Next
'Wscript.Echo strPostKey

' ***********************************************************
' コマンドラインからの固有の情報の取得
' ***********************************************************
' Seesaa のログインユーザ( メールアドレス )
emailData = Wscript.Arguments(0)
' Seesaa のログインパスワード
passData = Wscript.Arguments(1)
' 登録したいブログの ID を指定します
blogData = Wscript.Arguments(2)

' ***********************************************************
' (1) : POST
' ***********************************************************
' ログイン URL
Call objHTTP.Open("POST","https://ssl.seesaa.jp/auth",False)
' POST 用ヘッダ
Call objHTTP.setRequestHeader("Content-Type", "application/x-www-form-urlencoded")
strData = ""
strData = strData & "aXt=" & strPostKey
strData = strData & "&email=" & emailData
strData = strData & "&password=" & passData
strData = strData & "&return_to=http%3A%2F%2Fblog.seesaa.jp%2F"
Call objHTTP.SetRequestHeader("Content-Length",Len(strData))
Call objHTTP.Send(strData)
'strHeaders = objHTTP.getAllResponseHeaders()
'Wscript.Echo strHeaders

' ***********************************************************
' (2) : GET
' ***********************************************************
' 対象ブログ URL
Call objHTTP.Open("GET","http://blog.seesaa.jp/cms/home/switch?blog_id="&blogData&"&goto=/cms/article/regist/input" , False)
Call objHTTP.setTimeouts(lResolve, lConnect, lSend, lReceive)
Call objHTTP.Send()

' 以下デバッグ用
'Set OutObj = Fs.OpenTextFile( "log.txt", 2, True )
'OutObj.Write objHTTP.responseText
'OutObj.Close

' ***********************************************************
' (3) : GET
' ***********************************************************
' 投稿ページ
Call objHTTP.Open("GET","http://blog.seesaa.jp/cms/ignore_words/regist/input" , False)
Call objHTTP.setTimeouts(lResolve, lConnect, lSend, lReceive)
Call objHTTP.Send()

' 投稿用のキーを取得
strPage = objHTTP.responseText
regEx.Pattern = "method=""POST""><input value=""([^""]+)"""
Set Matches = regEx.Execute( strPage )
For Each Match in Matches
	strPostKey = Match.SubMatches(0)
	Exit For
Next

Wscript.Sleep(2000) ' 2秒間の間を置く

' ***********************************************************
' (3) : POST
' ***********************************************************
Set InObj = Fs.OpenTextFile( "禁止WORD.txt", 1 )

nCnt = 0
strData = "aXt=" & strPostKey
Do While not InObj.AtEndOfStream
	Buffer = InObj.ReadLine
	nCnt = nCnt + 1

	if strData <> "" then
		strData = strData & "&"
	end if

	strData = strData & "ignore_words=" & URLEncode( Buffer )

	if nCnt = 5 then
		' 5ワード毎に POST
		Call objHTTP.Open("POST","http://blog.seesaa.jp/cms/ignore_words/regist/input",False)
		Call objHTTP.setRequestHeader("Content-Type", "application/x-www-form-urlencoded")
		Call objHTTP.SetRequestHeader("Content-Length",Len(strData))
		Call objHTTP.Send(strData)
		nCnt = 0
		strData = "aXt=" & strPostKey
		Wscript.Sleep(2000) ' 2秒間の間を置く
	end if
Loop

if nCnt <> 0 then
	Call objHTTP.Open("POST","http://blog.seesaa.jp/cms/ignore_words/regist/input",False)
	Call objHTTP.setRequestHeader("Content-Type", "application/x-www-form-urlencoded")
	Call objHTTP.SetRequestHeader("Content-Length",Len(strData))
	Call objHTTP.Send(strData)
end if

InObj.Close

Wscript.Echo "終了しました"

' ***********************************************************
' 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 = ""
	' BOMを取り去る
	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
</SCRIPT>
</JOB>




▼ 初回投稿時の実際の経緯
承認制にしているにも関わらず、週末にいきなりたくさんやってきます。ここ最近急に増えて来ていちいち削除するのが面倒になってきたので、VBScript で一括で禁止ワードをアップロードできるようにしました。

ワードは少しづつ追加していったものですが、26個ほどでピタリと止まっているので。

そのワードも公開したいところですが、とても出せるようなものでは無いので、ロ口工エの組み合わせで4つできる事だけは報告しておきます。( 同梱しています )


関連する記事

Seesaa ブログのエクスポートを呼び出して全てをバックアップするスクリプト



タグ:トラブル
posted by lightbox at 2015-02-06 22:49 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする

2014年08月06日


VBScript で半角カナから全角カナへ変換するのに、php の mb_convert_kana を呼び出す

mb_convert_kana で変換できる内容は多岐に渡りますし、それを VBScript でわざわざ実装するコストはちょっともったいないので VBScript から http で呼び出して変換するサンプルです。
VBScript
Set objHTTP = Wscript.CreateObject("Msxml2.ServerXMLHTTP")
Set Stream = Wscript.CreateObject("ADODB.Stream")
Set Stream2 = Wscript.CreateObject("ADODB.Stream")
Set StreamBin = Wscript.CreateObject("ADODB.Stream")

Dim strTargetUrl : strTargetUrl = "http://localhost/user/convert_kana.php"

Wscript.Echo WEBConvSend("アイウエオガギグゲゴ","KV")

' ***************************
' 投稿
' ***************************
Function WEBConvSend(s,t)

	Dim strData

	strData = "t=" & t & "&s=" & URLEncode(s)

	Call objHTTP.Open("POST",strTargetUrl,False)
	Call objHTTP.setRequestHeader("Content-Type", "application/x-www-form-urlencoded")
	Call objHTTP.SetRequestHeader("Content-Length",Len(strData))
	Call objHTTP.Send(strData)

	WEBConvSend = objHTTP.ResponseText

End Function

' ***************************
' URLエンコード
' ***************************
Function 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 = "utf-8"
	' 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 = ""
	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


PHP : convert_kana.php


タグ:VBScript PHP
posted by lightbox at 2014-08-06 16:49 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする

VBScript : URLEncode( OAuth 用 rfc3986 )

VBScript で、コード内の文字列を UTF-8 に変換してから、一旦全てパーセントエンコードし、目的の仕様に沿って一部の文字を元に戻しています。

※ rfc3986 は、PHP 5.3.x における rawurlencode です。

関連する記事

   PHP / JavaScript / ASP / PowerShell / python / Framework(バージョン別) : 処理別の urlencode の結果の違い
 VBScript : Twitter API を呼び出して投稿する
Set Stream = Wscript.CreateObject("ADODB.Stream")
Set Stream2 = Wscript.CreateObject("ADODB.Stream")
Set StreamBin = Wscript.CreateObject("ADODB.Stream")

strData = "status=" & rfc3986_convert(URLEncode(strText))

' ********************************************
' 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 = ""
	' BOMを取り去る
	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


以下はいろいろな処理系の URLEncode か、またはそれに相当する変換の一部分です
1PHP : urlencode
2PHP : rawurlencode : 5.2.x
3PHP : rawurlencode : 5.3.x
4JavaScript : encodeURI
5JavaScript : encodeURIComponent
6ASP : Server.URLEncode
( Server.URLEncode(chr(I))で変換できない文字があります )
7PowerShell : [System.Web.HttpUtility]::UrlEncode
8python 2.6.2 : urllib.quote
9js2 と同じ : VS2010 Uri.EscapeDataString
10php3 と同じ : VS2012 Uri.EscapeDataString
11ps の ' が %27 : VS2010 HttpUtility.UrlEncode

    php1 php2 php3 js1 js2 asp ps py fw4 fw4.5 fw
    1 2 3 4 5 6 7 8 9 10 11
0   %00 %00 %00 %00 %00   %00 %00 %00 %00 %00
32   + %20 %20 %20 %20 + + %20 %20 %20 +
33 【!】 %21 %21 %21 ! ! %21 ! %21 ! %21 !
34 【"】 %22 %22 %22 %22 %22 %22 %22 %22 %22 %22 %22
35 【#】 %23 %23 %23 # %23 %23 %23 %23 %23 %23 %23
36 【$】 %24 %24 %24 $ %24 %24 %24 %24 %24 %24 %24
37 【%】 %25 %25 %25 %25 %25 %25 %25 %25 %25 %25 %25
38 【&】 %26 %26 %26 & %26 %26 %26 %26 %26 %26 %26
39 【'】 %27 %27 %27 ' ' %27 ' %27 ' %27 %27
40 【(】 %28 %28 %28 ( ( %28 ( %28 ( %28 (
41 【)】 %29 %29 %29 ) ) %29 ) %29 ) %29 )
42 【*】 %2A %2A %2A * * %2A * %2A * %2A *
43 【+】 %2B %2B %2B + %2B %2B %2B %2B %2B %2B %2B
44 【,】 %2C %2C %2C , %2C %2C %2C %2C %2C %2C %2C
45 【-】 - - - - - %2D - - - - -
46 【.】 . . . . . %2E . . . . .
47 【/】 %2F %2F %2F / %2F %2F %2F / %2F %2F %2F


posted by lightbox at 2014-08-06 11:10 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする

2014年07月24日


VBscript(または JScript) で簡単にバイナリファイルをアップロードする

PHP 側も単純ですが、PHP のマニュアルに書いている場所は、少し見付けづらいかもしれません。

内容は PUT メソッドで始まっていますが、VBScript からは POST で問題ありません。実際の内容は、Apache 上で PUT メソッドを PHP でサポートするお話なので、重要なのは PHP での記述方法です。

put.php ( utf-8n )
<?
session_start();
$id = session_id();


$fp = fopen( "php://input", "r" );
$wfp = fopen( "image/$id.png", "w" );

while( $ret = fread( $fp, 4096 ) ) {

	fwrite( $wfp, $ret );

}

fclose($wfp);
fclose($fp);


print $id . ".png\n";
?>
で画像が保存されました

この URL に対して、VBScript のコマンドは POST であろうが、PUT であろうがどちらでもかまいません。

open Method (ServerXMLHTTP/IServerXMLHTTPRequest)
' *************************************
' サーバーオブジェクトを使用しています
' *************************************
Set objHTTP = Wscript.CreateObject("Msxml2.ServerXMLHTTP")
lResolve = 60 * 1000
lConnect = 60 * 1000
lSend = 60 * 1000
lReceive = 60 * 1000

' *************************************
' バイナリファイル
' *************************************
Set Stream = Wscript.CreateObject("ADODB.Stream")
upload_file = "winofsql.png"

' *************************************
' アップロード先
' localhost(AN HTTPD)でテストできます
' *************************************
upload_url = "http://yourdomain/put/put.php"

' *************************************
' 準備
' *************************************
Call objHTTP.Open( "POST",upload_url, False )

' *************************************
' バイナリデータ取得
' *************************************
Stream.Open
Stream.Type = 1
Stream.LoadFromFile(upload_file)
nLen = Stream.Size
data = Stream.Read(nLen)

' *************************************
' 送信
' *************************************
Call objHTTP.SetRequestHeader("Content-Length",nLen)
Call objHTTP.setTimeouts(lResolve, lConnect, lSend, lReceive)
Call objHTTP.Send(data)

Wscript.Echo(objHTTP.responseText)
setRequestHeader Method 
setTimeouts Method
send Method 

Stream オブジェクト

※ Microsoft は VB を真剣にやめたいみたいですね

なので、以下には JScript で書いたソースコードです。JScript では、大文字、小文字が区別されるので、いろいろ注意する必要があります。

upload.js
// *************************************
// サーバーオブジェクトを使用しています
// *************************************
objHTTP = new ActiveXObject("Msxml2.ServerXMLHTTP")
lResolve = 60 * 1000
lConnect = 60 * 1000
lSend = 60 * 1000
lReceive = 60 * 1000

// *************************************
// バイナリファイル
// *************************************
Stream = new ActiveXObject("ADODB.Stream")
upload_file = "winofsql.png"

// *************************************
// アップロード先
// localhost(AN HTTPD)でテストできます
// *************************************
upload_url = "http://yourdomain/put/put.php"

// *************************************
// 準備
// *************************************
objHTTP.open( "POST",upload_url, false )

// *************************************
// バイナリデータ取得
// *************************************
Stream.Open()
Stream.Type = 1
Stream.LoadFromFile(upload_file)
nLen = Stream.Size
data = Stream.Read(nLen)

// *************************************
// 送信
// *************************************
objHTTP.setRequestHeader("Content-Length",nLen)
objHTTP.setTimeouts(lResolve, lConnect, lSend, lReceive)
objHTTP.send(data)

WScript.Echo(objHTTP.responseText)

ActiveXObject オブジェクト



関連する記事


posted by lightbox at 2014-07-24 00:39 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする

2014年03月28日


WSH : VBScript + JavaScript ライブラリで、Twitter に画像をアップロード

OneDrive へ移動


API は、update_with_media.json です。

まだ詳細は解らないのですが、『Twitterが1ツイートに4枚までの写真添付や人物のタグ付けに対応。』とあったので、API を調べてみましたが、まだそのような対応が行われた形跡はありませんでした。しかし、いずれそのようになるのであれば、面倒だから避けていたこの処理を作成してしまう事にしました。

処理そのものはむずかしくは無いので、VS2010 の C# では既に出来ています。また、単純な PHP へのファイルアップロードも既に作成しています。

なので、これらを総合して、『WSH : VBScript と JavaScript で Twitter に投稿する』をベースにして作成しました。注意する場所は、Twitter の API の マルチパート部分の改行コードは vbCrLf(\r\n) で、VBScript のテキストデータで utf-8 を扱う場合、ADODB.Stream では、頭に3バイト余計な UTF-8 である事を示す値(BOM)がセットされるので読み飛ばす必要があるところです。

後は、ADODB.Stream のバイナリタイプをうまく使うと、ファイルのアップロードのマルチパート部分をポストする事ができます。
<JOB>
<COMMENT>
************************************************************
■著作権その他

このプログラムはフリーです。どうぞ自由に御使用ください。
著作権は作者である私(lightbox)が保有しています。
また、本ソフトを運用した結果については、作者は一切責任を
負えせんのでご了承ください。
************************************************************
</COMMENT>

<OBJECT id="objHTTP" progid="Msxml2.ServerXMLHTTP" />
<OBJECT id="Stream1" progid="ADODB.Stream" />
<OBJECT id="Stream2" progid="ADODB.Stream" />
<OBJECT id="StreamBin" progid="ADODB.Stream" />

<COMMENT>
************************************************************
 HMAC-SHA1 と Base64用
************************************************************
</COMMENT>
<SCRIPT language="JavaScript" src="hmac-sha1.js"></SCRIPT> 
<SCRIPT language="JavaScript" src="enc-base64-min.js"></SCRIPT> 
<SCRIPT language="JavaScript"> 
// *********************************************************
// JavaScript メソッドのラッパー
// *********************************************************
function hash_hmac(str1,str2) {

	// ここで使用します
	var hash = CryptoJS.HmacSHA1(str1, str2);
	return hash.toString(CryptoJS.enc.Base64);

}
</SCRIPT>

<SCRIPT language="VBScript">

' ***********************************************************
' ▼▼▼ こちらにご自分の API データをセットします ▼▼▼
' ***********************************************************
oauth_consumer_key = ""
oauth_consumer_secret = ""
oauth_token = ""
oauth_secret = ""
' ***********************************************************
' ▲▲▲ こちらにご自分の API データをセットします ▲▲▲
' ***********************************************************

' 投稿本文
strPost = ""
' 画像のパス
strPath = ""
' アップロード時のファイル名 / 英数字
strFileName = ""

MsgBox( PostTwitter(strPost, strPath, strFileName) )

' **********************************************************
' Twitter に自分のアプリケーションで投稿
' **********************************************************
Function PostTwitter( postdata, upload_file, file_name )

	Dim twitter_url
	Dim oauth_nonce,oauth_timestamp,oauth_signature_method,oauth_version
	Dim str,oauth_signature,headerAuth,strData,strRet

	' **************************************
	' Twitter 投稿用 API URL
	' **************************************
	twitter_url = "https://api.twitter.com/1.1/statuses/update_with_media.json"
'	twitter_url = "http://localhost/"

	oauth_nonce = Nonce()
	oauth_timestamp = DateDiff("s", "1970/1/1 0:00:00",DateAdd("h",-9,now))
	oauth_signature_method = "HMAC-SHA1"
	oauth_version = "1.0"

	base_s = "POST"
	base_s = base_s & "&" & rfc3986_convert(URLEncode(twitter_url))
	base_s = base_s & "&"
	base_s = base_s & "oauth_consumer_key" & "%3D" & oauth_consumer_key
	base_s = base_s & "%26"
	base_s = base_s & "oauth_nonce" & "%3D" & oauth_nonce & "%26"
	base_s = base_s & "oauth_signature_method" & "%3D" & oauth_signature_method & "%26"
	base_s = base_s & "oauth_timestamp" & "%3D" & oauth_timestamp & "%26"
	base_s = base_s & "oauth_token" & "%3D" & oauth_token & "%26"
	base_s = base_s & "oauth_version" & "%3D" & oauth_version

	oauth_signature = hash_hmac(base_s,oauth_consumer_secret & "&" & oauth_secret)
	Call objHTTP.Open( "POST",twitter_url, False )

	' ヘッダー1 : マルチパート
	strBoundary = DateDiff("s", "1970/1/1 0:00:00",DateAdd("h",-9,now))
	Call objHTTP.setRequestHeader("Content-Type", "multipart/form-data; boundary="&strBoundary)

	' ヘッダー2 : Authorization
	headerAuth = "OAuth " & _
	"oauth_consumer_key="""&oauth_consumer_key&"""," & _
	"oauth_token="""&oauth_token&"""," & _
	"oauth_nonce="""&oauth_nonce&"""," & _
	"oauth_timestamp="""&oauth_timestamp&"""," & _
	"oauth_signature_method="""&oauth_signature_method&"""," & _
	"oauth_version="""&oauth_version&"""," & _
	"oauth_signature="""&rfc3986_convert(URLEncode(oauth_signature))&""""
	Call objHTTP.setRequestHeader("Authorization", headerAuth)

	' データ
	' バイナリ変換用ストリーム
	Stream1.Open
	Stream1.Type = 1	' バイナリ

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

	' テキストストリーム
	Stream2.Open
	Stream2.Charset = "utf-8"

	' 開始セクション
	Stream2.WriteText "--" & strBoundary & vbCrLf
	Stream2.WriteText "Content-Disposition: form-data; name=""status""" & vbCrLf
	Stream2.WriteText vbCrLf
	Stream2.WriteText postdata & vbCrLf
	Stream2.Position = 0

	' テキストをバイナリに変換
	Stream2.CopyTo Stream1
	' テキストをいったん閉じる
	Stream2.Close

	' 開始セクションを書き込み
	Stream1.Position = 3
	StreamBin.Write Stream1.Read(Stream1.Size)

	Stream1.Close
	Stream1.Open
	Stream1.Type = 1	' バイナリ

	' テキストストリーム(2回目)
	Stream2.Open
	Stream2.Charset = "utf-8"

	' バイナリセクション
	Stream2.WriteText "--" & strBoundary & vbCrLf
	Stream2.WriteText "Content-Type: application/octet-stream" & vbCrLf
	Stream2.WriteText "Content-Disposition: form-data; name=""media[]""; filename=""" & file_name & """" & vbCrLf
	Stream2.WriteText vbCrLf
	Stream2.Position = 0

	' テキストをバイナリに変換
	Stream2.CopyTo Stream1
	' テキストをいったん閉じる
	Stream2.Close

	' バイナリセクションヘッダ部分書き込み
	Stream1.Position = 3
	StreamBin.Write Stream1.Read(Stream1.Size)

	Stream1.Close
	Stream1.Open
	Stream1.Type = 1	' バイナリ

	' 画像を読み込む
	Stream1.LoadFromFile(upload_file)

	' 画像を書き込み
	StreamBin.Write Stream1.Read(Stream1.Size)

	' バイナリワークをいったん閉じる
	Stream1.Close
	Stream1.Open
	Stream1.Type = 1

	' テキストストリーム(3回目)
	Stream2.Open
	Stream2.Charset = "utf-8"

	' 終了セクション
	Stream2.WriteText vbCrLf & "--" & strBoundary & "--" & vbCrLf
	Stream2.Position = 0

	' テキストをバイナリに変換
	Stream2.CopyTo Stream1
	' テキストを閉じる
	Stream2.Close

	' 終了セクションを書き込み
	Stream1.Position = 3
	StreamBin.Write Stream1.Read(Stream1.Size)

	' 送信データを取得
	nLen = StreamBin.Size
	StreamBin.Position = 0
	strData = StreamBin.Read(nLen)

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

	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)
	PostTwitter = objHTTP.responseText

End Function

' ***********************************************************
' ランダムな文字列
' ***********************************************************
Function Nonce(  )

	Dim base_str,str,I,nLen,Random
	base_str = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
	base_str = base_str & "abcdefghijklmnopqrstuvwxyz0123456789"

	nLen = Len(base_str)

	str = ""
	For I = 1 to 32
		Randomize
		Random = 1 + Int(Rnd * nLen)
		str = str & Mid(base_str,Random,1)
	Next

	Nonce = str

End function

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

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

関連する記事

WSH : VBScript と JavaScript で Twitter に投稿する
VBScript を使って HTTPプロトコルで PHP へファイルをアップロードする方法
VS2010(C#) Form : POST statuses/update_with_media で画像を伴った Twitter 投稿
VBScript : 複数テキストファイルの charset(キャラクタセット) 一括変換 / ADODB.Stream



posted by lightbox at 2014-03-28 01:02 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする

2014年03月08日


WSH : VBScript と JavaScript で Twitter に投稿する

▼ 最新版 
OneDrive へ移動

crypto-js が新しくなっていて、Twitter API で使う上において、SCRIPT 要素で読み込むだけで良いようになっています。

CryptoJS v3.1.2.zip は同梱しており、必要な js は、hmac-sha1.js と enc-base64-min.js だけなので、twitter_post_v2.wsf と同じ場所で実行できるようにしています。

実行は以下のような感じです。
cscript twitter_post_v2.wsf "CryptoJS v3.1.2 を使用して、コマンドプロンプトから投稿しています"





ソースコードは長くなるのでこちらから
▼ Twitter 部分は変わりませんが、crypto-js が古いです OneDrive へ移動 VBScript : Twitter API を呼び出して投稿する で書いた内容を一つ にまとめたソースコードにしました。 ※ ある程度関数化してあります。 必要なものは、以下の4つと投稿データです。 ( 88行目 )
oauth_consumer_key = "Consumer key"
oauth_consumer_secret = "Consumer secret"
oauth_token = "Access Token"
oauth_secret = "Access Token Secret"
上記データは、自分のアプリケーションを登録すると、全てその場で取得する事ができます。 ( Twitter Applications | dev.twitter.com ) ▼ 取得方法をまとめました Twitter アプリの登録方法と、API キーの利用 投稿データは、バッチファイルに書き込むようにしてテストしています。 使用例 : twitter.bat cscript twitter_post.wsf "新しくアプリを作ってバッチ投稿テスト"
<JOB>
<COMMENT>
************************************************************
■著作権その他

このプログラムはフリーです。どうぞ自由に御使用ください。
著作権は作者である私(lightbox)が保有しています。
また、本ソフトを運用した結果については、作者は一切責任を
負えせんのでご了承ください。
************************************************************
</COMMENT>

<OBJECT id="objHTTP" progid="Msxml2.ServerXMLHTTP" />
<OBJECT id="Stream1" progid="ADODB.Stream" />
<OBJECT id="Stream2" progid="ADODB.Stream" />
<OBJECT id="StreamBin" progid="ADODB.Stream" />

<SCRIPT language="JavaScript">
/*
 * Crypto-JS v2.0.0
 * http://code.google.com/p/crypto-js/
 * Copyright (c) 2009, Jeff Mott. All rights reserved.
 * http://code.google.com/p/crypto-js/wiki/License
 */
var Crypto;

(function(){var c="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";var d=Crypto={};var a=d.util={rotl:function(h,g){return(h<<g)|(h>>>(32-g))},rotr:function(h,g){return(h<<(32-g))|(h>>>g)},endian:function(h){if(h.constructor==Number){return a.rotl(h,8)&16711935|a.rotl(h,24)&4278255360}for(var g=0;g<h.length;g++){h[g]=a.endian(h[g])}return h},randomBytes:function(h){for(var g=[];h>0;h--){g.push(Math.floor(Math.random()*256))}return g},bytesToWords:function(h){for(var k=[],j=0,g=0;j<h.length;j++,g+=8){k[g>>>5]|=h[j]<<(24-g%32)}return k},wordsToBytes:function(i){for(var h=[],g=0;g<i.length*32;g+=8){h.push((i[g>>>5]>>>(24-g%32))&255)}return h},bytesToHex:function(g){for(var j=[],h=0;h<g.length;h++){j.push((g[h]>>>4).toString(16));j.push((g[h]&15).toString(16))}return j.join("")},hexToBytes:function(h){for(var g=[],i=0;i<h.length;i+=2){g.push(parseInt(h.substr(i,2),16))}return g},bytesToBase64:function(h){if(typeof btoa=="function"){return btoa(e.bytesToString(h))}for(var g=[],l=0;l<h.length;l+=3){var m=(h[l]<<16)|(h[l+1]<<8)|h[l+2];for(var k=0;k<4;k++){if(l*8+k*6<=h.length*8){g.push(c.charAt((m>>>6*(3-k))&63))}else{g.push("=")}}}return g.join("")},base64ToBytes:function(h){if(typeof atob=="function"){return e.stringToBytes(atob(h))}h=h.replace(/[^A-Z0-9+\/]/ig,"");for(var g=[],j=0,k=0;j<h.length;k=++j%4){if(k==0){continue}g.push(((c.indexOf(h.charAt(j-1))&(Math.pow(2,-2*k+8)-1))<<(k*2))|(c.indexOf(h.charAt(j))>>>(6-k*2)))}return g}};d.mode={};var b=d.charenc={};var f=b.UTF8={stringToBytes:function(g){return e.stringToBytes(unescape(encodeURIComponent(g)))},bytesToString:function(g){return decodeURIComponent(escape(e.bytesToString(g)))}};var e=b.Binary={stringToBytes:function(j){for(var g=[],h=0;h<j.length;h++){g.push(j.charCodeAt(h))}return g},bytesToString:function(g){for(var j=[],h=0;h<g.length;h++){j.push(String.fromCharCode(g[h]))}return j.join("")}}})();(function(){var f=Crypto,a=f.util,b=f.charenc,e=b.UTF8,d=b.Binary;var c=f.SHA1=function(i,g){var h=a.wordsToBytes(c._sha1(i));return g&&g.asBytes?h:g&&g.asString?d.bytesToString(h):a.bytesToHex(h)};c._sha1=function(o){if(o.constructor==String){o=e.stringToBytes(o)}var v=a.bytesToWords(o),x=o.length*8,p=[],r=1732584193,q=-271733879,k=-1732584194,h=271733878,g=-1009589776;v[x>>5]|=128<<(24-x%32);v[((x+64>>>9)<<4)+15]=x;for(var z=0;z<v.length;z+=16){var E=r,D=q,C=k,B=h,A=g;for(var y=0;y<80;y++){if(y<16){p[y]=v[z+y]}else{var u=p[y-3]^p[y-8]^p[y-14]^p[y-16];p[y]=(u<<1)|(u>>>31)}var s=((r<<5)|(r>>>27))+g+(p[y]>>>0)+(y<20?(q&k|~q&h)+1518500249:y<40?(q^k^h)+1859775393:y<60?(q&k|q&h|k&h)-1894007588:(q^k^h)-899497514);g=h;h=k;k=(q<<30)|(q>>>2);q=r;r=s}r+=E;q+=D;k+=C;h+=B;g+=A}return[r,q,k,h,g]};c._blocksize=16})();

/*
 * Crypto-JS v2.0.0
 * http://code.google.com/p/crypto-js/
 * Copyright (c) 2009, Jeff Mott. All rights reserved.
 * http://code.google.com/p/crypto-js/wiki/License
 */
(function(){var e=Crypto,a=e.util,b=e.charenc,d=b.UTF8,c=b.Binary;e.HMAC=function(l,m,k,h){if(m.constructor==String){m=d.stringToBytes(m)}if(k.constructor==String){k=d.stringToBytes(k)}if(k.length>l._blocksize*4){k=l(k,{asBytes:true})}var g=k.slice(0),n=k.slice(0);for(var j=0;j<l._blocksize*4;j++){g[j]^=92;n[j]^=54}var f=l(g.concat(l(n.concat(m),{asBytes:true})),{asBytes:true});return h&&h.asBytes?f:h&&h.asString?c.bytesToString(f):a.bytesToHex(f)}})();

// *********************************************************
// JavaScript メソッドのラッパー
// *********************************************************
function hash_hmac(str1,str2) {

	// ここで使用します
	return Crypto.HMAC(Crypto.SHA1, str1, str2,{ asString: true } ); 

}
function hash_hmac_bin(str1,str2) {

	// ここでは使用しません( 整数の配列が戻されます )
	return Crypto.HMAC(Crypto.SHA1, str1, str2,{ asBytes: true } ); 

}
// stringToBytes の結果を渡します
function bytesToBase64(data) {

	// ここで使用します
	return Crypto.util.bytesToBase64(data); 
}

function stringToBytes(data) {

	// ここで使用します
	return Crypto.charenc.Binary.stringToBytes(data)
}

// JavaScript のメソッドを VBScript から利用
function encodeJsUri( str ) {
	return encodeURIComponent( str );
}

function getTwitpicJson( json ) {

	var obj = eval("("+json+")" );

	return obj["url"];

}
function getTwitterJson( json ) {

	var obj = eval("("+json+")" );

	return obj["data"]["url"];

}
</SCRIPT>

<SCRIPT language="VBScript">

oauth_consumer_key = ""
oauth_consumer_secret = ""
oauth_token = ""
oauth_secret = ""

strPost = WScript.Arguments(0)

PostTwitter(strPost)

' ***********************************************************
' 文字列前後の漢字スペースを含むホワイトスペースの削除
' ***********************************************************
Function RegTrim( strValue )

	Dim regEx, str

	Set regEx = New RegExp
	regEx.IgnoreCase = True
	regEx.Pattern = "^[ \s]+"
	str = regEx.Replace( strValue, "" )
	regEx.Pattern = "[ \s]+$"
	RegTrim = regEx.Replace( str, "" )

End Function

' **********************************************************
' Twitter に自分のアプリケーションで投稿
' **********************************************************
Function PostTwitter( postdata )

	Dim twitter_url
	Dim oauth_nonce,oauth_timestamp,oauth_signature_method,oauth_version
	Dim str,oauth_signature,headerAuth,strData,strRet

	' **************************************
	' Twitter 投稿用 API URL
	' **************************************
	twitter_url = "https://api.twitter.com/1.1/statuses/update.json"

	oauth_nonce = Nonce()
	oauth_timestamp = DateDiff("s", "1970/1/1 0:00:00",DateAdd("h",-9,now))
	oauth_signature_method = "HMAC-SHA1"
	oauth_version = "1.0"

	base_s = "POST"
	base_s = base_s & "&" & rfc3986_convert(URLEncode(twitter_url))
	base_s = base_s & "&"
	base_s = base_s & "oauth_consumer_key" & "%3D" & oauth_consumer_key
	base_s = base_s & "%26"
	base_s = base_s & "oauth_nonce" & "%3D" & oauth_nonce & "%26"
	base_s = base_s & "oauth_signature_method" & "%3D" & oauth_signature_method & "%26"
	base_s = base_s & "oauth_timestamp" & "%3D" & oauth_timestamp & "%26"
	base_s = base_s & "oauth_token" & "%3D" & oauth_token & "%26"
	base_s = base_s & "oauth_version" & "%3D" & oauth_version & "%26"
	base_s = base_s & "status" & "%3D" & _
		rfc3986_convert(URLEncode(rfc3986_convert(URLEncode(postdata))))

	str = hash_hmac(base_s,oauth_consumer_secret & "&" & oauth_secret)
	oauth_signature = bytesToBase64(stringToBytes(str))
	Call objHTTP.Open( "POST",twitter_url, False )
	Call objHTTP.setRequestHeader("Content-Type", "application/x-www-form-urlencoded")
'	Call objHTTP.setRequestHeader("Expect", "")
	headerAuth = "OAuth " & _
	"oauth_consumer_key="""&oauth_consumer_key&"""," & _
	"oauth_token="""&oauth_token&"""," & _
	"oauth_nonce="""&oauth_nonce&"""," & _
	"oauth_timestamp="""&oauth_timestamp&"""," & _
	"oauth_signature_method="""&oauth_signature_method&"""," & _
	"oauth_version="""&oauth_version&"""," & _
	"oauth_signature="""&rfc3986_convert(URLEncode(oauth_signature))&""""
	Call objHTTP.setRequestHeader("Authorization", headerAuth)
	strData = "status=" & rfc3986_convert(URLEncode(postdata))
	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)
	PostTwitter = objHTTP.responseText

End Function

' ***********************************************************
' ランダムな文字列
' ***********************************************************
Function Nonce(  )

	Dim base_str,str,I,nLen,Random
	base_str = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
	base_str = base_str & "abcdefghijklmnopqrstuvwxyz0123456789"

	nLen = Len(base_str)

	str = ""
	For I = 1 to 32
		Randomize
		Random = 1 + Int(Rnd * nLen)
		str = str & Mid(base_str,Random,1)
	Next

	Nonce = str

End function

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

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

更新履歴
2012-12-31 : 初回投稿
2013-06-02 : API 1.1 で動作確認
2013-07-11 : 再確認

関連する記事

Twitter API の自分のアプリのトークンを使って投稿するだけの class VS2010_Twitter

Twitter API の自分のアプリのトークンを使って投稿するだけの class VS2012_Twitter

Twitter API の自分のアプリのトークンを使って投稿するだけの class Android_Twitter

PHP : Twitter 投稿関数( twitter_update ) / cURL 関数



タグ:twitter API
posted by lightbox at 2014-03-08 15:01 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする

2013年03月01日


VBS : レンタルサーバーに画像を置いてブログに貼ると、アクセスログで記事毎のアクセス状態を知る事ができます

自分が使っているサーバーのアクセスログは以下のようになっているので、IPアドレスとタイムスタンプを正規表現で取り出して該当記事がいつどこからの IP からアクセスされたかを知る事ができます。
xxx.xxx.xxx.xxx - - [27/Feb/2013:10:21:24 +0900] "GET /image/logical_error.png HTTP/1.1" 200 28573 "http://logicalerror.seesaa.net/article/331996491.html" "Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10.6; en-US; rv:1.9.2) Gecko/20100115 Firefox/3.6"
Windows で実はなにより手軽な VBScriptで

適当なフォルダにログを置いて、同じ場所に以下の checklog.vbs を置いて、先頭にログのファイル名と出力ファイルと対象となる記事の URL を指定してエクスプローラから実行します。

IPアドレスの正規表現は厳密ではありませんが、調べてみると IP アドレスの正規表現は複雑なわりに信頼性低そうなので、きちんとチェックしたい場合はプログラムでチェックして読み飛ばすなりしたほうが良いと思いました。

checklog.vbs
FilePath = "access_log_20130227"
OutFile = "check_27.log"
TargetUrl = "http://logicalerror.seesaa.net/article/331996491.html"

' **********************************************************
' オブジェクト作成
' **********************************************************
Set Fs = CreateObject( "Scripting.FileSystemObject" )

' **********************************************************
' ファイルオープン
' **********************************************************
on error resume next
Set InFile = Fs.OpenTextFile( FilePath, 1 )
if Err.Number <> 0 then
	Wscript.Echo Err.Description
	Wscript.Quit
end if
on error goto 0
Set OutFile = Fs.OpenTextFile( OutFile, 2, True )

' **********************************************************
' 正規表現
' **********************************************************
Set regEx = New RegExp
' 検索パターン : IPアドレスらしきものとタイムスタンプ
regEx.Pattern = "(\d+\.\d+\.\d+\.\d+)[^\n]+(\[[^\n]+\])"
' 大文字小文字を区別しない
regEx.IgnoreCase = True
' 文字列全体を検索
' False だと一件しか検索しない
regEx.Global = True

' **********************************************************
' 処理
' **********************************************************
strBreak = ""
Do While not InFile.AtEndOfStream
	' 行を読み取る
	Buffer = InFile.ReadLine
	' 対象となる URL を含んでいる
	if instr( Buffer, TargetUrl ) <> 0 then

		' 行を調べる
		Set Matches = regEx.Execute(Buffer)

		strTarget1 = ""
		For Each Match in Matches
			' 検索結果の中の 最初に見つけた IPアドレスらしきもの
			strTarget1 = Match.SubMatches(0)
			' IPアドレスらしきもの後にある、[] で囲まれたタイムスタンプ
			strTarget2 = Match.SubMatches(1)

			' 一つのセットのみで良い
			Exit For
		Next

		' IPアドレスらしきものがあった場合
		if strTarget1 <> "" then
			' 初回と、連続するIPアドレスらしきものの先頭のみ出力
			if strBreak <> strTarget1 then
				OutFile.WriteLine strTarget1 & vbTab & strTarget2
			end if

			' 今回の内容を保存
			strBreak = strTarget1
		end if

	end if
Loop

' **********************************************************
' ファイルクローズ
' **********************************************************
OutFile.Close
InFile.Close

Wscript.Echo "処理が終了しました"

記事 URL をサイト URL に短縮すると

サイトに対するアクセスログを IP アドレスで分析する事になります。出力フォーマットは以下のような感じになっているので、コマンドプロンプトを使ってソートすれば、マッチング処理で同一 IP からのアクセスを分析できると思います。
xxx.xxx.xxx.xxx	[27/Feb/2013:10:21:24 +0900]
xxx.xxx.xxx.xxx	[27/Feb/2013:12:02:59 +0900]
xxx.xxx.xxx.xxx	[27/Feb/2013:15:43:20 +0900]
ソートは、type check_27.log | sort > check_27s.log のようにすると作成できます。 マッチングは、ソートされた二つのファイルを使って同一 IP アドレスを出力するようにするものですが、以下のようなものを作ってテストしてみました。
FilePath = "check_26s.log"
FilePath2 = "check_27s.log"
OutFileName = "match.log"

' **********************************************************
' オブジェクト作成
' **********************************************************
Set Fs = CreateObject( "Scripting.FileSystemObject" )

' **********************************************************
' ファイルオープン
' **********************************************************
on error resume next
Set InFile = Fs.OpenTextFile( FilePath, 1 )
if Err.Number <> 0 then
	Lbox.MsgOk( Err.Description )
	Wscript.Quit
end if

Set InFile2 = Fs.OpenTextFile( FilePath2, 1 )
if Err.Number <> 0 then
	Lbox.MsgOk( Err.Description )
	Wscript.Quit
end if
on error goto 0
Set OutFile = Fs.OpenTextFile( OutFileName, 2, True )

' **********************************************************
' マッチング処理
' **********************************************************
Buffer = InFile.ReadLine
wk = Split(Buffer,vbTab)
Buffer = wk(0)

Buffer2 = InFile2.ReadLine
wk = Split(Buffer2,vbTab)
Buffer2 = wk(0)

Do While not InFile.AtEndOfStream

	if Buffer = Buffer2 then
		OutFile.WriteLine Buffer
	else
		Do While Buffer >= Buffer2 and not InFile2.AtEndOfStream
			Buffer2 = InFile2.ReadLine
			wk = Split(Buffer2,vbTab)
			Buffer2 = wk(0)
			if Buffer = Buffer2 then
				OutFile.WriteLine Buffer
			end if
		Loop
	end if

	Buffer = InFile.ReadLine
	wk = Split(Buffer,vbTab)
	Buffer = wk(0)
Loop

' **********************************************************
' ファイルクローズ
' **********************************************************
OutFile.Close
InFile.Close

Wscript.Echo "処理が終了しました"

マッチング処理は昔からある二つのファイルの比較方法で、二つのファイルの比較するキーが同一ならば、どちらか一つを読み進めて( この場合は、InFile )、それ以外では小さいほうのファイルを読み進めます。そうすると必ず同じデータがヒットするというアルゴリズムです。

この方法は、データベースが無くてもテキストデータをソートするコマンド( SORT )さえあれば可能なので、バッチ処理として使う上において今でもとても有効だと思います。




タグ:VBScript
posted by lightbox at 2013-03-01 10:00 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする

2012年12月28日


WEBのファイルをコマンドラインからダウンロードするスクリプト : httpget.vbs

バッチ処理に使うのであれば
cscript httpget.vbs "URL"

対話で、エラー時にメッセージボックスが出ても良い場合は

httpget "URL"

※ URL だけを指定すると、URL の最後をファイル名としてカレントにダウンロード
※ URL の後にパスを指定するとそこへダウンロードです
( httpget "URL" "保存ファイル名のパス" )

(例) 7zip コマンドラインバージョンのダウンロード
▼ 
httpget.vbs "http://sourceforge.jp/frs/g_redir.php?m=jaist&f=/sevenzip/7-Zip/9.20/7za920.zip"
if Wscript.Arguments.Count = 0 then
	Wscript.Echo "httpget url [savepath]"
	Wscript.Quit
end if

' *****************************
' ダウンロード用のオブジェクト
' *****************************
Set objSrvHTTP = Wscript.CreateObject("Msxml2.ServerXMLHTTP")

' *****************************
' 第1引数は URL
' *****************************
strUrl = Wscript.Arguments(0)
if Wscript.Arguments.Count = 1 then
	' 第2引数が無い場合は、URL の最後の部分
	' ( カレントにダウンロード )
	aData = Split(strUrl,"/")
	strFile = aData(Ubound(aData))
else
	' 第2引数がある場合はそれをローカルファイルとする
	strFile = Wscript.Arguments(1)
end if

' *****************************
' ダウンロード要求
' *****************************
on error resume next
Call objSrvHTTP.Open("GET", strUrl, False )
if Err.Number <> 0 then
	Wscript.Echo Err.Description
	Wscript.Quit
end if
objSrvHTTP.Send
if Err.Number <> 0 then
	' おそらくサーバーの指定が間違っている
	Wscript.Echo Err.Description
	Wscript.Quit
end if
on error goto 0

if objSrvHTTP.status = 404 then
	Wscript.Echo "URL が正しくありません(404)"
	Wscript.Quit
end if

' *****************************
' バイナリデータ保存用オブジェクト
' *****************************
Set Stream = Wscript.CreateObject("ADODB.Stream")
Stream.Open
Stream.Type = 1	' バイナリ
' 戻されたバイナリをファイルとしてストリームに書き込み
Stream.Write objSrvHTTP.responseBody
' ファイルとして保存
Stream.SaveToFile strFile, 2
Stream.Close





posted by lightbox at 2012-12-28 09:32 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする

2011年10月03日


VBS : Textt サービスに書き込んだテキストを PC にダウンロード(配布)する

環境によりますが、同一ユーザ、同一パスでログインしている複数のPC の共有に
テキストデータを一括配布するバッチを比較的簡単に作成できます。
( 出力側パスに \\PC名\共有 等を使用します )
' ダウンロード用のオブジェクト
Set objSrvHTTP = Wscript.CreateObject("Msxml2.ServerXMLHTTP")

' ダウンロード要求
Call objSrvHTTP.Open("GET", "http://textt.net/ユーザID/ファイル番号.txt", False )
objSrvHTTP.Send

' ※ Textt は Content-type は送られずに UTF-8 なので 問題は出ません

' ファイルシステムオブジェクト
Set Fs = CreateObject( "Scripting.FileSystemObject" )

' 書き込むファイルのパスを指定します
' 2はファイルを書き込み専用として開きます
' True はファイルが存在しなかった場合に新しいファイルを作成します
Set OutObj = Fs.OpenTextFile( "C:\TEST.txt", 2, True )

' WEB 上のファイルなので LF のみなので、CRLF に変換します
OutObj.Write( Replace( objSrvHTTP.responseText, vbLf, vbCrLf ) )

OutObj.Close()



posted by lightbox at 2011-10-03 15:46 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする

2011年09月07日


VBScript を使って HTTPプロトコルで PHP へファイルをアップロードする方法


関連する記事

ファイルのアップロード時のデータのダンプ

仕様を確認したわけではありませんが、boundary は、境界識別する為の
ユニークな文字列であると思われます。http ヘッダで指定した文字列を
x とすると --x が境界で、改行コードが付加されます。
一番最後の境界は --x-- です。
upload_target.php
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; CHARSET=shift_jis">
</HEAD>
<BODY>
<FORM 
	enctype="multipart/form-data"
	method="POST"
>
 
	アップロードするファイル : 
	<INPUT name="target" type="file" style='width:400'>
	<INPUT type="submit" value="アップロード">
 
</FORM>
<PRE>
<?
if ( $_SERVER['REQUEST_METHOD'] == "POST" ) {
 
	$upload = realpath("./");
	$upload .= ( DIRECTORY_SEPARATOR . $_FILES['target']['name'] );

	print $upload;

	if ( move_uploaded_file(
		$_FILES['target']['tmp_name'], $upload ) ) {
		print "アップロードに成功しました<br>\n";
	}

	print_r( $_FILES );
}

?>
</PRE>
</BODY></HTML>

upload.wsf
<JOB>
<COMMENT>
************************************************************
 URLEncode用
************************************************************
</COMMENT>
<OBJECT id="Stream" progid="ADODB.Stream" />
<OBJECT id="StreamWorkBin" progid="ADODB.Stream" />
<OBJECT id="StreamBin" progid="ADODB.Stream" />
<COMMENT>
************************************************************
 HTTP通信用
************************************************************
</COMMENT>
<OBJECT id="objHTTP" progid="Msxml2.ServerXMLHTTP" />

<SCRIPT language=VBScript>

' **********************************************************
' アップロード用 URL
' **********************************************************
upload_url = "http://localhost/test/001/upload_target.php"
upload_file = "winofsql.png"
upload_type = "image/png"

' *********************************************************
' 送信準備
' *********************************************************
Call objHTTP.Open( "POST",upload_url, False )
' File Upload 用 HTTP ヘッダ
strBoundary = DateDiff("s", "1970/1/1 0:00:00",DateAdd("h",-9,now))
Call objHTTP.setRequestHeader("Content-Type", "multipart/form-data; boundary="&strBoundary)

' バイナリ変換用ストリーム
StreamWorkBin.Open
StreamWorkBin.Type = 1

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

' テキストストリーム
Stream.Open
Stream.Charset = "shift_jis"

' 開始セクション
Stream.WriteText "--" & strBoundary & vbLf
Stream.WriteText "Content-Disposition: form-data; name=""target""; filename=""uploadtest.png""" & vbLf
Stream.WriteText "Content-Type: "&upload_type& vbLf
Stream.WriteText vbLf
Stream.Position = 0

' テキストをバイナリに変換
Stream.CopyTo StreamWorkBin

' 第一セクションを書き込み
StreamWorkBin.Position = 0
StreamBin.Write StreamWorkBin.Read(StreamWorkBin.Size)

' 画像を読み込む
StreamWorkBin.LoadFromFile(upload_file)

' 画像を書き込み
StreamBin.Write StreamWorkBin.Read(StreamWorkBin.Size)

' バイナリワークをいったん閉じる
StreamWorkBin.Close
StreamWorkBin.Open
StreamWorkBin.Type = 1

' テキストをいったん閉じる
Stream.Close
Stream.Open
Stream.Charset = "shift_jis"

' 終了セクション
Stream.WriteText vbLf & "--" & strBoundary & "--" & vbLf
Stream.Position = 0

' テキストをバイナリに変換
Stream.CopyTo StreamWorkBin

' 終了セクションを書き込み
StreamWorkBin.Position = 0
StreamBin.Write StreamWorkBin.Read(StreamWorkBin.Size)

' 送信データを取得
nLen = StreamBin.Size
StreamBin.Position = 0
strData = StreamBin.Read(nLen)

Call StreamBin.SaveToFile( "result.dat", 2 )

' *********************************************************
' 投稿データとその長さ
' *********************************************************
Call objHTTP.SetRequestHeader("Content-Length",nLen)

' *********************************************************
' API へ向けて送信
' *********************************************************
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)

Wscript.Echo(objHTTP.responseText)


</SCRIPT>
</JOB>



タグ:Curl
posted by lightbox at 2011-09-07 10:02 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする

2011年08月06日


VBScriptの関数定義をWEB上に置いて、Msxml2.ServerXMLHTTP で読みだして PCで使用する

VBScriptの関数定義をWEB上に置いて、PCで使用する の発展版です。
※ WEB 上に置くソースコードは、上記リンク先を参照して下さい。

Msxml2.ServerXMLHTTP は昔はバグがありましたが、今はとても優秀なオブジェクト
です。ただ、相手側が静的ファイルの場合は UTF-8 扱いになるはずなので、PHP 側
でキャラクタセットを明示しています。

読みだした後、ExecuteGlobal で文字列を実行してしまうのが特徴です。Global ス
コープで実行されるため、最初から定義していたのと同じ事になります。

但し、この処理を行う為に読みだされるソースコード側で注意する事があります

1) コメントにシングルクォートを使わないで REM を使う
2) 条件文で = を使わないで <> の else で表現する

これらは、ExecuteGlobal が正しく VBScript の構文を解析する為に重要な準備事項
になるので注意して下さい
<job>
<object id="http" progid="Msxml2.ServerXMLHTTP" /> 
<script language="VBScript">

' 関数のソースコードを読みだして、関数として定義
strResult = HTTPGet( "http://toolbox.winofsql.jp/vbs/regtrim.php" )
if not IsEmpty( strResult ) and Left( strResult, 3 ) = "REM" then
	' 関数定義の実行
	ExecuteGlobal strResult
else
	MsgBox( "処理できませんでした" )
	Wscript.Quit
end if

str = RegTrim( getResource( "mydata" ) )
MsgBox( "/" & str & "/" )

Function HTTPGet( strUrl )

	on error resume next
	Call http.Open("GET", strUrl, False )
	if Err.Number <> 0 then
		MsgBox(Err.Description)
		HTTPGet = Empty
		Exit Function
	end if
	on error goto 0

	Call http.Send()

	HTTPGet = http.responseText

End Function
</script>
<resource id="mydata">


    この部分のみ取り出します    


</resource>
</job>



posted by lightbox at 2011-08-06 12:48 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする

2011年08月05日


VBScriptの関数定義をWEB上に置いて、PCで使用する

まず、WEB 側に置くコードですが、Content-Type を text/plain にする
為に、PHP でhttpヘッダーを記述します。.htaccess で記述してもかまい
ませんが、WEB上の好きな場所を移動しやすくする為に php で記述してお
くのが一番いいと思います。

キャラクタセットは shift_jis で保存して shift_jis として httpヘッダ
ーに出力します。こうしておくと、PC 側で ServerXMLHTTP を使って読みだ
して、動的に関数を定義する事も可能になります。
<?
header( "Content-Type: text/plain; Charset=shift_jis" );
header( "pragma: no-cache" );
header( "Expires: Wed, 31 May 2000 14:59:58 GMT" );
header( "Cache-control: no-cache" );
?>
REM **********************************************************
REM 正規表現のトリム
REM **********************************************************
Function RegTrim( strValue )

	Dim regEx, str

	Set regEx = New RegExp
	regEx.IgnoreCase = True
	regEx.Pattern = "^[ \s]+"
	str = regEx.Replace( strValue, "" )
	regEx.Pattern = "[ \s]+$"
	RegTrim = regEx.Replace( str, "" )

End Function

この関数は、VBScript の正規表現を使って文字列の左右の空白文字を
漢字スペースも含めて取り除くものです。


PC 側の定義は通常通りですが、script 要素の src 属性で web 上の場所
を指定する事になります。拡張子を .wsf にしてWscript.exe か Cscript.exe
で実行します( 通常はエクスプローラからダブルクリックです )
<job>
<script
	language="VBScript"
	src="http://toolbox.winofsql.jp/vbs/regtrim.php"
></script>
<script language="VBScript">

str = RegTrim( getResource( "mydata" ) )
MsgBox( "/" & str & "/" )

</script>
<resource id="mydata">


    この部分のみ取り出します    


</resource>
</job>

resource 要素では、ソースコード内にテキストデータを用意できるので
ソースコードを準備しておいて、プログラムを登録したい時に使ったり
します



posted by lightbox at 2011-08-05 17:42 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする

2011年04月04日


IE限定。信頼するサイトのページをボタンから印刷プレビュー表示する


イントラネット用に IE6 のころから利用していた方法ですが、IE9 できちんと動くかどうかをテストしました。

IE は、スクリプトとして JavaScript 以外に VBScript を動かす事ができます。このへんがそもそも、他のブラウザと根本的に違うところで、イントラネット + 業務アプリケーションが IE 限定になる理由でもあります。

JavaScript でオブジェクトの処理を書くと、どういうわけかバグがあってうまく動かない事が過去に多かったので、誰も JavaScript を使わないのです。

CreateObject("InternetExplorer.Application") で、インターネットエクスプローラオブジェクトを作成して、現在のページをナビゲートして、その内容を印刷プレビューで表示します。

こういってしまうと簡単ですが、実際使えるものにする為に、二段階のタイマーを使っています。また、フォーカスの処理を行う為に、WScript.Shellを使っていますので、経験無い方には全くなんの事が解らない特殊なコードになっていますが、Excel との連携では似たような事は昔から良く行われています。

通常のインターネット では、セキュリティの設定で、危険な ActiveXは、無効になっていますが、社内であれば別に気にする事は無いので ActiveXを有効にして、OS の恩恵を業務で役立てているわけです。

この方法の良いところは、印刷時のみページをカスタマイズ可能であるというところで、ここでは最も基本的なボタンの非表示を印刷時に行っています。
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html>
<head>
<meta http-equiv="Content-type" content="text/html; charset=EUC-JP">

<style type="text/css">
.<?= $_GET['print_preview'] ?> {
	display:none;
}
</style>
<script language="VBScript">

Dim WshShell
Set WshShell = CreateObject( "WScript.Shell" )

Dim Ie
Const OLECMDID_PRINTPREVIEW = 7
Const OLECMDEXECOPT_DODEFAULT = 0

'************************************
' プレビュー開始
'************************************
Function DoPrintPreview()

	if not IsEmpty( Ie ) then
		Ie.Quit()
	end if

	Set Ie = CreateObject("InternetExplorer.Application")
	Ie.Visible = True
	Ie.Navigate(window.location&"?print_preview=preview")

	TimerPreview()

End Function

'************************************
' ドキュメントロード完了待ち処理
'************************************
function TimerPreview()

	if Ie.Busy then
		Call window.setTimeout( _
			"Call TimerPreview()", _
			100, _
			"VBScript" _
		)
	else
 		Call Ie.ExecWB( _
			OLECMDID_PRINTPREVIEW, _
			OLECMDEXECOPT_DODEFAULT _
		)
		Call window.setTimeout( _
			"Call TimerFocus()", _
			500, _
			"VBScript" _
		)
	end if

end function

'************************************
' フォーカス取得
'************************************
function TimerFocus()

	Call WshShell.AppActivate( "印刷プレビュー" )
	Ie.Visible = False

end function

</script>
<script for="window" event="onunload" language="VBScript">

	if not IsEmpty( Ie ) then
		Ie.Quit()
	end if

</script>
</head>
<body>
<input class="preview" type='button' value="印刷プレビュー" onclick='Call DoPrintPreview()' language="VBScript">
<br><br>
<img src="http://lh5.googleusercontent.com/_IzfbcNjqGuE/TZlg5usBDjI/AAAAAAAACX0/v0Q8yvsp9os/ie_trust_site.png" style='border:solid 0px #000000' />
</body>
</html>




タグ:IE VBScript
posted by lightbox at 2011-04-04 15:25 | VBS + インターネット | このブログの読者になる | 更新情報をチェックする
Seesaa の各ページの表示について
Seesaa の 記事がたまに全く表示されない場合があります。その場合は、設定> 詳細設定> ブログ設定 で 最新の情報に更新の『実行ボタン』で記事やアーカイブが最新にビルドされます。

Seesaa のページで、アーカイブとタグページは要注意です。タグページはコンテンツが全く無い状態になりますし、アーカイブページも歯抜けページはコンテンツが存在しないのにページが表示されてしまいます。

また、カテゴリページもそういう意味では完全ではありません。『カテゴリID-番号』というフォーマットで表示されるページですが、実際存在するより大きな番号でも表示されてしまいます。

※ インデックスページのみ、実際の記事数を超えたページを指定しても最後のページが表示されるようです

対処としては、このようなヘルプ的な情報を固定でページの最後に表示するようにするといいでしょう。具体的には、メインの記事コンテンツの下に『自由形式』を追加し、アーカイブとカテゴリページでのみ表示するように設定し、コンテンツを用意するといいと思います。


※ エキスパートモードで表示しています

アーカイブとカテゴリページはこのように簡単に設定できますが、タグページは HTML 設定を直接変更して、以下の『タグページでのみ表示される内容』の記述方法で設定する必要があります

<% if:page_name eq 'archive' -%>
アーカイブページでのみ表示される内容
<% /if %>

<% if:page_name eq 'category' -%>
カテゴリページでのみ表示される内容
<% /if %>

<% if:page_name eq 'tag' -%>
タグページでのみ表示される内容
<% /if %>
この記述は、以下の場所で使用します


Windows
container 終わり

フリーフォントで簡単ロゴ作成
フリーフォントでボタン素材作成
フリーフォントで吹き出し画像作成
フリーフォントではんこ画像作成
ほぼ自由に利用できるフリーフォント
フリーフォントの書体見本とサンプル
画像を大きく見る為のウインドウを開くボタンの作成

Android SDK ポケットリファレンス
改訂版 Webデザイナーのための jQuery入門
今すぐ使えるかんたん ホームページ HTML&CSS入門
CSS ドロップシャドウの参考デモ
Google Hosted Libraries
cdnjs
BUTTONS (CSS でボタン)
イラストAC
ぱくたそ
写真素材 足成
フリーフォント一覧
utf8 文字ツール
右サイド 終わり
base 終わり