2016年03月01日


テキストファイルの一括読み込み

Fso は事前に定義していてもいいですし、引数として渡して使用してもいいですが、このコードでは ErrorMessage と Fso がグローバル変数として関数内で定義されています。
Function GetTextFile( strPath )

	Dim ExecuteString
	Dim objHandle

	ExecuteGlobal "Dim ErrorMessage"

	ExecuteString = "Dim Fso : Set Fso = CreateObject( ""Scripting.FileSystemObject"" )"
	ExecuteGlobal ExecuteString

	ErrorMessage = ""
	on error resume next
	Set objHandle = Fso.OpenTextFile( strPath, 1 )
	if Err.Number <> 0 then
		ErrorMessage = Err.Description
		GetTextFile = ""
	else
		GetTextFile = objHandle.ReadAll
		objHandle.Close
	end if
	on error goto 0

End Function





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


2015年02月16日


URLEncode ( UTF-8 の文字列として全ての文字をパーセントエンコーディングします )

VBScript の内部コードから意図的に UTF-8 のキャラクタセットでテキストを書き込んで、バイナリストリームにコピーして、UTF-8 としてのバイトデータを1バイトづつ読み込んで『パーセントエンコーディング』で表現した文字列に変換しています。

※ UTF-8 として処理した場合、先頭3バイトは BOM なので取り除いています。
REM ***********************************************
REM UTF-8 のバイナリデータを作成して URLエンコード
REM ※ 全ての文字をパーセントエンコーディングします
REM ***********************************************
Function URLEncode(s1,s2, str)

	s1.Open
	s1.Charset = "utf-8"
	REM shift_jis で入力文字を書き込む
	s1.WriteText str
	REM コピーの為にデータポインタを先頭にセット
	s1.Position = 0

	REM バイナリで開く
	s2.Open
 	s2.Type = 1

	REM テキストをバイナリに変換
	s1.CopyTo s2
	s1.Close

	REM 読み込みの為にデータポインタを先頭にセット
	s2.Position = 0

	Dim Buffer : Buffer = ""
	REM BOMを取り去る
	s2.Read(3)
	Do while not s2.EOS
		LineBuffer = s2.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 & "%" & Cwork
			else
				Buffer = Buffer & "%0" & Cwork
			end if
		Next
 
	Loop

	s2.Close

	URLEncode = Buffer

End Function

▼ 呼び出しサンプル
<JOB>
<OBJECT id="s1" progid="ADODB.Stream" />
<OBJECT id="s2" progid="ADODB.Stream" />

<SCRIPT language="VBScript" src="http://winofsql.jp/VBScript/urlencode.vbs"></SCRIPT>

<SCRIPT language="VBScript">

str = "あいうえお"

Wscript.Echo URLEncode(s1,s2, str)

</SCRIPT>
</JOB>

REM を使ったり、条件式の = を使わずに、<> を使っているのは、ExecuteGlobal を使って動的に関数登録する為です。
VBScript では、x = y の解釈が 2 とおりあります。1 つ目は代入ステートメントとして解釈され、y の値が x に代入されます。2 つ目は x と y の値が等しいかどうかをテストする式として解釈されます。等しい場合、result は True です。それ以外の場合、result は False です。ExecuteGlobal ステートメントは常に 1 つ目の解釈を適用し、Eval メソッドは常に 2 つ目の解釈を適用します。
posted by at 17:47 | Comment(0) | 関数 | このブログの読者になる | 更新情報をチェックする


2014年07月11日


VBScript で『管理者として実行を強制する』処理

freefont_logo_hkreikk.png
昨今の Windows では、管理者権限が無いと失敗する処理が増えました。これは、バッチで自動化する時には使用できませんが、PC の前に操作員が居るという前提で実行可能です。

この処理は、右クリックで表示されるメニューの中の『管理者として実行』という項目に該当し、本来の英語表示は『runas』であると思われ、スクリプトの Operation"runas" を引き渡すと実現できます。

Shell.ShellExecute method

注意するのは、以下のコードでは VBScript に対して引数がある場合は利用できないと言う事です。引数がある場合はその引数の数に合わせてカスタマイズする必要があります。

