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