Windows Script Compornents(SCRIPT COM)の雛型作成スクリプト

Windows Script Compornents は、簡単に言えば「VBScript で作成する COM」なんですが、
その言葉からは「容易」と受け取られると思いますが、それほど容易でも無いので
はやらなかったんでは無いかと思ってしまいます。

かなり昔、ウィザードのアプリケーションを Microsoft からダウンロードできたのですが
日本語版が無く、熟練した者からすれば殆ど価値無い内容でした。
たしか、当時マニュアルは CHM で日本語版がダウンロードできたのですが、
↓に日本語ページありますし。

※ Microsoft のドキュメントはこちら


とは言うものの、限定された条件下では、関係者を幸せに導いてくれる可能性もあるので、
当時のウィザードと同程度の利用価値のある「雛型作成スクリプト」を作ってみました。

ブラウザでダウンロード

このスクリプトはカレントに4つのファイルを作成しますので、
必ずダウンロードしてから実行して下さい。

1) script_com_年月日時間.wsc
2) install_com_年月日時間.wsf
3) uninstall_com_年月日時間.wsf
4) test_com_年月日時間.vbs

ダウンロードして、エクスプローラからダブルクリック

コマンドプロンプトが表示されて、pause 状態なりますが
コマンドプロンプトは閉じて下さい。

上記画像のような状態になりますが、WSC のインストールはされていません。
script_com_年月日時間.wsc が本体なので、このファイルを変更して
自分専用の WSC を作成してインストールします。

ただ、既に動くようになっていますので、そのままインストールしても
動作しますし、インストールしてから変更しても、「スクリプト」なんで
全然問題ありません

一つだけ注意するのが、登録される「プログラムID」に、このままでは
年月日時間 が付加されたままだという事です

必要ならば、まず「プログラムID」の変更を行う

以下のソースコードが、WSC の先頭の内容ですが、先頭部分の registration にある
progid="Lbox.COM20081108173655" が「プログラムID」で、年月日時間
が付加されてしまっています。

これは、システム上1つしか無いものにしなければならないので、
そのままでも使えるようにこうしてあります。
自由に変更して、自分用の「プログラムID」にする事ができます。

例えば Lbox.COM20081108173655 => MyCOM.tool 
と変更する事を前提に話をすすめて行きます

<?xml version="1.0" encoding="shift_jis" ?>
<component>

<registration
	description="WSC Skeleton"
	progid="Lbox.COM20081108173655"
	version="1.00"
	classid="{704E3422-E729-43EA-B133-A7682355DFFA}"
>
</registration>

↓以下のように変更

<?xml version="1.0" encoding="shift_jis" ?>
<component>

<registration
	description="WSC Skeleton"
	progid="MyCOM.tool"
	version="1.00"
	classid="{704E3422-E729-43EA-B133-A7682355DFFA}"
>
</registration>

classid は、元々ユニークになるように作成されています。
これは、雛型を作成するたびに変わりますが、変更しないで下さい

インストール方法

インストーラも作成されていますが、「プログラムID」を変更したので
そのままでは使えません。以前のプログラム ID を変更して実行する必要
がありますが、これは運用上必要になった場合のサンプルで、
今インストールする場合はもっと簡単な方法があります

見たままですが、登録と登録解除ができるようになっています。
これは、regsvr32.exe で登録(登録解除)するのと同じ効果があります

ソースの中の「プログラムID」できちんと登録してくれますし、
簡単に登録解除可能なので、登録して下さい

↑のようなメッセージボックスが出て登録されます
( 結局 regsvr32.exe のメッセージですが )

実行テスト

test_com_年月日時間.vbs をエディタで変更してテストします。
( プログラムID の変更 )

Set obj = CreateObject( "Lbox.COM20081108173655" )
obj.ScriptDir = WScript.ScriptFullName
obj.SelectDir( "選択" )

↓以下のように変更

Set obj = CreateObject( "MyCOM.tool" )
obj.ScriptDir = WScript.ScriptFullName
obj.SelectDir( "選択" )

test_com_年月日時間.vbs をエクスプローラからダブルクリックすると、
以下のようなウインドウが表示されるはずです

