2013年11月21日


IE拡張 : テキストエリア入力拡張





テキストエリアの内容を転送して、簡単な拡張編集ができます。( 簡易的なプレビューも可能です )

▼ IE に登録された画面を伴うコード部分
<meta http-equiv="content-type" content="text/html; charset=SHIFT_JIS">
<SCRIPT language="VBScript">
	Dim WshShell,RegName,strLocation,obj,doc,Fs
	Dim nFirstLen,objFirstTextRange,BakPath,bMax

	bMax = False

	Set WshShell = CreateObject("WScript.Shell")
	Set Fs = CreateObject( "Scripting.FileSystemObject" )

	RegName = "−【テキストエリア入力拡張】"

	BakPath = "C:\laylaClass\menuex"

	' *************************************************
	' ウインドウサイズ
	' *************************************************
	window.dialogWidth = "900px"
	window.dialogHeight = "610px"

'	window.dialogTop = "100px"
'	window.dialogLeft = (window.screen.width/2)&"px"

	on error resume next
	ExecuteGlobal "function dummy(): end function"
	on error goto 0

Function setObj( src )
	Set obj = src
End Function
</SCRIPT>

<SCRIPT language="JavaScript">
setObj(external.menuArguments.event.srcElement);
var shift_key;
var ctrl_key;

