WEB 関数 -- WEB WSH

  使用サンプル



http://lightbox.matrix.jp/ginpro/patio.cgi?mode=view&no=8&w=910


2007/03/11 現在



  laylaClass.vbs



  
REM ***********************************************************
REM laylaClass : インターネット用汎用関数セット
REM ***********************************************************
Function laylaGetVersion()

REM	laylaGetVersion = "2007.02.25"
	laylaGetVersion = "2007.03.04"

End Function 

REM ***********************************************************
REM Msxml2.ServerXMLHTTP : プロキシ設定は以下を参照
REM http://support.microsoft.com/default.aspx?scid=kb;ja;289481
REM ***********************************************************
Function LoadMsxmlHTTP( )

	if not IsObject( objSrvHTTP ) then
		Set objSrvHTTP = CreateObject("Msxml2.ServerXMLHTTP.3.0")
	end if 

End Function
Function HTTPGet( strUrl )

	LoadMsxmlHTTP

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

	objSrvHTTP.Send

	HTTPGet = objSrvHTTP.responseText

End Function
Function laylaFunctionTarget( strUrl )

	laylaFunctionTargetUrl = strUrl

End Function
Function laylaLoadFunction( strUrl )

	Dim str

	if Left( strUrl, 7 )  <> "http://" then
		strUrl = laylaFunctionTargetUrl & strUrl
	end if

	str = HTTPGet( strUrl )
	if not IsEmpty( str ) then
		ExecuteGlobal str
	end if

End Function
Function laylaLoadFunctionPrefix( strUrl, strPrefix, aData )

	Dim str,I

	if Left( strUrl, 7 )  <> "http://" then
		strUrl = laylaFunctionTargetUrl & strUrl
	end if

	str = HTTPGet( strUrl )
	if not IsEmpty( str ) then
		For I = 0 to Ubound( aData )
			str = Replace( str, aData( I ), strPrefix & aData( I ) )
		Next
		ExecuteGlobal str
	end if

End Function

REM ***********************************************************
REM laylaClass : グローバル
REM ***********************************************************
Dim laylaFunctionTargetUrl
Dim ErrorMessage
Dim objSrvHTTP
Dim objRegistry

Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002

  

※ URL より取得する関数定義(laylaLoadFunction で実装する関数定義) は UTF-8 で記述する必要があります
※ ExecuteGlobal の仕様により、 条件に = は使ってはいけません。 <> の else で使います
※ REM を使っているのは、そうするのが VBS の解析で必要だろうと思ったからです
※ API が IE とは違います。プロキシ設定が必要な場合は別に設定する必要があります



  baseFunction.vbs

  
REM **********************************************************
REM シングルクォートで囲む
REM **********************************************************
Function Ss( strValue )

	Ss = "'" & strValue & "'"

End Function

REM **********************************************************
REM ダブルクォートで囲む
REM **********************************************************
Function Dd( strValue )

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

End Function

REM **********************************************************
REM 文字列のバイト計算
REM **********************************************************
function ByteLen( strTarget )

	Dim i,nLen,nRet,strMoji,nAsc

	nRet = 0

	nLen = Len( strTarget )

	For i = 1 to nLen
		nRet = nRet + 2
		strMoji = Mid( strTarget, i, 1 )
		nAsc = Asc( strMoji )
		if &H20 <= nAsc and nAsc <= &H7E then
			nRet = nRet - 1
		end if
		if &HA1 <= nAsc and nAsc <= &HDF then
			nRet = nRet - 1
		end if
	Next

	ByteLen = nRet

end function

REM **********************************************************
REM 指定数、指定文字列左側を埋める
REM **********************************************************
Function Lpad( strValue, str, nLen )

	Lpad = Right( String(nLen,str) & strValue, nLen )