※ 動かない場合は、script_com_年月日時間.wsc の内容が正しく変更されているか確認

システムの登録場所は、厳密には2箇所ですが、プログラムIDは
レジストリエディタで確認できます

( もう一つは CLSID )

インストーラとアンインストーラの変更

インストーラは、プログラムID とソース名を変更する必要があります
( 以前のプログラムIDの削除と再登録を行っています )

アンインストーラはプログラムID の変更が必要です

インストーラのソースコード

<JOB>
<SCRIPT
	language="VBScript"
	src="http://homepage2.nifty.com/lightbox/laylaClass.vbs">
</SCRIPT>

<SCRIPT language=VBScript>
' ***********************************************************
' 処理開始
' ***********************************************************
Call laylaFunctionTarget( "http://homepage2.nifty.com/lightbox/" )
Call laylaLoadFunction( "baseFunction.vbs" )

Crun
GetWshShell

on error resume next
strValue = WshShell.RegRead("HKCR\Lbox.COM20081108173655\CLSID\")
if Err.Number = 0 then
	' 現在の情報でアンインストール
	strValue = "HKCR\CLSID\" & strValue
	strValue = strValue & "\ScriptletURL\"
	strValue = WshShell.RegRead(strValue)
	strValue = "regsvr32.exe scrobj.dll /s /u /n /i:""" & strValue & """"
	Call RunSync( strValue )
end if
on error goto 0

' インストール
strValue = "regsvr32.exe scrobj.dll /n /i:file://""" & ScriptDir & "\script_com_20081108173655.wsc" & """"
	Call RunSync( strValue )

Wscript.Echo "インストールが終了しました"

</SCRIPT>

</JOB>

WSC 雛型の内容

プロパティやメソッドの実装サンプルとして以下のような機能があります

1) スクリプトディレクトリの記憶( 内部変数の使用 )

2) クリップボードの読み書き( プロパティ )

3) MDB 作成( メソッド )

4) ファイルを開くダイアログ( Windows2000 でも動きます )
	※ XP 以降だともっといいのがあります

5) ディレクトリ選択( テストスクリプトで実行する内容 )

6) ファイルを表示しながらディレクトリ選択

<?xml version="1.0" encoding="shift_jis" ?>
<component>

<registration
	description="WSC Skeleton"
	progid="MyCOM.tool"
	version="1.00"
	classid="{704E3422-E729-43EA-B133-A7682355DFFA}"
>
</registration>

<public>

<comment>
************************************************************
* プロパティ
************************************************************
</comment>
	<property name="Clipboard">
		<get/>
		<put/>
	</property>
	<property name="ScriptDir">
		<get/>
		<put/>
	</property>
	<property name="LastError">
		<get/>
	</property>

<comment>
************************************************************
* メソッド
************************************************************
</comment>
	<method name="CreateMdb">
		<PARAMETER name="Path"/>
		<PARAMETER name="bDelete"/>
	</method>
	<method name="OpenFileName">
	</method>
	<method name="SelectDir">
		<PARAMETER name="strTitle"/>
	</method>
	<method name="SelectDirWidthFile">
		<PARAMETER name="strTitle"/>
	</method>

</public>

<script language="VBScript">
<![CDATA[

Dim ScriptDir
Dim ErrorMessage

' ************************************************
' プロパティ処理の実装
' ************************************************
' --------------------------------------
' クリップボード
' --------------------------------------
function get_Clipboard()

	Dim objIE

	Set objIE = CreateObject("InternetExplorer.Application")
	objIE.Navigate("about:blank")
	get_Clipboard = objIE.document.parentwindow.clipboardData.GetData("Text")
	objIE.Quit
	Set objIE = Nothing

end function
function put_Clipboard(srt)

	Dim objIE

	Set objIE = CreateObject("InternetExplorer.Application")
	objIE.Navigate("about:blank")
	objIE.document.parentwindow.clipboardData.SetData "Text", srt
	objIE.Quit
	Set objIE = Nothing

end function
' --------------------------------------
' スクリプトディレクトリの保存
' ScriptDir = WScript.ScriptFullName
' を必ず実行してから ScriptDir プロパティ
' を使用する
' --------------------------------------
function get_ScriptDir()

	get_ScriptDir = ScriptDir

end function
function put_ScriptDir(str)

	Dim Fs,obj

	Set Fs = CreateObject( "Scripting.FileSystemObject" )

	ScriptDir = str
	Set obj = Fs.GetFile( ScriptDir )
	Set obj = obj.ParentFolder
	ScriptDir = obj.Path

	Set Fs = Nothing

end function
' --------------------------------------
' 直近に発生したエラーメッセージ
' --------------------------------------
function get_LastError()

	get_LastError = ErrorMessage

end function

' ************************************************
' MDB 作成( bDelete が True で事前削除 )
' ************************************************
function CreateMdb( Path, bDelete )

	Dim Adox,Fs

	Set Adox = CreateObject( "ADOX.Catalog" )
	Set Fs = CreateObject( "Scripting.FileSystemObject" )

	if Fs.FileExists( Path ) then
		if bDelete then
			on error resume next
			Call Fs.DeleteFile( Path )
			if Err.Number <> 0 then
				CreateMdb = Err.Description
				Exit Function
			end if
			on error goto 0
		end if
	end if

	on error resume next
	Adox.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _
		"Data Source=" & Path & ";"
	if Err.Number <> 0 then
		CreateMdb = Err.Description
		Exit Function
	end if
	on error goto 0

	Set Adox.ActiveConnection = Nothing
	Set Adox = Nothing
	Set Fs = Nothing

end function

' **********************************************************
' ファイルを開くダイアログ
' **********************************************************
function OpenFileName( )

	Dim objIE,WshShell

	Set objIE = CreateObject("InternetExplorer.Application")
	objIE.Navigate( "about:blank" )
	objIE.document.getElementsByTagName("BODY")(0).innerHTML = _
		"<INPUT id=FilePath type=file>"

	objIE.Visible = True
	Set WshShell = CreateObject( "WScript.Shell" )
	WshShell.AppActivate "about:blank"
	Set WshShell = Nothing
	objIE.Visible = False

	objIE.document.getElementById("FilePath").click
	if objIE.document.getElementById("FilePath").value = "" then
		OpenFileName = ""
		objIE.Quit
		Set objIE = Nothing
		Exit Function
	end if

	OpenFileName = objIE.document.getElementById("FilePath").value

	objIE.Quit
	Set objIE = Nothing

End Function

' **********************************************************
' フォルダ選択(1)
' **********************************************************
Function SelectDir( strTitle )

	Dim Shell,obj

	Set Shell = CreateObject( "Shell.Application" )

	Set obj = Shell.BrowseForFolder( 0, strTitle, 11 + &h40, 0 )
	if obj is nothing then
		Set Shell = Nothing
		SelectDir = ""
		Exit Function
	end if
	if not obj.Self.IsFileSystem then
		Set Shell = Nothing
		ErrorMessage = "ファイルシステムではありません"
		SelectDir = ""
		Exit Function
	end if

	SelectDir = obj.Self.Path

	Set Shell = Nothing

End Function

' **********************************************************
' フォルダ選択(2) : ファイルも表示される
' **********************************************************
Function SelectDirWidthFile( strTitle )

	Dim Shell,obj

	Set Shell = CreateObject( "Shell.Application" )

	on error resume next
	Set obj = Shell.BrowseForFolder( 0, strTitle, 11 + &h4000 + &h40, 0 )
	if Err.Number <> 0 then
		Set Shell = Nothing
		ErrorMessage = "ファイルが選択されました"
		SelectDirAndFile = ""
		Exit Function
	end if
	on error goto 0
	if obj is nothing then
		Set Shell = Nothing
		SelectDirAndFile = ""
		Exit Function
	end if
	if not obj.Self.IsFileSystem then
		Set Shell = Nothing
		ErrorMessage = "ファイルシステムではありません"
		SelectDirAndFile = ""
		Exit Function
	end if

	SelectDirAndFile = obj.Self.Path

	Set Shell = Nothing

End Function

]]>
</script>

</component>