ここでは、引数が無いという前提なので、次に実行する場合はダミーで "runas" という引数を渡しています。WScript.ScriptFullName & " runas"wscript.exe に対する引数で、runas が スクリプトに対する引数です。

こうする事によって、2回目の実行は、管理者権限で実行されている状態で、if Wscript.Arguments.Count = 0 then を通り抜ける事になります。

ShellExecute の3番目の引数が省略されていますが、これは作業ディレクトリの指定で、このパラメータを指定しない場合、現在の作業ディレクトリが使用されます。

ShellExecute の5番目引数は、ウインドウの表示方法で、1 は、ノーマル表示を意味します。
' 管理者として実行を強制する
Set obj = Wscript.CreateObject("Shell.Application")
if Wscript.Arguments.Count = 0 then
	obj.ShellExecute "wscript.exe", WScript.ScriptFullName & " runas", "", "runas", 1
	Wscript.Quit
end if

Wscript.Echo WScript.Arguments(0)





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


2014年05月29日


WMIのレジストリアクセスで、レジストリエントリの一覧を取得する VBScript クラス

freefont_logo_hkreikk.png
WMI : StdRegProv class
VBScript のクラス : Initialize イベント

Private Sub Class_Initialize は、コンストラクタのような働きをしますが、イベントなので引数を使うコンストラクタを実装する事ができません。また、そもそも同名のメソッドを作成できないので、注意が必要です。

ここでは、デフォルトのメソッドを定義して、メソッド名を指定せずに処理を実行しています。