End Function
Function LpadB( strValue, str, nLen )

	Dim strWork,nLen2
	
	strWork = Right( String(nLen,str) & strValue, nLen )
	nLen2 = nLen

	Do While ByteLen( strWork ) > nLen
		nLen2 = nLen2 - 1
		if nLen2 <= 0 then
			Exit Do
		end if
		strWork = Right( String(nLen,str) & strValue, nLen2 )
	Loop
	LpadB = strWork

End Function

REM **********************************************************
REM 指定数、指定文字列右側を埋める
REM **********************************************************
Function Rpad( strValue, str, nLen )

	Rpad = Left( strValue & String(nLen,str), nLen )

End Function
Function RpadB( strValue, str, nLen )

	Dim strWork,nLen2

	strWork = Left( strValue & String(nLen,str), nLen )
	nLen2 = nLen

	Do While ByteLen( strWork ) > nLen
		nLen2 = nLen2 - 1
		if nLen2 <= 0 then
			Exit Do
		end if
		strWork = Left( strValue & String(nLen,str), nLen2 )
	Loop
	RpadB = strWork

End Function

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


REM **********************************************************
REM Wscript で実行された場合はメッセージを表示して終了
REM **********************************************************
Function WscriptQuit( )

	if ScriptType <> 1 then
		Exit Function
	end if

	Dim str

	str = WScript.FullName
	str = Right( str, 11 )
	str = Ucase( str )
	if str <> "CSCRIPT.EXE" then
		strMessage = "コマンドプロンプトより cscript " & WScript.ScriptFullName
		strMessage = strMessage & " と指定して実行して下さい   " & vbCrLf & vbCrLf
		strMessage = strMessage & "( この文字列をクリップボードにコピーしたい場合は"
		strMessage = strMessage & " ctrl+c です )"
		WScript.Echo strMessage
		WScript.Quit
	end if

End Function

REM **********************************************************
REM Wscript で実行された場合は Cscript で実行しなおす
REM **********************************************************
Function Crun( )

	if ScriptType <> 1 then
		Exit Function
	end if

	Dim str

	str = WScript.FullName
	str = Right( str, 11 )
	str = Ucase( str )
	if str <> "CSCRIPT.EXE" then
		str = WScript.ScriptFullName
		GetWshShell
		Call WshShell.Run( "cmd.exe /c cscript.exe " & Dd(str) & " & pause", 3 )
		WScript.Quit
	end if

End Function
Function Crun2( nCol )

	if ScriptType <> 1 then
		Exit Function
	end if

	Dim str

	str = WScript.FullName
	str = Right( str, 11 )
	str = Ucase( str )
	if str <> "CSCRIPT.EXE" then
		str = WScript.ScriptFullName
		GetWshShell
		Call WshShell.Run( "cmd.exe /c mode con: cols=" _
			& nCol & " & cscript.exe " & Dd(str) & " & pause", 3 )
		WScript.Quit
	end if

End Function

REM **********************************************************
REM ソース内のテキストリソースを取得
REM **********************************************************
Function GetInline( strName )

	GetInline = RegTrim( getResource( strName ) ) & vbCrLf

End Function

REM **********************************************************
REM 実行中のスクリプトのタイプ
REM 1:WSH, 2:HTA, 3:ASP, 0:不明
REM **********************************************************
Function ScriptType( )

	Dim nType

	nType = 0

	if IsObject( Wscript ) then
		nType = 1
	else
		if IsObject( window ) then
			nType = 2
		else
			if IsObject( Server ) then
				nType = 3
			end if
		end if
	end if

	ScriptType = nType

End Function

REM **********************************************************
REM 文字列を指定して、変数にオブシェクトを作成させる
REM **********************************************************
Function GetObj( strTarget, strObjectName )

	Dim ExecuteString

	ExecuteString = "Dim " & strTarget & " : "
	ExecuteString = ExecuteString & "Set " & strTarget & " = "

	Select Case ScriptType
		Case 1
			ExecuteString = ExecuteString & _
			"WScript.CreateObject("
		Case 2
			ExecuteString = ExecuteString & _
			"CreateObject("
		Case 3
			ExecuteString = ExecuteString & _
			"Server.CreateObject("
		Case Else
			ExecuteString = ExecuteString & _
			"CreateObject("
	End Select

	ExecuteString = ExecuteString & Dd( strObjectName ) & ")"

	ExecuteGlobal ExecuteString