function easyPreview() {

	document.getElementById("preview").style.display = '';
	document.getElementById("text").style.height = '330px';
	document.getElementById("preclose").style.display = '';

	if ( bMax ) {
		
		document.getElementById("preview").style.height = (window.screen.height - 450) + "px";
	}

	var target = document.getElementById("preview").contentWindow.document;
	target.open;

	var str="";
str+="<style type=\"text/css\"> \n";
str+="* { \n";
str+="	font-size:12px; \n";
str+="} \n";
str+="</style> ";
	target.write(str);
str="";
str+="<"+"script type=\"text/javascript\"> \n";
str+="window.onerror = function() { \n";
str+="	return true; \n";
str+="} \n";
str+="</"+"script> ";
	target.write(str);

	if ( event.shiftKey ) {
		target.write("<pre>\n");
	}

	var cnvtext,cnvarr;

	if ( event.ctrlKey ) {
		cnvtext = document.getElementById("text").value;
		if ( event.shiftKey ) {
			cnvarr = cnvtext.match(/(https?|ftp)(:\/\/[-_.!~*\'()a-zA-Z0-9;\/?:\@&=+\$,%#]+)/g );
			cnvtext = "";
			for( i = 0; i < cnvarr.length; i++ ) {
				cnvtext += "<a href=" + cnvarr[i] + " target='_blank'>" + cnvarr[i] + "</a>\n";
			}
		}
		else {
			cnvtext = cnvtext.replace(/&/g, "&amp;" );
			cnvtext = cnvtext.replace(/</g, "&lt;" );
			cnvtext = cnvtext.replace(/>/g, "&gt;" );
			cnvtext = cnvtext.replace(/(https?|ftp)(:\/\/[-_.!~*\'()a-zA-Z0-9;\/?:\@&=+\$,%#]+)/g, "<a href='$1$2' target='_blank'>$1$2</a>" );
		}
	}
	else {
		cnvtext = document.getElementById("text").value;
	}

	target.write(cnvtext);

	if ( event.shiftKey ) {
		target.write("</pre>\n");
	}

	target.close();

}

function closePreview() {

	document.getElementById("preview").style.display="none";
	document.getElementById("preclose").style.display="none";
	document.getElementById("text").style.height = '550px';

	if ( bMax ) {
		document.getElementById("text").style.height = (window.screen.height - 120) + "px"
	}

}


function createURLLink() {

	var txt = "";
	var strUrl = "";
	var strTarget = "";

	var shift_key_local = event.shiftKey;

	var objSelectedText = document.selection
	var objTextRange = objSelectedText.createRange( )

	if (objTextRange.text.length == 0 ) {
		return;
	}
	try {
		if ( shift_key_local ) {
			strTarget = "_self"
		}
		else {
			strTarget = "_blank"
		}
		strUrl = external.menuArguments.prompt("URLリンク作成( " + strTarget + " )","http://");
		if ( strUrl != "" && strUrl != "http://" && strUrl+"" != "null" ) {
			txt = objTextRange.text
			txt = "<a href=\""+strUrl+"\" target=\"" + strTarget + "\">"+txt+"</a>"
			objTextRange.text = txt;
		}
	}catch( e ){}

}

function createIFrame() {

	document.getElementById("text").focus();
	setTimeout("createIFrameCore()", 100 );
}
function createIFrameCore() {

	var txt = "";
	var strUrl = "";
	var str;

	var objSelectedText = document.selection
	var objTextRange = objSelectedText.createRange( )

	if (objTextRange.text.length == 0 ) {
		try {
			strUrl = external.menuArguments.prompt("IFRAME作成","http://");
			if ( strUrl != "" && strUrl != "http://" && strUrl+"" != "null" ) {
				str="";
				str+="<"+"iframe \n";
				str+="	src=\""+strUrl+"\" \n";
				str+="	name=\"myframe\" \n";
				str+="	frameborder=\"no\" \n";
				str+="	scrolling=\"no\" \n";
				str+="	width=\"600\" \n";
				str+="	height=\"480\" \n";
				str+="></"+"iframe> \n";
				objTextRange.text = str;
			}
		}catch( e ){ }
	}
}

function createBold() {

	document.getElementById("text").focus();
	setTimeout("createBoldCore()", 100 );
}
function createBoldCore() {

	var txt = "";
	var strUrl = "";

	var objSelectedText = document.selection
	var objTextRange = objSelectedText.createRange( )

	if (objTextRange.text.length == 0 ) {
		try {
			objTextRange.text = "<b></b>";
		}catch( e ){}
		return;
	}
	try {
		txt = objTextRange.text;
		txt = "<b>"+txt+"</b>";
		objTextRange.text = txt;
	}catch( e ){}

}
function createTable() {

	document.getElementById("text").focus();
	setTimeout("createTableCore()", 100 );
}
function createTableCore() {

	var txt = "";
	var strUrl = "";

	var str1,str2;
str1="";
str1+="<table>\n";
str1+="<tr>\n";
str1+="<td>\n";
str1+="<!-- (left) -->\n";
str2="";
str2+=" \n";
str2+="</td> \n";
str2+="<td>\n";
str2+="<!-- (right) -->\n";
str2+="</td>\n";
str2+="</tr>\n";
str2+="</table>\n";

	var objSelectedText = document.selection
	var objTextRange = objSelectedText.createRange( )

	if (objTextRange.text.length == 0 ) {
		try {
			objTextRange.text = str1+str2;
		}catch( e ){}
		return;
	}
	try {
		txt = objTextRange.text;
		txt = str1+txt+str2;
		objTextRange.text = txt;
	}catch( e ){}

}
function convertHtml() {

	var txt = "";
	var strUrl = "";

	var objSelectedText = document.selection
	var objTextRange = objSelectedText.createRange( )

	if (objTextRange.text.length == 0 ) {
		return;
	}
	try {
		txt = objTextRange.text
		txt = txt.replace(/&/g, "&amp;" );
		txt = txt.replace(/</g, "&lt;" );
		txt = txt.replace(/>/g, "&gt;" );
		objTextRange.text = txt;
	}catch( e ){}

}
function decodeHtml() {

	var txt = "";
	var strUrl = "";

	var objSelectedText = document.selection
	var objTextRange = objSelectedText.createRange( )

	if (objTextRange.text.length == 0 ) {
		return;
	}
	try {
		txt = objTextRange.text
		txt = txt.replace(/&lt;/g, "<" );
		txt = txt.replace(/&gt;/g, ">" );
		txt = txt.replace(/&amp;/g,'&')
		objTextRange.text = txt;
	}catch( e ){}

}

function removeSpace() {

	var txt = "";
	var strUrl = "";

	var objSelectedText = document.selection
	var objTextRange = objSelectedText.createRange( )

	if (objTextRange.text.length == 0 ) {
		return;
	}
	try {
		txt = objTextRange.text
		txt = txt.replace(/\s+/g, " " );
		objTextRange.text = txt;
	}catch( e ){}

}


function insertPre() {


	shift_key = false
	if ( event.shiftKey ) {
		shift_key = true
	}
	document.getElementById("text").focus();
	setTimeout("insertPreCore()", 100 );
}
function insertPreCore() {

	var txt = "";

	var objSelectedText = document.selection
	var objTextRange = objSelectedText.createRange( )

	if (objTextRange.text.length == 0 ) {
		try {
			if ( shift_key ) {
				objTextRange.text = "<"+"script type=\"text/javascript\">\n\n\n</"+"script>\n";
			}
			else {
				objTextRange.text = "<pre>\n\n\n</pre>\n";
			}
		}catch( e ){}
	}
	else {
		try {
			txt = objTextRange.text
			if ( shift_key ) {
				txt = "<"+"script type=\"text/javascript\">\n"+txt+"\n</"+"script>\n"
			}
			else {
				txt = "<pre>\n"+txt+"\n</pre>"
			}
			objTextRange.text = txt;
		}catch( e ){}
	}

}

function insertBr() {

	document.getElementById("text").focus();
	setTimeout("insertBrCore()", 100 );
}
function insertBrCore() {

	var objSelectedText = document.selection
	var objTextRange = objSelectedText.createRange( )

	if (objTextRange.text.length == 0 ) {
		try {
			objTextRange.text = "<br />\n";
		}catch( e ){}
	}

}

function insertStyle() {

	shift_key = false;
	ctrl_key = false;
	if ( event.shiftKey ) {
		shift_key = true;
	}
	if ( event.ctrlKey ) {
		ctrl_key = true;
	}
	document.getElementById("text").focus();
	setTimeout("insertStyleCore()", 100 );
}
function insertStyleCore() {

	var objSelectedText = document.selection
	var objTextRange = objSelectedText.createRange( )

	if (objTextRange.text.length == 0 ) {
		try {
			if ( shift_key ) {
				objTextRange.text = " style='color:#0000ff'";
			}
			else {
				if ( ctrl_key ) {
					objTextRange.text = " style='color:#228b22'";
				}
				else {
					objTextRange.text = " style='color:#ff0000'";
				}
			}
		}catch( e ){}
	}

}

</SCRIPT>
<html>
<head>
<title>−【テキストエリア入力拡張】</title>
<meta http-equiv="content-type" content="text/html; charset=SHIFT_JIS">
<STYLE type="text/css">
* {
	font-size:12px;
}
body {
	margin:0;
	background-color:#C5D1A5;
}
</STYLE>

<SCRIPT language="VBScript">

' 関数定義用
Function ReturnText()

	if Not confirm( "データを転送しますか?   " ) then
		Exit Function
	end if

	if UCase( obj.tagName ) = "TEXTAREA" then
		if nFirstLen <> 0 then
			objFirstTextRange.text = document.getElementById("text").value
		else
			obj.value = document.getElementById("text").value
		end if
	end if

	if UCase( obj.tagName ) = "INPUT" then
		if UCase( obj.type ) = "TEXT" then
			if nFirstLen <> 0 then
				objFirstTextRange.text = document.getElementById("text").value
			else
				obj.value = document.getElementById("text").value
			end if
		end if
	end if

	on error resume next
	Set OutObj = Fs.OpenTextFile( BakPath & "\TextareaEx.bak", 2, True )
	OutObj.Write document.getElementById("text").value & ""
	OutObj.Close
	on error goto 0

	window.close()

End Function

function SetTab( )

	if window.event.keyCode <> 9 then
		exit function
	end if

	window.event.returnValue = false

	Dim objTextArea,objTextRange,nLen,nChars,strData

	set objTextArea = document.selection
	set objTextRange = objTextArea.createRange( )
	on error resume next
	strData = objTextRange.text
	nLen = Len( strData )
	if window.event.shiftKey then
		strData = Replace( strData, vbLf & vbTab, vbLf )
		if Left( strData, 1 ) = vbTab then
			strData = Right( strData, Len( strData ) - 1 )
		end if
	else
		strData = Replace( strData, vbLf, vbLf & vbTab )
		strData = vbTab & strData
	end if

	if nLen = 0 then
		objTextRange.text = strData
	else
		objTextRange.text = strData & vbLf
	end if

	on error goto 0

end function 

Function CursorTop()

	document.getElementById("text").focus()
	Set objFocus = document.getElementById("text").createTextRange()
	Call objFocus.collapse(True)

End Function


Dim objFocus
' **********************************************************
' サーチ
' **********************************************************
function TextSearch()

	if Trim(document.getElementById("search").value&"") = "" then
		Exit Function
	end if

	Dim objTextArea,objTextRange
	Set objTextArea = document.selection
	Set objTextRange = objTextArea.createRange( )

	if objTextRange.text = "" then
		Set objFocus = document.getElementById("text").createTextRange()
		if objFocus.findText( document.getElementById("search").value ) then
			objFocus.select()
		end if
	else
		objFocus.collapse( false )
		if objFocus.findText( document.getElementById("search").value ) then
			objFocus.select()
		end if
	end if

End Function

Function keyCheck(  )
	if window.event.keyCode = 27 then
		Call closePreview()
	end if

End Function

Function maxWindow()

	window.dialogLeft = "0"
	window.dialogTop = "0"
	window.dialogWidth = (window.screen.width-5) & "px"
	window.dialogHeight = (window.screen.height - 70) & "px"
	bMax = True
	document.getElementById("text").style.height = (window.screen.height - 120) & "px"
	document.getElementById("maxw").style.display = "none"

End Function
</SCRIPT>
<base target="_self">
</head>
<BODY onKeydown='keyCheck()'>
<INPUT
	id="retbutton"
	type="button"
	value="戻す"
	onClick="Call ReturnText()"
>
<INPUT
	id="search"
	type="text"
>
<INPUT
	type="button"
	value="検索"
	onClick="Call TextSearch()"
>
折り返さない <input
	type="checkbox"
	onClick='if me.checked then document.getElementById("text").wrap="off" else document.getElementById("text").wrap="soft" end if'
>
&nbsp;&nbsp;&nbsp;&nbsp;
<input type=button value="リンク" language="javascript" onClick='createURLLink()'
	onMouseover='document.getElementById("message").value = "選択部分に対してURLを入力してリンクを作成します ( そのままクリックすると _blank で作成。SHIFTキーを押しながら開くと _self で作成)"'
	onMouseout='document.getElementById("message").value = ""'
>
<input type=button value="pre" language="javascript" onClick='insertPre()'>
<input type=button value="bold" language="javascript" onClick='createBold()'>
<input type=button value="table" language="javascript" onClick='createTable()'>
 / <input type=button value="色" language="javascript" onClick='insertStyle()'
	onMouseover='document.getElementById("message").value = "通常 : 赤、SHIFTキー : 青、CTRLキー : 緑"'
	onMouseout='document.getElementById("message").value = ""'
>
<input type=button value="br" language="javascript" onClick='insertBr()'>
<input type=button value="iframe" language="javascript" onClick='createIFrame()'
	onMouseover='document.getElementById("message").value = "IFRAME を挿入します"'
	onMouseout='document.getElementById("message").value = ""'
>
 / <input type=button value="&amp;lt;" language="javascript" onClick='convertHtml()'>
<input type=button value="HTML" language="javascript" onClick='decodeHtml()'>
<input type=button value="改行削除" language="javascript" onClick='removeSpace()'
	onMouseover='document.getElementById("message").value = "選択した文字列を、replace(/\s+/g, \" \" ) で置き換えます"'
	onMouseout='document.getElementById("message").value = ""'
>
 / <input type=button value="プレビュー" language="javascript" onClick='easyPreview()'
	onMouseover='document.getElementById("message").value = "SHIFT : PRE 要素内にセット、CTRL : URL 部分のみリンク変換、CTRL+SHIFT : URL部分のみ取り出してリンク変換"'
	onMouseout='document.getElementById("message").value = ""'
>

&nbsp;&nbsp;&nbsp;&nbsp;<INPUT style='' type="button" id="maxw" value="最大化" onClick='maxWindow()' >

<br>
<TEXTAREA
	id="text"
	name="text"
	style='width:100%;height:550px;'
	onKeydown='Call SetTab()'
></TEXTAREA>
<IFRAME
	id="preview"
	frameborder="yes"
	scrolling="yes"
	width="100%"
	height="205"
	style='display:none'
></IFRAME>
<INPUT style='display:none;float:right;' type="button" id="preclose" value="プレビュー結果を閉じる" onClick='closePreview()' >
<INPUT id="message" type=text style='border:none 0px #000000;width:700px;background-color:#C5D1A5' />

</BODY>
</html>
<SCRIPT for=window event=onload language="VBScript">

' onload 処理
Set doc = obj.document

set objTextArea = doc.selection
set objFirstTextRange = objTextArea.createRange( )
on error resume next
strData = objFirstTextRange.text
nFirstLen = Len( strData )
on error goto 0

if nFirstLen <> 0 then
	document.getElementById("text").value = strData
else
	strTag = obj.tagName
	if UCase( strTag ) = "A" then
		strWork = obj.innerText
		strWork = strWork & vbCrLf & obj.href
		document.getElementById("text").value = strWork
	else
		if UCase( obj.tagName ) = "TEXTAREA" then
			document.getElementById("text").value = obj.innerText
			strCommand = "document.getElementById(""text"").scrollTop = 0"
			Call window.setTimeout( strCommand, 100 )
			Call window.setTimeout( "Call CursorTop()", 500 )
		else
			if UCase( obj.tagName ) = "INPUT" then
				if UCase( obj.type ) = "TEXT" then
					document.getElementById("text").value = obj.value
				end if
			else
				document.getElementById("text").value = obj.innerHTML
			end if
		end if
	end if
end if

</SCRIPT>

関連する記事

Seesaa のカテゴリをソート(通常と逆順と記事が多い順)する VBScript で記述された IE 拡張


posted by at 21:07 | Comment(0) | IE拡張 | このブログの読者になる | 更新情報をチェックする



Seesaa のカテゴリをソート(通常と逆順と記事が多い順)する VBScript で記述された IE 拡張





インストール場所は、通常 C:\laylaClass\menuex となります。 アンインストールは、アンインストール用のスクリプトを実行した後、C:\laylaClass\menuex\Seesaa_catsort.htm を削除して下さい。他のインストールされたファイルが無い場合は、C:\laylaClass\menuex も削除して下さい。

インストール









インストール用ソースコード
( ie_Seesaa_catsort_120417.wsf )
<JOB>
<COMMENT>
************************************************************
IE 拡張メニューインストーラ

■ Seesaa 用カテゴリソート

■著作権その他

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

<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" )



' //////////////////////////////////////////////////////////
' インストール時の表示名
strProgName	= "Seesaa 用カテゴリソート"
' インストールファイル名( 拡張子は .htm となる )
strProgFile	= "Seesaa_catsort"
' メニューとウインドウのタイトルに表示する文字列
' レジストリに登録するのでユニークである必要があります
strRegName	= "Seesaa 用カテゴリソート"
' 対象となるコンンテンツ
nTargetType 	= &H4
' &H3F : UNKNOWNを除く全て
' &H1  : DEFAULT
' &H2  : IMAGE
' &H4  : CONTROL
' &H8  : TABLE
' &H10 : TEXTSELECT
' &H20 : ANCHOR
' &H40 : UNKNOWN

' 画面ありかどうか
bIsGUI = False
' //////////////////////////////////////////////////////////

print strProgName & " をインストールします"
if not OkCancel( "インストールしてもよろしいですか?" ) then
	Wscript.Quit
end if

' ファイルシステムオブジェクト作成
GetFso

strInstallPath1 = "c:\laylaClass"
strInstallPath2 = "c:\laylaClass\menuex"
strInstallPath3 = "c:\laylaClass\menuex\" & strProgFile & ".htm"
on error resume next
if not Fso.FolderExists( strInstallPath1 ) then
	Call Fso.CreateFolder( strInstallPath1 )
	if Err.Number <> 0 then
		ErrorFlg = True
	end if
end if
if not Fso.FolderExists( strInstallPath2 ) then
	Call Fso.CreateFolder( strInstallPath2 )
	if Err.Number <> 0 then
		ErrorFlg = True
	end if
end if
on error goto 0

Call PutTextFile( strInstallPath3, _
Replace(GetInline("MenuExt"),"$REGNAME", strRegName ) )

' レジストリ処理用オブジェクト作成
GetWshShell

on error resume next
WshShell.RegWrite _
	"HKCU\Software\Microsoft\Internet Explorer\MenuExt\"&strRegName&"\", _
	strInstallPath3, _
	"REG_SZ"
WshShell.RegWrite _
	"HKCU\Software\Microsoft\Internet Explorer\MenuExt\"&strRegName&"\Contexts", _
	nTargetType, _
	"REG_DWORD"

if bIsGUI then
	' この定義があると、画面あり
	WshShell.RegWrite _
	"HKCU\Software\Microsoft\Internet Explorer\MenuExt\"&strRegName&"\Flags", _
	&H1, _
	"REG_DWORD"
end if
on error goto 0

print "処理が終了しました"

Wscript.Quit

</SCRIPT>

<COMMENT>
******** ここからがコード ********
</COMMENT>
<RESOURCE id="MenuExt">
<![CDATA[
<html>
<head>
<meta http-equiv="content-type" content="text/html; charset=SHIFT_JIS">
<title>$REGNAME</title>
<script language="VBScript">

	Dim RegName,obj,doc,win

	RegName = "Seesaa 用カテゴリソート"

	' SHIFTとCTRL用変数
	Dim keyflg1,keyflg2
	keyflg1 = False
	keyflg2 = False

Function setObj( src )
	Set obj = src
End Function
</script>
<script language="JavaScript">
setObj(external.menuArguments.event.srcElement);
</script>
<base target="_self">
</head>
<body>
<input id="btn" type=button onClick='keyflg1=window.event.shiftKey:keyflg2=window.event.ctrlKey'>
<script language="VBScript">

	' ボタンの呼び出し
	document.getElementById("btn").click()

	' ADO 用の定数
	Const adVarChar = 130	' Null で終了する Unicode 文字列
	Const adInteger = 3	' 4 バイトの符号付き整数

	' IEが表示しているページの document オブジェクト
	Set doc = external.menuArguments.document
	' IEが表示しているページの window オブジェクト
	Set win = external.menuArguments

	Dim colTable,objTable
	Dim colInput,colNum

	Set colInput = Nothing

	' テーブル要素の一覧
	Set colTable = doc.getElementsByTagName("TABLE")
	For Each objTable In colTable
		' カテゴリ一覧テーブルの選択
		if objTable.className = "entrytable" then
			Set colInput = objTable.getElementsByTagName("A")
			Set colINum = objTable.getElementsByTagName("INPUT")
			Exit For
		end if
	Next

	Dim Rs,nCount,nMax,I,aData()

	' colInput は、対象テーブル内の A オブジェクト
	if Not colInput is Nothing then

		' A の数
		nCount = colInput.length
		' 仕様上2つで一行
		nMax = nCount / 2

		' ソート用レコードセット作成
		Set Rs = CreateObject("ADODB.Recordset")
		' メモリテーブルを作成
		' CTRL( 数値ソート )
		if keyflg2 then
			Rs.Fields.Append "ソートキー", adInteger
		' それ以外はカテゴリ名による文字列ソート
		else
			Rs.Fields.Append "ソートキー", adVarChar,255
		end if
		Rs.Fields.Append "順序", adInteger
		Rs.Open

		' データ保存
		For I = 0 to nMax - 1
			' 行追加
			Rs.AddNew
			' CTRL
			if keyflg2 then
				Rs.Fields("ソートキー").Value = Cint(colInput(I*2+1).firstChild.nodeValue)
			' カテゴリ名による文字列ソート
			else
				Rs.Fields("ソートキー").Value = colInput(I*2).firstChild.nodeValue
			end if
			Rs.Fields("順序").Value = I
			Rs.Update

		Next

		' ソート指定
		if keyflg1 or keyflg2 then
			' 逆ソート
			Rs.Sort = "ソートキー desc"
		else
			Rs.Sort = "ソートキー"
		end if

		' ポインタを先頭に移動
		Rs.MoveFirst

		' 配列を現在必要な数で動的作成
		ReDim aData(nMax)

		' 元の順序に現在の 順序x10+100 を設定
		I = 0
		Do while not Rs.EOF

			aData(Rs.Fields("順序").Value) = I*10 + 100

			Rs.MoveNext
			I = I + 1

		Loop

		' レコードセットを閉じる
		Rs.Close

		' 現在のフィールドにソート順序を設定
		For I = 0 to Ubound(aData) - 1

			colINum(I).Value = aData(I)

		Next

	end if

</script>
</body>
</html>
]]>
</RESOURCE>

</JOB>

インストール後は、一旦 IE を終了させて下さい。

関連する記事

ADO を使ったメモリソート



posted by at 19:40 | Comment(0) | IE拡張 | このブログの読者になる | 更新情報をチェックする


2013年11月17日


runas 使ってコマンドプロンプトを VBScript で管理者として実行

元々、Shell としての機能にある、右クリックメニューの『管理者として実行』をスクリプトで処理する方法です。(『runas』がそれに該当します )

コマンドプロンプトは、管理者として実行すると、タイトルにその旨が表示されるので確認して下さい。



Shell.ShellExecute method
Set obj = Wscript.CreateObject("Shell.Application")
obj.ShellExecute "cmd.exe", "/k", "", "runas", 1



posted by at 01:49 | Comment(0) | Shell.Application | このブログの読者になる | 更新情報をチェックする


2013年11月16日


ODBC ドライバの列挙

レジストリアクセスは一覧取得なので WMI が必要です。
ソートには ADO を使用します。
表示を コマンドプロンプトに表示する為に、CSCRIPT.EXE での実行を強制しています。
Set WshShell = WScript.CreateObject("WScript.Shell")

Crun

' ***********************************************************
' 処理開始
' ***********************************************************
Const HKEY_LOCAL_MACHINE = &H80000002
Const adVarChar = 200

Dim ErrorMessage

Set objRegistry = GetObject("Winmgmts:root\default:StdRegProv")

strPath = "SOFTWARE\ODBC\ODBCINST.INI\ODBC Drivers"
bRet = WMIRegEnumValues( HKEY_LOCAL_MACHINE, strPath, aNames, aTypes )

if not bRet then
	Wscript.Echo ErrorMessage
	Wscript.Quit
end if

Set Rs = CreateObject("ADODB.Recordset")
Rs.Fields.Append "ソートキー", adVarChar,255
Rs.Open

For Each data In aNames
	Rs.AddNew
	Rs.Fields("ソートキー").value = data
Next

Rs.Sort = "ソートキー"
Rs.MoveFirst

Do while not Rs.EOF
	Wscript.Echo Rs.Fields("ソートキー").value & ""
	Rs.MoveNext
Loop

Rs.Close

' **********************************************************
' 列挙
' **********************************************************
Function WMIRegEnumValues ( nType, strPath, aNames, aTypes )
	WMIRegEnumValues = False

	on error resume next
	WMIRet = objRegistry.EnumValues( nType, strPath, aNames, aTypes )
	if Err.Number <> 0 then
		ErrorMessage = Err.Description
		Exit Function
	end if
	if WMIRet <> 0 then
		ErrorMessage = Hex( WMIRet )
		Exit Function
	end if
	on error goto 0

	WMIRegEnumValues = True
End Function

' ***********************************************************
' Cscript.exe で強制実行
' ***********************************************************
Function Crun( )

	Dim str

	str = WScript.FullName
	str = Right( str, 11 )
	str = Ucase( str )
	if str <> "CSCRIPT.EXE" then
		str = WScript.ScriptFullName
		strParam = " "
		For I = 0 to Wscript.Arguments.Count - 1
			if instr(Wscript.Arguments(I), " ") < 1 then
				strParam = strParam & Wscript.Arguments(I) & " "
			else
				strParam = strParam & Dd(Wscript.Arguments(I)) & " "
			end if
		Next
		Call WshShell.Run( "cmd.exe /c cscript.exe " & Dd(str) & strParam & " & pause", 3 )
		WScript.Quit
	end if

End Function

' ***********************************************************
' ダブルクォート
' ***********************************************************
Function Dd( strValue )

	Dd = """" & strValue & """"

End function

関連する記事

ADO を使ったメモリソート


posted by at 03:01 | Comment(0) | サンプル | このブログの読者になる | 更新情報をチェックする


2013年08月07日


Yahoo!メールで簡単メール送信( CDO.Message+VBScript関数 )

ポートが 465 なのは、SSL を使う場合のポートで、587 でも別の仕様で暗号化が可能ですが、Cdo が使えるのは 465 の標準の SSLのみです。

フリーメールで安心して使えそうなのは、Yahoo!メールとGmail です。Gmail でも同様に使えるはずです。
( hotmail は、Cdo で利用できませんが、587 の使えるソフトならば可能です )

Cdo で、587 番を使ったサブミッションポートの利用は可能ですが、その場合は認証部分が暗号化されないので内部的なメール送信で使う事をお勧めします。( 他のソフトならば認証部分だけの暗号化は可能です )
Dim ErrorMessage
' **********************************************************
' Yahoo!メール送信
' **********************************************************
YahooMail = "???????@yahoo.co.jp"
strName = "日本語で自分の名前"
strPass = "パスワード"
strTo = "宛先 <宛先のメールアドレス>"
strSubject = "Yahoo!メール+CDO.Message"
strBody = "本文" & vbCrLf + "です"

if YahooSend( YahooMail, strName, strPass, strTo, strSubject ,strBody ) then
	MsgBox("メールを送信しました")
else
	MsgBox( ErrorMessage )
end if

' **********************************************************
' Yahoo!メールで単純メール送信
' **********************************************************
Function YahooSend( _
	mailaddr, _
	jname, _
	pass, _
	mailto, _
	subj, _
	body _
)

	Dim Cdo

	Set Cdo = WScript.CreateObject("CDO.Message")

	Dim aAuth

	aAuth = Split( mailaddr, "@" )
	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/sendusername") = aAuth(0)
	Cdo.Configuration.Fields.Item _ 
	 ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = pass

	if jname <> "" then
		Cdo.From = jname & " <" & mailaddr & ">"
	else
		Cdo.From = mailaddr
	end if
	Cdo.To = mailto
	Cdo.Subject	= subj
	Cdo.Textbody = body

	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = true
	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.mail.yahoo.co.jp"
	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465

	Cdo.Configuration.Fields.Update

	YahooSend = true

	on error resume next
	Cdo.Send
	if Err.Number <> 0 then
		ErrorMessage = Err.Description
		YahooSend = false
	end if
	on error goto 0

End Function

Gmail は、サーバーが smtp.gmail.com です。


タグ:通信
posted by at 16:38 | Comment(0) | ツール | このブログの読者になる | 更新情報をチェックする



ServerXMLHTTP を使用してバイナリデータのダウンロードを行うスクリプト

殆どがServerXMLHTTPオブジェクトにまかされていて、イベントも存在しないのであまり巨大なファイルはダウンロードしてはいけません。

ですが、10メガ以内のファイル( 単純なフリーソフト等 ) ならば、特に問題は出ないと思います。( これに関してはかなり長い間運用して来ました )
Dim ErrorMessage
' **********************************************************
' ファイルをダウンロード
' **********************************************************
strUrl = "http://www5f.biglobe.ne.jp/~t-susumu/dl/tpad/tpad109.zip"
strPath = "C:\Users\lightbox\Documents\Downloads\tpad109.zip"
if HTTPDownload( strUrl, strPath ) then
	MsgBox("ダウンロードが成功しました")
else
	MsgBox( ErrorMessage )
end if


' **********************************************************
' ダウンロード
' 1) ダウンロードする URL
' 2) 保存するPC内のパス
' **********************************************************
Function HTTPDownload( strUrl, strPath )

	Dim objHTTP

	Set objHTTP = WScript.CreateObject("Msxml2.ServerXMLHTTP")

	HTTPDownload = True

	on error resume next
	Call objHTTP.Open("GET", strUrl, False )
	if Err.Number <> 0 then
		ErrorMessage = Err.Description
		HTTPDownload = False
		Exit Function
	end if
	on error goto 0

	on error resume next
	objHTTP.Send
	if Err.Number <> 0 then
		ErrorMessage = Err.Description
		HTTPDownload = False
		Exit Function
	end if
	on error goto 0

	Dim Stream

	Set Stream = WScript.CreateObject("ADODB.Stream")

	Stream.Open
	Stream.Type = 1	' バイナリ
	Stream.Write objHTTP.responseBody
	Stream.SaveToFile strPath, 2 ' 上書き
	Stream.Close

End Function




タグ:通信
posted by at 15:41 | Comment(0) | ツール | このブログの読者になる | 更新情報をチェックする



VBScript で、グローバルな変数を関数内で定義する方法

グローバルな変数を作成して各関数から参照させるには、ソースコードの先頭で Dim で宣言するのが通常ですが、関数内から ExecuteGlobal ステートメントを呼び出す事によって同じ結果を得る事ができます。但し、この際変数名は文字列で指定する必要があるので、ソース全体(実行単位)で『定義済変数』という位置付けで申し合わせる必要があります
' **********************************************************
' グローバルな変数を関数内で定義する方法
' ( 文字列を作って、グローバル名前空間で実行 )
' **********************************************************

Call MyObject( "WshShell", "WScript.Shell" )

' 実行デスト
Call WshShell.Run( "notepad" )

' **********************************************************
' 関数内よりグローバル変数にオブジェクトをセットする
' **********************************************************
Function MyObject( strName, strObjName )

	Dim ExecuteString

	Call DimGlobal( strName )	' この部分は無くても動作します

	ExecuteString = "Set " & strName & " = WScript.CreateObject(""" & strObjName & """)"

	ExecuteGlobal ExecuteString

End Function

' **********************************************************
' 関数内よりグローバル変数を作成する
' **********************************************************
Function DimGlobal( strName )

	Dim ExecuteString

	ExecuteString = "Dim " & strName

	ExecuteGlobal ExecuteString

End Function




posted by at 14:58 | Comment(0) | 基本事項 | このブログの読者になる | 更新情報をチェックする



XCOPY.EXE を使用した、『新しいファイルのみのバックアップ』を行うスクリプト

バックアップ先は、例えばリムーバルの保存用のハードディスクとすると、そこにこのスクリプトを置いてフォルダ名を決定して実行すると、そのフォルダの中にバックアップされます。

2回目以降は、新しいファイルしかバックアップされないので、新しいファイルが無い場合は『0 個のファイルをコピーしました』と表示されます

バックアップするフォルダのパスは、フルパスで設定しますが、ネットワークドライブが対象である事を想定しています。ですから、事前に仮想ドライブを設定する処理を追加する事もありますし、\\PC名\共有 という書き方でもかまいません。
Set WshShell = WScript.CreateObject("WScript.Shell")

Dim strCommand,strMessage
Dim strFrom,strTo

' コピー元
strFrom = "バックアップするフォルダのパス"
' コピー先
strTo = "バックアップ先"

' **********************************************
' 実行確認ダイアログ
' **********************************************
strMessage = strFrom & " の内容を   " & vbCrLf
strMessage = strMessage & strTo & " へ   " & vbCrLf
strMessage = strMessage & "新しいファイルのみコピーします" & vbCrLf & vbCrLf
strMessage = strMessage & "よろしいですか?"
if vbCancel = MsgBox( strMessage, vbOKCancel, "実行確認") then
	Wscript.Quit
end if

' **********************************************
' XCOPY
' **********************************************
strCommand = "cmd.exe /c XCOPY """ & strFrom & """ """ & strTo & """"
strCommand = strCommand & " /D /E /C /S /Y & echo 処理が終了しました & pause"
Call WshShell.Run( strCommand,, True )



posted by at 10:56 | Comment(0) | ツール | このブログの読者になる | 更新情報をチェックする


2013年01月19日


VBScript の既定のスクリプトホストの変更

『スクリプトホスト』は、.vbs と .wsf という拡張子に関係付けられた、VBScript のソースコードを読み込んで実行するアプリケーションの事です。

VBScript では、cscript.exewscript.exe という二つのスクリプトホストがあり、前者はコマンドプロンプト用で、後者は Windows アプリケーション用で、実際どのような違いが出るかというと、Wscript.echo という処理が、前者では標準出力に出力されるのに対して、後者ではメッセージボックスに出力されるというところです。

当然、コマンドプロンプトを前提にして作成されたスクリプトで Wscript.echo が使われていると、Windows アプリケーションでは、メッセージボックスが表示されつづけるという問題が出てしまいます。ですから、どちらのスクリプトホストで実行されるかは良く考えて運用する必要があるわけです。

そもそも、デフォルトのスクリプトホストは、Windows アプリケーションとして起動されるので、エクスプローラから開いた場合は Windows アプリケーションとして実行されてしまいます。これらの問題を避けるには、いずれかのスクリプトホストを //H:CScript 引数を付けて実行するとデフォルトのスクリプトホストが変更されます( 戻す場合は //H:WScript で実行 )

さらに、これらの設定の大元はレジストリの記述なので、そこを変更してしまうと前述の切り替えを行わなくても同じ効果を得る事ができてしまいますが、元に戻すには直接レジストリを書き換える必要があります。
( 以下は、.vbs 用で、.wsf は WSFFile というエントリが別にあって管理されています )
HKEY_CLASSES_ROOT\VBSFile\Shell\Open\Command
HKEY_CLASSES_ROOT\VBSFile\Shell\Open2\Command

または

HKEY_LOCAL_MACHINE\SOFTWARE\Classes\VBSFile\Shell\Open\Command
HKEY_LOCAL_MACHINE\SOFTWARE\Classes\VBSFile\Shell\Open2\Command
>reg query HKEY_CLASSES_ROOT\VBSFile\Shell\Open\Command

HKEY_CLASSES_ROOT\VBSFile\Shell\Open\Command
    (既定)    REG_EXPAND_SZ    "%SystemRoot%\System32\WScript.exe" "%1" %*


>reg query HKEY_CLASSES_ROOT\VBSFile\Shell\Open2\Command

HKEY_CLASSES_ROOT\VBSFile\Shell\Open2\Command
    (既定)    REG_EXPAND_SZ    "%SystemRoot%\System32\CScript.exe" "%1" %*
>cscript /?
Microsoft (R) Windows Script Host Version 5.8
Copyright (C) Microsoft Corporation 1996-2001. All rights reserved.

使い方 : CScript scriptname.extension [オプション...] [引数...]

オプション :
 //B         バッチ モード : スクリプトのエラーおよびプロンプトを非表示にする
 //D         アクティブ デバッグを使用可能にする
 //E:engine  スクリプト実行時にエンジンを使用する
 //H:CScript 既定のスクリプト ホストを CScript.exe に変更する
 //H:WScript 既定のスクリプト ホストを WScript.exe に変更する (既定値)
 //I         対話モード (既定値、//B と逆の動作)
 //Job:xxxx  WSF ジョブを実行する
 //Logo      ロゴを表示する (既定値)
 //Nologo    ロゴを表示しない : 実行時に見出しを表示しない
 //S         このユーザーの現在のコマンド ライン オプションを保存する
 //T:nn      秒単位のタイムアウト時間 :  スクリプトを実行できる時間の最大値
 //X         デバッガでスクリプトを実行する
 //U         コンソールからリダイレクトされた I/O に Unicode を使用する



タグ:WScript cscript
posted by at 02:30 | Comment(0) | 基本事項 | このブログの読者になる | 更新情報をチェックする


2011年12月16日


ユーザー環境変数の設定

PC名とユーザ名が必要です
' **********************************************************
' PC 名と ユーザ名を取得
' **********************************************************
Dim WshNetwork : Set WshNetwork = CreateObject( "WScript.Network" )
Dim strUser : strUser = WshNetwork.UserName
Dim strMachine : strMachine = WshNetwork.ComputerName

Dim strComputer : strComputer = "."
Dim obj : Set obj = GetObject("winmgmts:\\"&strComputer&"\root\cimv2")


' **********************************************************
' ユーザ環境変数を登録
' **********************************************************
Dim objEnv : Set objEnv = obj.Get("Win32_Environment").SpawnInstance_

objEnv.Name = "MyENV"
objEnv.UserName = strMachine & "\" & strUser
objEnv.VariableValue = "設定しました"
objEnv.Put_



posted by at 09:10 | Comment(0) | WMI | このブログの読者になる | 更新情報をチェックする