Set Shell = CreateObject("Shell.Application")
if WScript.Arguments.Count = 0 then
	Shell.ShellExecute "cmd.exe", "/c Cscript.exe """ & Wscript.ScriptFullName & """ dummy & pause", "", "runas", 1
	Wscript.Quit
end if

Dim obj

' ************************************************
' インスタンス作成
' ************************************************
Set obj = new Wmireg

' ************************************************
' デフォルトメソッド実行
' ************************************************
Set list = obj(WMI_HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run")

' ************************************************
' 一覧表示
' ************************************************
For Each data in list.Keys

	Wscript.Echo data & " : " & list(data)

Next

const WMI_HKEY_CLASSES_ROOT = &H80000000
const WMI_HKEY_CURRENT_USER = &H80000001
const WMI_HKEY_LOCAL_MACHINE = &H80000002
const WMI_HKEY_USERS = &H80000003
const WMI_HKEY_CURRENT_CONFIG = &H80000005

const WMI_REG_SZ = 1 
const WMI_REG_EXPAND_SZ = 2 
const WMI_REG_BINARY = 3 
const WMI_REG_DWORD = 4 
const WMI_REG_MULTI_SZ = 7 

Class Wmireg

	Public objReg 

	' ************************************************
	' Initialize イベント
	' ************************************************
	Private Sub Class_Initialize

		Set objReg = _
			GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
			".\root\default:StdRegProv") 

	End Sub

	' ************************************************
	' サブキーの配列を取得
	' ************************************************
	Public Function GetLSubKeyArray( defKey, strPath )

		Dim aSubKeys,str

		objReg.EnumKey defKey, strPath, aSubKeys
		GetLSubKeyArray = aSubKeys
	 
	end function

	' ************************************************
	' 値の一覧の連想配列を取得( 規定のメソッド )
	' ************************************************
	Public Default Function GetLValueArray( defKey, strPath )

		Dim aValueNames, aValueTypes, strValue, aValue

		Set var = CreateObject( "Scripting.Dictionary" )

		objReg.EnumValues defKey, strPath,_ 
			aValueNames, aValueTypes 
		For i=0 To UBound(aValueNames)
			Select Case aValueTypes(i) 
				Case WMI_REG_SZ
					objReg.GetStringValue _
					defKey,strPath,aValueNames(i),strValue
					var(aValueNames(i)) = strValue
				Case WMI_REG_EXPAND_SZ
					objReg.GetExpandedStringValue _
					defKey,strPath,aValueNames(i),strValue
					var(aValueNames(i)) = strValue
				Case WMI_REG_DWORD
					objReg.GetDWORDValue _
					defKey,strPath,aValueNames(i),strValue
					var(aValueNames(i)) = strValue
				Case WMI_REG_MULTI_SZ
					objReg.GetMultiStringValue _
					defKey,strPath,aValueNames(i),aValue
					var(aValueNames(i)) = aValue
				Case WMI_REG_BINARY 
					objReg.GetBinaryValue _
					defKey,strPath,aValueNames(i),aValue
					var(aValueNames(i)) = aValue
			End Select 
		Next 

		Set GetLValueArray = var

	end function

	' ************************************************
	' 文字列セット
	' ************************************************
	Public Function SetLString( defKey, strPath, strName, strValue )

		objReg.SetStringValue _
			defKey,strPath,strName,strValue 

	end function

	' ************************************************
	' 整数セット
	' ************************************************
	Public Function SetLDword( defKey, strPath, strName, dwValue )

		objReg.SetDWORDValue _
			defKey,strPath,strName,dwValue

	end function

End Class



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


2014年01月09日


BatchHelperオブジェクト(32bit)のインストール

BatchHelper オブジェクトのメソッド等使用方法


インストーラのダウンロード

解凍して、setup.wsf を実行します。
<JOB>
<OBJECT id="WshShell" progid="WScript.Shell" />
<OBJECT id="Fs" progid="Scripting.FileSystemObject" />
<OBJECT id="Shell" progid="Shell.Application" />
<SCRIPT language=VBScript>
' 管理者として実行を強制する
Set obj = Wscript.CreateObject("Shell.Application")
if Wscript.Arguments.Count = 0 then
	obj.ShellExecute "wscript.exe", WScript.ScriptFullName & " runas", "", "runas", 1
	Wscript.Quit
end if

Set obj = GetObject ("winmgmts:\\.\root\cimv2")
Set objTargets = obj.ExecQuery( "select AddressWidth from Win32_Processor" )
Dim str
For Each objTarget in objTargets
	str = objTarget.AddressWidth
Next

strCurPath = WScript.ScriptFullName
Set obj = Fs.GetFile( strCurPath )
Set obj = obj.ParentFolder
strCurPath = obj.Path

Dim Lbox,bLbox,strDir,objExec

Set objFolder = Shell.Namespace( &H25 )
Set objFolderItem = objFolder.Self
strDir = objFolderItem.Path

if str <> "32" then
	strDir = Replace(Ucase(strDir),"SYSTEM32", "SYSWOW64")
end if

Wscript.Echo "インストール先 : " & strDir

on error resume next
' インストールされているかどうか
strValue = WshShell.RegRead("HKCR\Lbox.BatchHelper\CLSID\")
if Err.Number = 0 then
	' 現在の情報でアンインストール
	strValue = "HKCR\CLSID\" & strValue
	strValue = strValue & "\InprocServer32\"
	strValue = WshShell.RegRead(strValue)
	strValue = strDir & "\regsvr32.exe /u /s """ & strValue & """"
	Call WshShell.Run( strValue,,true )
end if
on error goto 0

' カレントファイルをシステムディレクトリにコピー
Call Fs.CopyFile( strCurPath & "\lbox.dll", strDir & "\", True )
Call Fs.CopyFile( strCurPath & "\BatchWsc.wsc", strDir & "\", True )
Call Fs.CopyFile( strCurPath & "\imgctl.dll", strDir & "\", True )
Call Fs.CopyFile( strCurPath & "\SaveJPG.dll", strDir & "\", True )
Call Fs.CopyFile( strCurPath & "\TransG32.dll", strDir & "\", True )

' lbox.dll のインストール
strValue = strDir & "\regsvr32.exe """ & strDir & "\lbox.dll"""
Call WshShell.Run( strValue,,true )

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