End Function

REM **********************************************************
REM FileSystemObject の取得
REM ExecuteGlobal で定義されたグローバルな変数は
REM ローカルスコープで即参照できない
REM **********************************************************
Function GetFso( )

	if not IsObject( Fso ) then
		Call GetObj( "Fso", "Scripting.FileSystemObject" )
	end if

End Function

REM **********************************************************
REM テキストファイル一括取得
REM **********************************************************
Function GetTextFile( strPath )

	GetFso

	Dim objHandle

	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

REM **********************************************************
REM テキストファイル一括書き込み
REM **********************************************************
Function PutTextFile( strPath, strValue )

	GetFso

	Dim objHandle

	on error resume next
	Set objHandle = Fso.CreateTextFile( strPath, True )
	if Err.Number <> 0 then
		ErrorMessage = Err.Description
	else
		objHandle.Write( strValue )
		objHandle.Close
	end if
	on error goto 0

End Function

REM **********************************************************
REM WScript.Shell の取得
REM **********************************************************
Function GetWshShell( )

	if not IsObject( WshShell ) then
		Call GetObj( "WshShell", "WScript.Shell" )
	end if

End Function

REM **********************************************************
REM 非同期実行
REM **********************************************************
Function RunAsync( strCommand )

	GetWshShell
	Call WshShell.Run( strCommand )

End Function

REM **********************************************************
REM 同期実行( 必要ならコマンドプロンプトを開く )
REM **********************************************************
Function RunSync( strCommand )

	GetWshShell
	Call WshShell.Run( strCommand, , True )

End Function

REM **********************************************************
REM バッチファイル 実行
REM **********************************************************
Function RunBat( strName )

	Dim strPath,strCommand

	strPath = Tempdir & "\" & strName & ".bat"
	Call PutTextFile( strPath, GetInline(strName) )
	strCommand = "cmd.exe /c " & Dd( strPath )
	RunSync( strCommand )

End Function

REM **********************************************************
REM バッチファイル パラメータ(置き換え)実行
REM **********************************************************
Function RunBatParam( strName, bPause, strParamList )

	Dim strPath,strCommand,aParam,str,I

	aParam = Split(strParamList,",")

	strPath = Tempdir & "\" & strName & ".bat"
	str = GetInline(strName)
	For I = 0 to Ubound( aParam ) step 2
		str = Replace( str, aParam(I), aParam(I+1) )
	Next
	Call PutTextFile( strPath, str )
	strCommand = "cmd.exe /c " & Dd( strPath )
	RunSync( strCommand )

End Function

REM **********************************************************
REM PHP 実行
REM **********************************************************
Function RunPhp( strName, bPause )

	Dim strPath,strCommand

	strPath = Tempdir & "\" & strName & ".php"
	Call PutTextFile( strPath, GetInline(strName) )
	if bPause then
		strCommand = "cmd.exe /c php.exe " & Dd( strPath ) & " & pause"
	else
		strCommand = "php.exe " & Dd( strPath )
	end if
	RunSync( strCommand )

End Function

REM **********************************************************
REM PHP パラメータ(置き換え)実行
REM **********************************************************
Function RunPhpParam( strName, bPause, strParamList )

	Dim strPath,strCommand,aParam,str,I

	aParam = Split(strParamList,",")

	strPath = Tempdir & "\" & strName & ".php"
	str = GetInline(strName)
	For I = 0 to Ubound( aParam ) step 2
		str = Replace( str, aParam(I), aParam(I+1) )
	Next
	Call PutTextFile( strPath, str )
	if bPause then
		strCommand = "cmd.exe /c php.exe " & Dd( strPath ) & " & pause"
	else
		strCommand = "php.exe " & Dd( strPath )
	end if
	RunSync( strCommand )

