SQLの窓

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 + インターネット | このブログの読者になる | 更新情報をチェックする

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年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年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>




タグ:VBScript IE
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 %>
この記述は、以下の場所で使用します
container 終わり



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

CSS ドロップシャドウの参考デモ
イラストAC
ぱくたそ
写真素材 足成
フリーフォント一覧
utf8 文字ツール
右サイド 終わり
base 終わり