' BatchWsc.wsc のインストール
strValue = strDir & "\regsvr32.exe scrobj.dll /n /i:file://""" & strDir & "\BatchWsc.wsc" & """"
Call WshShell.Run( strValue,,true )

</SCRIPT>
</JOB>

▼ 以下のようにファイルがシステムディレクトリにコピーされます
' カレントファイルをシステムディレクトリにコピー
Call Fs.CopyFile( strCurPath & "\lbox.dll", strDir & "\", True )
Call Fs.CopyFile( strCurPath & "\BatchWsc.wsc", strDir & "\", True )
Call Fs.CopyFile( strCurPath & "\imgctl.dll", strDir & "\", True )
Call Fs.CopyFile( strCurPath & "\SaveJPG.dll", strDir & "\", True )
Call Fs.CopyFile( strCurPath & "\TransG32.dll", strDir & "\", True )

アンインストールは、uninstall.wsf を実行して下さい。( レジストリの情報を削除します )

以下は、ファイルを開くダイアログの使用例です( 単一ファイルと複数選択 )
Set obj = GetObject ("winmgmts:\\.\root\cimv2")
Set objTargets = obj.ExecQuery( "select AddressWidth from Win32_Processor" )
Dim str
For Each objTarget in objTargets
	str = objTarget.AddressWidth
Next

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

Set BatchHelper = Wscript.CreateObject( "Lbox.BatchHelper" )

' 単一ファイルの選択
Path = BatchHelper.OpenFileName( _
	"ファイルを開く", _
	"テキスト,*.txt,ログ,*.log,全て,*.*", _
	"C:\Windows\Microsoft.NET\Framework" )

' キャンセルは、空文字が返されます
if Path <> "" then
	BatchHelper.MsgOk( "ファイルが選択されました : " & vbCrLf & Path )
end if

' 複数ファイルの選択
Path = BatchHelper.OpenFileNames( _
	"複数ファイルの選択", _
	"テキスト,*.txt,ログ,*.log,全て,*.*", _
	"C:\Windows\Microsoft.NET\Framework" )

' キャンセルは、空文字が返されます
if Path <> "" then
	BatchHelper.MsgOk( "ファイルが選択されました : " & vbCrLf & Path )

	' 複数のファイルのパスは、TABコードで分割されます
	aData = Split(Path, vbTab)
	BatchHelper.MsgOk("/" & aData(0) & "/")
end if




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


2013年12月05日


VBScript で標準的に「ファイルを開く」ダイアログを利用する唯一の方法

フォーカス(アクティブ)の問題とか、一般にファイルの種類は指定できないので不完全ではありますが、自分でアプリケーションを作成せずに利用する事ができます。

元々、ファイルのアップロードのみに使われるものですからそのような目的でしか利用する事はできません( ファイルの保存用はありません )

' 管理者として実行を強制する
Set obj = Wscript.CreateObject("Shell.Application")
if Wscript.Arguments.Count = 0 then
	obj.ShellExecute "wscript.exe", WScript.ScriptFullName & " runas", "", "runas", 1
	Wscript.Quit
end if

Function OpenLocalFileName( )

	' ファイルシステムを操作するオブジェクト
	Set Fso = WScript.CreateObject( "Scripting.FileSystemObject" )
	' テンポラリフォルダ
	TempDir =  Fso.GetSpecialFolder(2)
	on error resume next
	' テンポラリフォルダに空の "local.htm" を作成
	Set objHandle = Fso.CreateTextFile( TempDir & "\local.htm", True, True )
	if Err.Number <> 0 then
		Exit Function
	end if
	objHandle.Close
	on error goto 0

	' IE を操作するオブジェクト
	Set IEDocument = WScript.CreateObject( "InternetExplorer.Application" )
	' テンポラリフォルダに作成したファイルを開く
	IEDocument.Navigate( TempDir & "\local.htm" )
	' 『ファイルを開く』為のコンテンツを作成
	IEDocument.document.getElementsByTagName("BODY")(0).innerHTML = "<input id=FilePath type=file>"
	' 『ファイルを開く』為に、ボタンをクリックする
	IEDocument.document.getElementById("FilePath").click
	' ファイルを選択していない場合は終了
	if IEDocument.document.getElementById("FilePath").value = "" then
		OpenLocalFileName = ""
		IEDocument.Quit
		Set IEDocument = Nothing
		Exit Function
	end if

	' 選択したファイルのパスを戻す
	OpenLocalFileName = IEDocument.document.getElementById("FilePath").value

	' IE を終了
	IEDocument.Quit
	Set IEDocument = Nothing

End Function


' 呼び出し
strValue = OpenLocalFileName
if strValue = "" then
	Wscript.Quit
end if

' 選択したファイルを表示
Wscript.Echo strValue

昔はセキュリティが甘かったので、ローカルファイルでは無く about:blank で処理できていたのですが、今はインターネットオプションの『サーバーにファイルをアップロードするときにローカル ディレクトリのパスを含める』を有効にしないと、fakepath というパスのみが返るようになっています。それを回避する為にローカルのファイルを使うようにしていますが、その際に管理者権限でないと動作しないので、『管理者として実行を強制』しています

※ UserAccounts.CommonDialog は、XPのみで利用できます


BatchHelper オブジェクト をインストールすると以下が使用できます

【 OpenFileName 】
Path = BatchHelper.OpenFileName( [Title], [Filter], [DefaultDir], [DefaultExt], [DefaultName] )

コモンダイアログでファイルのパスを取得します 

Title (省略可): ダイアログのタイトル
Filter (省略可): フィルターリスト ( 例: "CSV,*.csv,全て,*.*" )
DefaultDir (省略可): 初期ディレクトリ
DefaultExt (省略可): デフォルトの拡張子
DefaultName (省略可): デフォルトのファイル名 

キャンセル時、Path は "" (空文字列) になります

▼ 実行ソースコードサンプル
Set BatchHelper = Wscript.CreateObject("Lbox.BatchHelper")

Path = BatchHelper.OpenFileName( )

Wscript.Echo Path




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


2013年11月30日


架空氏名作成スクリプト

こちらは教育漢字です

選択する漢字によっては、さらに架空度が増します。
<JOB>
<OBJECT id="WshShell" progid="WScript.Shell" />
<SCRIPT language=VBScript>
' ***********************************************************
' 処理開始
' ***********************************************************
nMax = 20	' 取得する人数

Call Crun()

' 1、2 は教育漢字の最初
strName1 = "愛悪圧安暗案以位囲委意易異移胃衣遺医域育一印員因引飲院右宇羽"
strName2 = "雨運雲営映栄永泳英衛液益駅円園延沿演遠塩央往応横王黄億屋恩温"
strName3 = "男也一行樹之朗七人"
strName4 = "子代美恵"

For i = 1 to nMax

	' 姓1文字目
	nTarget = Random( 1, Len(strName1) )
	strName = Mid( strName1, nTarget, 1 )

	' 1文字目と2文字目が一致したら除外
	nTarget2 = nTarget
	Do while( nTarget = nTarget2 )
		nTarget2 = Random( 1, Len(strName1) )
	Loop

	' 姓2文字目
	strName = strName & Mid( strName1, nTarget2, 1 ) & " "

	' 名1文字目
	nTarget = Random( 1, Len(strName2) )
	strName = strName & Mid( strName2, nTarget, 1 )

	' 性別
	nTarget = Random( 0, 1 )

	' 性別によって名2文字目を決定
	if nTarget = 0 then
		nTarget = Random( 1, Len(strName3) )
		strName = strName & Mid( strName3, nTarget, 1 )
	else
		nTarget = Random( 1, Len(strName4) )
		strName = strName & Mid( strName4, nTarget, 1 )
	end if
	
	Wscript.Echo strName

Next

' ***********************************************************
' 範囲内ランダム値取得
' ***********************************************************
Function Random( nMin, nMax )

	Randomize
	Random = nMin + Int(Rnd * (nMax - nMin + 1))

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

</SCRIPT>
</JOB>




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


2013年11月28日


文字列連結では無く、配列を利用した VBScript のクラス

そもそも、VBScript のクラスが珍しいですが、ExecuteGlobal や、ReDim Preserve は、VBScript のテクニックとしてとても重要なステートメントです。実際大量に文字列連結すると、大きくなるほどハフォーマンスが落ちます。しかし、ReDim では単純なメモリの増量のようなので( C++ レベルではそんなに単純でも無いでしょうけれど )かなり高速に動作するはずです。

もっと複雑な処理では、Dictionary オブジェクトを使用すればいいとおもいますが、文字列を作成して処理するだけなら( 例えば HTA における HTML 作成 )こちらのほうが便利です。
Set MyBuffer = CreateBuff

Wscript.Echo MyBuffer.Length

MyBuffer.SetData("001")

Wscript.Echo MyBuffer.Length

MyBuffer.SetData("日本語表示")
MyBuffer.SetData("XYZ")

Wscript.Echo MyBuffer.Length

' 内部配列の直接参照
Wscript.Echo MyBuffer.Buff(1)
MyBuffer.Buff(1) = "日本語"

' 改行コードで連結した内部配列
Wscript.Echo MyBuffer.GetData(vbCrLf)

' カンマで連結した内部配列
Wscript.Echo MyBuffer.GetData(",")


Class buffCon

	Public Buff()

	' ************************************************
	' コンストラクタ
	' ************************************************
	Public Default Function InitSetting()

		Redim Buff(0)

	end function

	' ************************************************
	' メソッド ( データセット )
	' ************************************************
	function Length()

		if IsEmpty( Buff(0) ) then
			Length = 0
		else
			Length =  Ubound(Buff)+1
		end if

	end function

	' ************************************************
	' メソッド ( データセット )
	' ************************************************
	function SetData( strRow )

		if IsEmpty( Buff(0) ) then
			Buff(0) = strRow
		else
			ReDim Preserve Buff(Ubound(Buff)+1)
			Buff(Ubound(Buff)) = strRow
		end if

	end function
	 
	' ************************************************
	' メソッド ( データ取得 )
	' ************************************************
	function GetData( strDelim )

		GetData = Join( Buff, strDelim )

	end function

End Class

' **********************************************************
' バッファ作成
' **********************************************************
Function CreateBuff( )

	ExecuteString = "Dim gblCreateBuff : "
	ExecuteString = ExecuteString & "Set gblCreateBuff = new buffCon"
	ExecuteGlobal ExecuteString
	Call gblCreateBuff

	Set CreateBuff = gblCreateBuff

End Function




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


2013年11月27日


管理者として実行を強制し、ANHTTPD を実行し、MySQLサービスを起動し、 エクスプローラで ANHTTPD のディレクトリを開け、ブラウザで、ANHTTPD の仮想ディレクトリを開くスクリプト

昔、『開発始めますよスクリプト』と読んでいました。当時は、管理者で実行とか必要なかったですが、今はたぶんサービスの実行で権限を求められると思います。
' 管理者として実行を強制する
Set obj = Wscript.CreateObject("Shell.Application")
if Wscript.Arguments.Count = 0 then
	obj.ShellExecute "wscript.exe", WScript.ScriptFullName & " runas", "", "runas", 1
	Wscript.Quit
end if

' MySQL サービスの表示名(DisplayName)
Dim MySQL_Name : MySQL_Name = "MySQL56"
' ANHTTPD のインストールディレクトリ
Dim Httpd_Path : Httpd_Path = "c:\httpd142p"
' ANHTTPD の常に使う仮想パス
Dim Httpd_VPath : Httpd_VPath = "http://localhost"
' ブラウザのパス
Dim Browser_Path : Browser_Path = "C:\Program Files\Google\Chrome\Application\chrome.exe"


' **********************************************************
' アプリケーション起動用
' **********************************************************
Set WshShell = Wscript.CreateObject( "WScript.Shell" )

' **********************************************************
' プロセス( httpd.exe ) を開始
' **********************************************************
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colProcesses = objWMIService.ExecQuery("Select * from Win32_Process Where Name = 'httpd.exe'") 
flg = false
For Each objProcess in colProcesses 
	flg = true
Next
if Not flg then
	WshShell.CurrentDirectory = Httpd_Path
	WshShell.Run( "httpd.exe" )
end if

' **********************************************************
' サービス( MySQL )
' **********************************************************
Set colRunningServices = objWMIService.ExecQuery("Select * from Win32_Service Where DisplayName = '" & MySQL_Name & "'") 
For Each objService in colRunningServices 
	if objService.State = "Stopped" then
		objService.StartService()
	end if
Next 

' **********************************************************
' ANHTTPD のインストールディレクトリをエクスプローラで開く
' **********************************************************
str = "explorer.exe /e," & Httpd_Path
WshShell.Run( str )


' **********************************************************
' ANHTTPD の常に使う仮想パス Google Chrome 
' **********************************************************
str = """" & Browser_Path & """"  & Httpd_VPath
WshShell.Run( str )



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


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拡張 | このブログの読者になる | 更新情報をチェックする


×

この広告は1年以上新しい記事の投稿がないブログに表示されております。