End Function

REM **********************************************************
REM 同期実行( コマンドプロンプトは開かない )
REM **********************************************************
Function RunSync2( strCommand )

	GetWshShell
	Call WshShell.Run( strCommand, 0, True )

End Function

REM **********************************************************
REM WScript.Network の取得
REM **********************************************************
Function GetWshNetwork( )

	if not IsObject( WshNetwork ) then
		Call GetObj( "WshNetwork", "WScript.Network" )
	end if

End Function

REM **********************************************************
REM ディクショナリオブジェクトの取得
REM **********************************************************
Function GetDic( )

	if not IsObject( Dic ) then
		Call GetObj( "Dic", "Scripting.Dictionary" )
	end if

End Function

REM **********************************************************
REM Shell オブジェクトの取得
REM **********************************************************
Function GetShell( )

	if not IsObject( Shell ) then
		Call GetObj( "Shell", "Shell.Application" )
	end if

End Function

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

	if ScriptType <> 3 then
	else
		Exit Function
	end if

	GetShell

	Dim obj

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

	SelectDir = obj.Self.Path

End Function

REM **********************************************************
REM ADO Connection オブジェクトの取得
REM **********************************************************
Function GetCn( )

	if not IsObject( Cn ) then
		Call GetObj( "Cn", "ADODB.Connection" )
	end if

End Function

REM **********************************************************
REM ADO Recordset オブジェクトの取得
REM **********************************************************
Function GetRs( )

	if not IsObject( Rs ) then
		Call GetObj( "Rs", "ADODB.Recordset" )
	end if

End Function

REM **********************************************************
REM ADO Stream オブジェクトの取得
REM **********************************************************
Function GetStream( )

	if not IsObject( Stream ) then
		Call GetObj( "Stream", "ADODB.Stream" )
	end if

End Function

REM **********************************************************
REM ADOX.Catalog の取得
REM **********************************************************
Function GetAdox( )

	if not IsObject( Adox ) then
		Call GetObj( "Adox", "ADOX.Catalog" )
	end if

End Function

REM **********************************************************
REM カレントディレクトリを返す
REM **********************************************************
Function CurDir( )

	GetWshShell

	CurDir = WshShell.CurrentDirectory

End Function

REM **********************************************************
REM スクリプトが存在する場所を返す
REM **********************************************************
Function ScriptDir( )

	Dim obj,strPath,aData,I

	ScriptDir = ""

	Select Case ScriptType
		Case 1
			GetFso

			strPath = WScript.ScriptFullName
			Set obj = Fso.GetFile( strPath )
			Set obj = obj.ParentFolder
			ScriptDir = obj.Path
		Case 2
			strPath = window.location
			aData = Split( strPath, "/" )
			strPath = ""
			For I = 3 to Ubound( aData ) - 1
				if I <> 3 then
					strPath = strPath & "\"
				end if
				strPath = strPath & aData( I )
			Next
			ScriptDir = strPath
		Case 3
			ScriptDir = Server.MapPath( "./" )
		Case Else
	End Select

End Function

REM **********************************************************
REM Shell フォルダを返す
REM **********************************************************
Function GetShellDir( nID )

	Dim objFolder,objFolderItem

	GetShell

	Set objFolder = Shell.Namespace(nID)
	Set objFolderItem = objFolder.Self
	GetShellDir = objFolderItem.Path

End Function

REM **********************************************************
REM プログラムフォルダを返す ( Program Files )
REM **********************************************************
Function ProgDir( )
	ProgDir = GetShellDir( &H26 )
End Function

REM **********************************************************
REM ユーザーフォルダを返す
REM **********************************************************
Function UserDir( )
	UserDir = GetShellDir( &H28 )
End Function

REM **********************************************************
REM テンポラリフォルダを返す
REM **********************************************************
Function TempDir( )
	TempDir = GetShellDir( &H28 ) & "\Local Settings\Temp"
End Function

REM **********************************************************
REM Windows ディレクトリの取得
REM **********************************************************
Function WinDir( )

	WinDir = GetShellDir( &H24 )

if False then
	Dim strComputer,objWMIService,colOSes,objOS

	strComputer = "."
	Set objWMIService = GetObject("winmgmts:" _
	 & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
 
	Set colOSes = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
	For Each objOS in colOSes
		WinDir = objOS.WindowsDirectory
	Next
end if

End Function

REM **********************************************************
REM Windows System ディレクトリの取得
REM **********************************************************
Function SysDir( )

	SysDir = GetShellDir( &H25 )

if False then
	Dim strComputer,objWMIService,colOSes,objOS

	strComputer = "."
	Set objWMIService = GetObject("winmgmts:" _
	 & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
 
	Set colOSes = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
	For Each objOS in colOSes
		SysDir = objOS.SystemDirectory
	Next
end if

End Function

REM **********************************************************
REM SpecialFolder の取得
REM **********************************************************
Function GetSpecialFolder( strName )
	GetWshShell
	GetSpecialFolder = WshShell.SpecialFolders(strName)
End Function

REM **********************************************************
REM SendTo ディレクトリの取得
REM **********************************************************
Function SendtoDir( )
	SendtoDir = GetSpecialFolder("SendTo")
End Function

REM **********************************************************
REM お気に入りディレクトリの取得
REM **********************************************************
Function FavDir( )
	FavDir = GetSpecialFolder("Favorites")
End Function

REM **********************************************************
REM デスクトップディレクトリの取得
REM **********************************************************
Function DesktopDir( )
	DesktopDir = GetSpecialFolder("Desktop")
End Function

REM **********************************************************
REM StartMenu ディレクトリの取得
REM **********************************************************
Function MenuDir( )
	MenuDir = GetSpecialFolder("StartMenu")
End Function

REM **********************************************************
REM MyDocuments ディレクトリの取得
REM **********************************************************
Function MyDocDir( )
	MyDocDir = GetSpecialFolder("MyDocuments")
End Function
 
REM **********************************************************
REM スタートアップディレクトリの取得
REM **********************************************************
Function StartupDir( )
	StartupDir = GetSpecialFolder("Startup")
End Function
 
REM **********************************************************
REM ユーザ名の取得
REM **********************************************************
Function GetUser( )
	GetWshNetwork
	GetUser = WshNetwork.UserName
End Function

REM **********************************************************
REM コンピュータ名の取得
REM **********************************************************
Function GetCpname( )
	GetWshNetwork
	GetCpname = WshNetwork.ComputerName
End Function

REM **********************************************************
REM メッセージボックス
REM **********************************************************
Function OkCancel( str )

	Dim ret

	if ScriptType <> 3 then
	else
		Exit Function
	end if

	if vbOK = MsgBox( str, vbOKCancel, "laylaClass" ) then
		OkCancel = True
	else
		OkCancel = False
	end if

End Function

Function YesNo( str )

	Dim ret

	if ScriptType <> 3 then
	else
		Exit Function
	end if

	if vbYes = MsgBox( str, vbYesNo, "laylaClass" ) then
		YesNo = True
	else
		YesNo = False
	end if

End Function

Function MsgOk( str )

	if ScriptType <> 3 then
	else
		Exit Function
	end if

	Call MsgBox( str, 0, "laylaClass" )

End Function

Function MsgErr( str )

	if ScriptType <> 3 then
	else
		Exit Function
	end if

	Call MsgBox( str, vbOKOnly + vbExclamation, "laylaClass" )

End Function

REM ************************************************
REM 指定範囲の整数の乱数を取得
REM ************************************************
Function Random( nMin, nMax )

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

End function

Function SameRandom( nMin, nMax )

	SameRandom = nMin + Int(Rnd * (nMax - nMin + 1))

End function

REM **********************************************************
REM 文字列グループの取得
REM **********************************************************
Function GroupString( nGroup )

End Function

REM ************************************************
REM 半角を全角に変換
REM ************************************************
Function Han2Zen( strValue )

	Dim strRet,strTarget1,strTarget2,i,nLen

	strRet = strValue

	strTarget1 = GroupString( 1 )
	strTarget2 = GroupString( 5 )

	nLen = Len(strTarget1)

	For i = 1 to nLen
		strRet = Replace(strRet,Mid(strTarget1,i,1), Mid(strTarget2,i,1) )
	Next

	strTarget1 = GroupString( 2 )
	strTarget2 = GroupString( 6 )

	nLen = Len(strTarget1)

	For i = 1 to nLen
		strRet = Replace(strRet,Mid(strTarget1,i,1), Mid(strTarget2,i,1) )
	Next

	strTarget1 = GroupString( 3 )
	strTarget2 = GroupString( 7 )

	nLen = Len(strTarget1)

	For i = 1 to nLen
		strRet = Replace(strRet,Mid(strTarget1,i,1), Mid(strTarget2,i,1) )
	Next

	strTarget1 = GroupString( 4 )
	strTarget2 = GroupString( 8 )

	nLen = Len(strTarget1)

	For i = 1 to nLen
		strRet = Replace(strRet,Mid(strTarget1,i,1), Mid(strTarget2,i,1) )
	Next

	Han2Zen = strRet

End function

REM ************************************************
REM 全角を半角に変換
REM ************************************************
Function Zen2Han( strValue )

	Dim strRet,strTarget1,strTarget2,i,nLen

	strRet = strValue

	strTarget1 = GroupString( 5 )
	strTarget2 = GroupString( 1 )

	nLen = Len(strTarget1)

	For i = 1 to nLen
		strRet = Replace(strRet,Mid(strTarget1,i,1), Mid(strTarget2,i,1) )
	Next

	strTarget1 = GroupString( 6 )
	strTarget2 = GroupString( 2 )

	nLen = Len(strTarget1)

	For i = 1 to nLen
		strRet = Replace(strRet,Mid(strTarget1,i,1), Mid(strTarget2,i,1) )
	Next

	strTarget1 = GroupString( 7 )
	strTarget2 = GroupString( 3 )

	nLen = Len(strTarget1)

	For i = 1 to nLen
		strRet = Replace(strRet,Mid(strTarget1,i,1), Mid(strTarget2,i,1) )
	Next

	strTarget1 = GroupString( 8 )
	strTarget2 = GroupString( 4 )

	nLen = Len(strTarget1)

	For i = 1 to nLen
		strRet = Replace(strRet,Mid(strTarget1,i,1), Mid(strTarget2,i,1) )
	Next

	Zen2Han = strRet

End function
  



  wmiService.vbs

  
REM **********************************************************
REM 開始モードの変更
REM 0:Automatic, 1:Manual, 2:Disabled
REM **********************************************************
Function WMIChangeStartMode( str, nMode )

	Dim strType

	Select Case nMode
		Case 0
			strType = "Automatic"
		Case 1
			strType = "Manual"
		Case 2
			strType = "Disabled"
		Case Else
			Exit Function
	End Select

	strComputer = "." 
	Set objWMIService = GetObject("winmgmts:" _ 
	& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
	Set colListOfServices = objWMIService.ExecQuery _ 
		("Select * from Win32_Service Where Name = " & Ss(str) ) 

	For Each objService in colListOfServices 
		on error resume next
		WMIChangeStartMode = objService.Change( , , , , strType )
		on error goto 0
	Next

End Function

REM **********************************************************
REM 表示名からサービス名の取得
REM **********************************************************
Function WMIGetServiceName( str )

	strComputer = "." 
	Set objWMIService = GetObject("winmgmts:" _ 
	& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
	Set colListOfServices = objWMIService.ExecQuery _ 
		("Select * from Win32_Service Where DisplayName = " & Ss(str) ) 
	For Each objService in colListOfServices 
		on error resume next
		WMIGetServiceName = objService.Name
		on error goto 0
	Next

End Function

REM **********************************************************
REM 状態
REM **********************************************************
Function WMIStateService( str )

	strComputer = "." 
	Set objWMIService = GetObject("winmgmts:" _ 
	& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
	Set colListOfServices = objWMIService.ExecQuery _ 
		("Select * from Win32_Service Where Name = " & Ss(str) ) 
	For Each objService in colListOfServices 
		on error resume next
		WMIStateService = objService.State
		on error goto 0
	Next

End Function

REM **********************************************************
REM 開始
REM **********************************************************
Function WMIStartService( str )

	strComputer = "." 
	Set objWMIService = GetObject("winmgmts:" _ 
	& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
	Set colListOfServices = objWMIService.ExecQuery _ 
		("Select * from Win32_Service Where Name = " & Ss(str) ) 
	For Each objService in colListOfServices 
		on error resume next
		objService.StartService() 
		on error goto 0
	Next

End Function

REM **********************************************************
REM 停止
REM **********************************************************
Function WMIStopService( str )

	strComputer = "." 
	Set objWMIService = GetObject("winmgmts:" _ 
	& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
	Set colListOfServices = objWMIService.ExecQuery _ 
		("Select * from Win32_Service Where Name = " & Ss(str) ) 
	For Each objService in colListOfServices 
		on error resume next
		objService.StopService() 
		on error goto 0
	Next

End Function

REM **********************************************************
REM 削除
REM **********************************************************
Function WMIDeleteService( str )

	strComputer = "." 
	Set objWMIService = GetObject("winmgmts:" _ 
	& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
	Set colListOfServices = objWMIService.ExecQuery _ 
		("Select * from Win32_Service Where Name = " & Ss(str) ) 
	For Each objService in colListOfServices 
		on error resume next
		objService.StopService() 
		objService.Delete() 
		on error goto 0
	Next

End Function
  



  wmiReg.vbs

  
Dim WMIRet
REM **********************************************************
REM WMI レジストリ
REM **********************************************************
Function LoadWMIReg( )

	ErrorMessage = ""

	if not IsObject( objRegistry ) then
		Set objRegistry = GetObject("Winmgmts:root\default:StdRegProv")
	end if 

End Function

REM **********************************************************
REM KEY の処理
REM **********************************************************
Function WMIRegCreateKey( nType, strPath )
REM 途中のキーもなければ全て作成される
	WMIRegCreateKey = False

	LoadWMIReg

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

	WMIRegCreateKey = True
End Function
Function WMIRegDeleteKey( nType, strPath )
REM 途中のキーは削除できない
	WMIRegDeleteKey = False

	LoadWMIReg

	on error resume next
	WMIRet = objRegistry.DeleteKey( nType, strPath )
	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

	WMIRegDeleteKey = True
End Function

REM **********************************************************
REM 値削除
REM **********************************************************
Function WMIRegDeleteValue( nType, strPath, strName )
	WMIRegDeleteValue = False

	LoadWMIReg

	on error resume next
	WMIRet = objRegistry.DeleteValue( nType, strPath, strName )
	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

	WMIRegDeleteValue = True
End Function

REM **********************************************************
REM STRING の処理
REM **********************************************************
Function WMIRegSetStringValue( nType, strPath, strName, strValue )
REM strValue が Empty で値を削除
	WMIRegSetStringValue = False

	LoadWMIReg

	if IsEmpty( strValue ) then
		Call WMIRegDeleteValue( nType, strPath, strName )
		WMIRegSetStringValue = True
		Exit Function
	end if
	if IsNull( strValue ) then
		strValue = ""
	end if

	on error resume next
	WMIRet = objRegistry.SetStringValue( nType, strPath, strName, strValue )
	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

	WMIRegSetStringValue = True
End Function

Function WMIRegGetStringValue( nType, strPath, strName, strValue )
	WMIRegGetStringValue = False

	LoadWMIReg

	on error resume next
	WMIRet = objRegistry.GetStringValue( nType, strPath, strName, strValue )
	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

	WMIRegGetStringValue = True
End Function

REM **********************************************************
REM DWORD の処理
REM **********************************************************
Function WMIRegGetDwordValue( nType, strPath, strName )

	LoadWMIReg

	objRegistry.GetDwordValue nType,strPath,strName,WMIRegGetDwordValue

	if IsNull( WMIRegGetDwordValue ) then
		WMIRegGetDwordValue = Empty
	end if

End Function
Function WMIRegSetDwordValue( nType, strPath, strName, dwValue )
	WMIRegSetDwordValue = False

	LoadWMIReg

	on error resume next
	objRegistry.SetDwordValue nType,strPath,strName,dwValue
	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

	WMIRegSetDwordValue = True
End Function

REM **********************************************************
REM 列挙
REM **********************************************************
Function WMIRegEnumKey( nType, strPath, aKeys )
	WMIRegEnumKey = False

	LoadWMIReg

	on error resume next
	WMIRet = objRegistry.EnumKey( nType, strPath, aKeys )
	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

	WMIRegEnumKey = True
End Function
  



  dbFunction.vbs

  
REM **********************************************************
REM baseFunction.vbs に依存します
REM **********************************************************

REM **********************************************************
REM SQLServer DB接続
REM **********************************************************
Function SQSConnect( _
	strServer, _
	strDB, _
	strUser, _
	strPass _
)
	Dim ConnectionString

	GetCn

	Call DBClose( Cn )

	ConnectionString = _
		"Provider=SQLOLEDB;" & _
		"Data Source=" & strServer & ";" & _
		"Initial Catalog=" & strDB & ";" & _
		"User ID=" & strUser & ";" & _
		"Password=" & strPass & ";"

	Cn.Open ConnectionString

End Function

REM **********************************************************
REM MDB DB接続
REM **********************************************************
Function MDBConnect( _
	strDB _
)
	Dim ConnectionString

	GetCn

	Call DBClose( Cn )

	ConnectionString = _
		"Provider=Microsoft.Jet.OLEDB.4.0;" & _
		"Data Source=" & strDB & ";"

	Cn.Open ConnectionString

End Function

REM ******************************************************
REM DB終了処理(接続を閉じる)
REM ******************************************************
Function DBClose( _
	CnRs _
)

	On Error Resume Next
	If CnRs.State >= 1 Then
		CnRs.Close
	End If
	On Error Goto 0

	DBClose = True

End Function

REM ******************************************************
REM DB読込み
REM 【戻り値】: True(データ有り),False(データ無し)
REM ******************************************************
Function DBGet( _
	SqlQuery, _
	bUpadateFlg _
)

	GetCn
	GetRs
	Call DBClose( Rs )

REM 更新処理に使用する場合は、レコード単位の共有的ロック
	If bUpadateFlg Then
		Rs.LockType = 3
	End If

REM レコードセット作成
	On Error Resume Next
	Rs.Open SqlQuery, Cn
	If Err.Number <> 0 then
		ErrorMessage = Err.Description
		DBGet = False
		Exit Function
	End If
	If Rs.EOF Then
		DBGet = False
	Else
		DBGet = True
	End If
	On Error Goto 0

End Function

REM ******************************************************
REM EOF
REM 【戻り値】: True(EOF),False(データ有り)
REM ******************************************************
Function DBEof( Record )

	Dim bRet

	On Error Resume Next
	bRet = Record.EOF
	If Err.Number <> 0 then
		ErrorMessage "DBEof でエラー : " & Err.Description
		DBEof = True
		Exit Function
	End If
	On Error Goto 0

	DBEof = bRet

End Function
  










  infoboard   管理者用   
このエントリーをはてなブックマークに追加





フリーフォントWEBサービス
SQLの窓WEBサービス

SQLの窓フリーソフト

素材

一般WEBツールリンク

SQLの窓

フリーソフト

JSライブラリ