Option Explicit
' vbslib ver3.01 Dec.15, 2009
' Copyright (c) 2008-2009, T's-Neko at Sage Plaisir 21 (Japan)
' All rights reserved. Based on 3-clause BSD license.
Dim g_SrcPath
Dim g_vbslib_main_Path
g_vbslib_main_Path = g_SrcPath
'********************************************************************************
' <<< Global variables >>>
'********************************************************************************
Dim g_WritablePathes
Dim g_Err2, g_EchoObj
Dim g_AppKey
Dim g_Test
Dim g_CUI
Dim g_ChildHead
Dim g_CurrentWritables
Dim g_FileSystemRetryMSec
Dim g_Player '// as Vbslib_Player
Function InitializeModule
ReDim g_WritablePathes(-1)
Set g_CurrentWritables = new CurrentWritables : ErrCheck
Set g_EchoObj = new EchoObj : ErrCheck
Set g_Err2 = new Err2 : ErrCheck
Set g_CUI = new CUI : ErrCheck
g_FileSystemRetryMSec = 10*1000
End Function
Dim g_InitializeModule
Set g_InitializeModule = GetRef( "InitializeModule" )
Function FinalizeModule( ThisPath, Reason )
If Reason = 0 Then
g_Err2.OnSuccessFinish
Else
g_Err2.OnErrorFinish
End If
echo_flush
End Function
Dim g_FinalizeModule: Set g_FinalizeModule = GetRef( "FinalizeModule" )
Dim g_FinalizeLevel: g_FinalizeLevel = 100 ' If smaller, called early
Const F_File = 1
Const F_Folder = 2
Const F_SubFolder = 4
Const g_PauseMsg = "続行するには Enter キーを押してください . . . "
Const g_PauseMsgStone = 24
'********************************************************************************
' <<< Error Code >>>
'********************************************************************************
Dim E_Others : E_Others = 1
Dim E_AssertFail : E_AssertFail = &h80041001
Dim E_TestFail : E_TestFail = &h80041003
Dim E_BuildFail : E_BuildFail = &h80041004
Dim E_OutOfWritable : E_OutOfWritable = &h80041005
Dim E_NotFoundSymbol : E_NotFoundSymbol = &h80041006
Dim E_ProgRetNotZero : E_ProgRetNotZero = &h80041007
Dim E_Unexpected : E_Unexpected = &h80041008
Dim E_WIN32_FILE_NOT_FOUND: E_WIN32_FILE_NOT_FOUND = &h80070002
Dim E_WIN32_DIRECTORY : E_WIN32_DIRECTORY = &h8007010B
Dim E_ProgTerminated : E_ProgTerminated = &hC0000005
Dim E_FileNotExist : E_FileNotExist = 53
Dim E_EndOfFile : E_EndOfFile = 62
Dim E_WriteAccessDenied : E_WriteAccessDenied = 70
Dim E_PathNotFound : E_PathNotFound = 76
Dim E_AlreadyExist : E_AlreadyExist = 58
'********************************************************************************
' <<< File Object >>>
'********************************************************************************
Const ReadOnly = 1
'*-------------------------------------------------------------------------*
'* ### <<<< Debugging >>>>
'*-------------------------------------------------------------------------*
'********************************************************************************
' <<< [g_count_up] >>>
'********************************************************************************
Redim g_count(-1)
Function g_count_up( i )
If i > UBound( g_count ) Then Redim Preserve g_count(i)
g_count_up = g_count(i) + 1
g_count(i) = g_count_up
End Function
'********************************************************************************
' <<< [SetTestMode] >>>
'********************************************************************************
Dim F_NotRandom : F_NotRandom = 1
Dim g_TestModeFlags
Sub SetTestMode( Flags )
g_TestModeFlags = Flags
End Sub
'*-------------------------------------------------------------------------*
'* ### <<<< User Interface >>>>
'*-------------------------------------------------------------------------*
'********************************************************************************
' <<< [EchoObj] Class >>>
'********************************************************************************
Class EchoObj
Public m_bEchoOff
Public m_bDisableEchoOff
Public m_Buf
Public m_BufN
End Class
'// g_EchoObj
'********************************************************************************
' <<< [echo] >>>
'********************************************************************************
Function echo( ByVal msg )
If g_EchoObj.m_bEchoOff Then Exit Function
If not IsEmpty( msg ) Then
msg = GetEchoString( msg )
If g_CommandPrompt = 0 Then
If IsEmpty( g_EchoObj.m_Buf ) Then
g_EchoObj.m_Buf = msg
Else
g_EchoObj.m_Buf = g_EchoObj.m_Buf & vbCRLF & msg
End If
g_EchoObj.m_BufN = g_EchoObj.m_BufN + 1
If g_EchoObj.m_BufN >= 20 Then echo_flush
Else
WScript.Echo msg
End If
If not IsEmpty( g_Test ) Then g_Test.WriteLogLine msg
End If
echo = msg
End Function
'********************************************************************************
' <<< [GetEchoString] >>>
'********************************************************************************
Function GetEchoString( ByVal msg )
If IsObject( msg ) Then msg = msg.Value
If IsNull( msg ) Then
msg = "(null)"
ElseIf VarType( msg ) = vbBoolean Then
If msg Then msg = "True" _
Else msg = "False"
ElseIf IsArray( msg ) Then
Dim a : Set a = new ArrayClass : ErrCheck
a.Copy msg
msg = GetEchoString( a )
End If
GetEchoString = msg
End Function
'********************************************************************************
' <<< [echo_flush] >>>
'********************************************************************************
Sub echo_flush()
If g_CommandPrompt = 0 and g_EchoObj.m_BufN > 0 Then
If MsgBox( g_EchoObj.m_Buf, vbOKCancel, WScript.ScriptName ) = vbCancel Then
WScript.Quit 1
End If
g_EchoObj.m_Buf = Empty
g_EchoObj.m_BufN = 0
End If
End Sub
'********************************************************************************
' <<< [EchoOff] >>>
'********************************************************************************
Class EchoOff
Public m_Prev
Private Sub Class_Initialize
m_Prev = g_EchoObj.m_bEchoOff
g_EchoObj.m_bEchoOff = not g_EchoObj.m_bDisableEchoOff
End Sub
Private Sub Class_Terminate
g_EchoObj.m_bEchoOff = m_Prev
End Sub
End Class
'********************************************************************************
' <<< [DisableEchoOff] >>>
'********************************************************************************
Sub DisableEchoOff
g_EchoObj.m_bDisableEchoOff = True
End Sub
'********************************************************************************
' <<< [echo_r] >>>
' return: output message
'********************************************************************************
Function echo_r( ByVal msg, redirect_path )
Dim f
Const ForAppending = 8
If IsObject( msg ) Then msg = msg.Value
If g_debug Then WScript.Echo msg
If IsEmpty( redirect_path ) Then
ElseIf redirect_path = "" Then
If Not g_debug Then WScript.Echo msg
Else
Set f = g_fs.OpenTextFile( redirect_path, ForAppending, True, False )
f.WriteLine msg
End If
echo_r = msg
End Function
'********************************************************************************
' <<< old I/F [echo_c] >>>
'********************************************************************************
Function echo_c( ByVal msg )
If g_cut_old Then Stop
echo_c = echo( msg )
End Function
'********************************************************************************
' <<< [type_] >>>
'********************************************************************************
Sub type_( path )
Dim f
Set f = g_fs.OpenTextFile( path )
Do Until f.AtEndOfStream
echo f.ReadLine
Loop
End Sub
'********************************************************************************
' <<< [pause] >>>
'********************************************************************************
Sub pause()
If g_CommandPrompt = 0 Then
echo "続行するには Enter キーを押してください . . ."
echo_flush
Else
g_CUI.input_sub g_PauseMsg, False
End If
End Sub
'********************************************************************************
' <<< [pause2] >>>
'********************************************************************************
Sub pause2()
If WScript.Arguments.Named("wscript")=1 Then input g_PauseMsg
End Sub
'********************************************************************************
' <<< [input] >>>
'********************************************************************************
Function input( ByVal msg )
input = g_CUI.input( msg )
End Function
'********************************************************************************
' <<< [set_input] >>>
'********************************************************************************
Sub set_input( Keys )
g_CUI.m_Auto_Keys = Keys
End Sub
'********************************************************************************
' <<< [InputPath] >>>
'********************************************************************************
Const F_ChkFileExists = 1
Const F_ChkFolderExists = 2
Const F_AllowEnterOnly = 4
Function InputPath( Prompt, Flags )
Dim path
Do
path = input( Prompt )
path = Trim( path )
If path = "" and ( Flags and F_AllowEnterOnly ) Then Exit Do
If Left( path, 1 ) = """" and Right( path, 1 ) = """" Then _
path = Mid( path, 2, Len( path ) - 2 )
If Flags = 0 Then Exit Do
If Flags and F_ChkFileExists Then
If g_fs.FileExists( path ) Then Exit Do
End If
If Flags and F_ChkFolderExists Then
If g_fs.FolderExists( path ) Then Exit Do
End If
echo "not found"
Loop
InputPath = path
End Function
'********************************************************************************
' <<< [SendKeys] Send keyboard code stroke to OS >>>
'********************************************************************************
Sub SendKeys( ByVal window_title, ByVal keycords, ByVal late_time )
WScript.Sleep late_time
If window_title <> "" Then
If not g_sh.AppActivate( window_title ) Then _
Raise E_NotFoundSymbol, ""
End If
WScript.Sleep 100
g_sh.SendKeys keycords
End Sub
'*-------------------------------------------------------------------------*
'* ### <<<< [CUI] Class >>>>
'*-------------------------------------------------------------------------*
Class CUI
Public m_Auto_InputFunc ' as string of auto input function name
Public m_Auto_Src ' as string of path
Public m_Auto_Keys ' as string of auto input keys
Public m_Auto_KeyEnter ' as string of the character of replacing to enter key
Public m_Auto_DebugCount ' as integer
'********************************************************************************
' <<< [CUI::Class_Initialize] >>>
'********************************************************************************
Private Sub Class_Initialize
Me.m_Auto_Keys = ""
Me.m_Auto_KeyEnter = "."
Me.m_Auto_DebugCount = Empty
End Sub
'********************************************************************************
' <<< [CUI::input] >>>
'********************************************************************************
Public Function input( ByVal msg )
input = input_sub( msg, not IsEmpty( WScript.Arguments.Named.Item("GUI_input") ) )
End Function
Public Function input_sub( ByVal msg, bGUI_input )
Dim e
Dim InputFunc
If not IsEmpty( g_EchoObj.m_Buf ) Then msg = g_EchoObj.m_Buf + vbCRLF + msg
g_EchoObj.m_Buf = Empty
g_EchoObj.m_BufN = 0
If msg = g_PauseMsg and Not IsEmpty( m_Auto_Keys ) And m_Auto_Keys <> "" Then
'// Owner process does not wait in EchoStream
Wscript.StdOut.Write Left( g_PauseMsg, g_PauseMsgStone )+"*"+Chr(8)+_
Mid( g_PauseMsg, g_PauseMsgStone+1 )
Else
Wscript.StdOut.Write msg
End If
On Error Resume Next
If Not IsEmpty( m_Auto_Keys ) And m_Auto_Keys <> "" Then
If Not IsEmpty( m_Auto_KeyEnter ) Then
e = InStr( m_Auto_Keys, m_Auto_KeyEnter )
If e = 0 Then
input_sub = m_Auto_Keys
m_Auto_Keys = Empty
Else
input_sub = Left( m_Auto_Keys, e - 1 )
m_Auto_Keys = Mid( m_Auto_Keys, e + 1 )
End If
Else
input_sub = m_Auto_Keys
m_Auto_Keys = Empty
End If
If IsEmpty( m_Auto_DebugCount ) Then
Wscript.StdOut.WriteLine input_sub
ElseIf m_Auto_DebugCount > 1 Then
Wscript.StdOut.WriteLine input_sub
m_Auto_DebugCount = m_Auto_DebugCount - 1
Else
Wscript.StdOut.Write input_sub
If bGUI_input Then
input_sub = InputBox( msg, WScript.ScriptName, "" )
Wscript.StdOut.WriteLine input_sub
Else
input_sub = StdIn_ReadLine_ForJP()
End If
Wscript.StdOut.WriteLine ""
End If
ElseIf IsEmpty( m_Auto_InputFunc ) Then
If bGUI_input Then
input_sub = InputBox( msg, WScript.ScriptName, "" )
Wscript.StdOut.WriteLine input_sub
Else
input_sub = StdIn_ReadLine_ForJP()
End If
Else
If IsEmpty( m_Auto_Src ) Then
Set InputFunc = GetRef( m_Auto_InputFunc )
If Err.Number = 5 Then Wscript.StdOut.WriteLine vbCR+vbLF+"Not found function of """+_
m_Auto_InputFunc +"""": Err.Clear
If Not IsEmpty( InputFunc ) Then input_sub = InputFunc( msg )
Else
input_sub = call_vbs_t( m_Auto_Src, m_Auto_InputFunc, msg )
If Err.Number = 5 Then Wscript.StdOut.WriteLine vbCR+vbLF+"Not found function of """+_
m_Auto_InputFunc +""" in """+m_Auto_Src+"""" : Err.Clear
If IsEmpty( input_sub ) Then Wscript.StdOut.Write msg : input_sub = StdIn_ReadLine_ForJP()
End If
End If
e = Err.Number : Err.Clear : On Error GoTo 0
If e <> 0 Then
If e <> 62 Then Err.Raise e '62= End Of File (StdIn, ^C)
WScript.Quit 1
End If
End Function
'********************************************************************************
' <<< [CUI::SetAutoKeysFromMainArg] >>>
'********************************************************************************
Public Sub SetAutoKeysFromMainArg
If not IsEmpty( Me.m_Auto_Keys ) and Me.m_Auto_Keys = "" Then
Me.m_Auto_Keys = WScript.Arguments.Named.Item("set_input")
Me.m_Auto_DebugCount = WScript.Arguments.Named.Item("set_input_debug")
End If
End Sub
End Class
'********************************************************************************
' <<< [StdIn_ReadLine_ForJP] >>>
'********************************************************************************
Function StdIn_ReadLine_ForJP()
Dim r, i, a
Const msg1 = "コマンドプロンプトや InputBox では、254文字以上は入りません。"
Const msg2 = "コマンドプロンプトでは、英文字以外の場合、128文字以上は入りません。"
Const msg3 = "もう一度入力してください。"
Do
r = WScript.StdIn.ReadLine
If Len( r ) >= 254 Then
WScript.StdOut.WriteLine msg1
WScript.StdOut.Write msg3 + ">"
ElseIf Len( r ) > 128 Then
For i=1 To 128
a = Asc( Mid( r, i, 1 ) )
If a < 0 or a > 127 Then
r = InputBox( msg2+msg3, WScript.ScriptName )
While Len( r ) >= 254
r = InputBox( msg1+msg3, WScript.ScriptName )
WEnd
WScript.StdOut.Write msg3 +">"+ r +vbCRLF
Exit For
End If
Next
Exit Do
Else
Exit Do
End If
Loop
StdIn_ReadLine_ForJP = r
End Function
'*-------------------------------------------------------------------------*
'* ### <<<< File >>>>
'*-------------------------------------------------------------------------*
'********************************************************************************
' <<< [AppKeyClass] >>>
'********************************************************************************
Const F_AskIfWarn = 0
Const F_ErrIfWarn = 1
Const F_IgnoreIfWarn = 2
Const F_BreakIfWarn = 3
Class AppKeyClass
Private m_Key
Private m_bAppKey
Private m_WritableMode ' as Flags
Private m_NewWritables()
Public m_BreakByFName ' as string
Private Sub Class_Initialize()
m_WritableMode = F_AskIfWarn
ReDim m_NewWritables(-1)
End Sub
Public Function SetKey( Key )
If not IsEmpty( m_Key ) Then Err.Raise 1,,"Double Key"
Set m_Key = Key
Key.SetKey_sub Me
Set SetKey = Key
End Function
Public Sub SetKey_sub( Key )
If not IsEmpty( m_Key ) Then Err.Raise 1,,"Double Key"
m_bAppKey = ( Key Is g_AppKey )
Set m_Key = Key
End Sub
Public Function IsSame( Key )
IsSame = ( m_Key Is Key ) and Key.IsSame_sub( Me )
End Function
Public Function IsSame_sub( Key )
IsSame_sub = ( m_Key Is Key )
End Function
Public Sub CheckGlobalAppKey()
If not m_bAppKey Then _
MsgBox "[ERROR] This is not AppKey from main2"
If not IsSame( g_AppKey ) Then _
MsgBox "[ERROR] g_AppKey was overrided by unknown"
End Sub
Private Sub Class_Terminate()
If m_bAppKey Then CheckGlobalAppKey
End Sub
'********************************************************************************
' <<< [AppKeyClass::NewWritable] >>>
'********************************************************************************
Public Function NewWritable( Pathes )
Me.CheckGlobalAppKey
Dim m : Set m = new Writables : ErrCheck
m.SetPathes Me, Pathes
Set NewWritable = m
End Function
'********************************************************************************
' <<< [AppKeyClass::SetWritableMode] >>>
'********************************************************************************
Public Sub SetWritableMode( Flags )
If g_AppKey Is Me Then
If Flags = F_IgnoreIfWarn Then
Err.Raise 1
Else
m_Key.SetWritableMode( Flags )
Exit Sub
End If
End If
Select Case Flags
Case F_AskIfWarn : echo ">SetWritableMode F_AskIfWarn"
Case F_ErrIfWarn : echo ">SetWritableMode F_ErrIfWarn"
Case F_IgnoreIfWarn:echo ">SetWritableMode F_IgnoreIfWarn"
Case F_BreakIfWarn :echo ">SetWritableMode F_BreakIfWarn"
Case Else : Err.Raise 1
End Select
m_WritableMode = Flags
End Sub
Public Function GetWritableMode()
If g_AppKey Is Me Then
GetWritableMode = m_Key.GetWritableMode()
Else
GetWritableMode = m_WritableMode
End If
End Function
'********************************************************************************
' <<< [AppKeyClass::AddNewWritableFolder] >>>
'********************************************************************************
Public Sub AddNewWritableFolder( Path )
AddNewWritableFolder_sub Path, Empty
End Sub
Public Sub AddNewWritableFolder_sub( Path, Opt )
If g_AppKey Is Me Then m_Key.AddNewWritableFolder_sub Path, Opt : Exit Sub
Dim abs_path, passed_path, out, b
'// Stop at debug
If g_debug_or_test Then
If StrComp( g_AppKey.m_BreakByFName, g_fs.GetFileName( Path ), vbTextCompare ) = 0 Then
echo_r "Break by """ + g_AppKey.m_BreakByFName + """", ""
Stop
End If
End If
'// If the folder in writable folder, Do nothing
abs_path = g_CurrentWritables.CheckWritable( Path, Opt )
If IsEmpty( abs_path ) Then Exit Sub
'// If it is not able to add new writable, raise warning.
If not IsEmpty( g_CurrentWritables.CheckAddNewWritable( abs_path, out ) ) Then
b=True: If not( IsEmpty( g_TempFile ) )Then b=( g_TempFile.m_FolderPath <> abs_path )
If b Then '// C-language's ||
CheckWritable abs_path : Exit Sub
End If
out = g_TempFile.m_FolderPath
End If
passed_path = out
'// Add to m_NewWritables
'// (sample) writable="C:\A\*", passed="C:\A", abs="C:\A\B" ... new="C:\A\B\"
'// (sample) writable="C:\A\*", passed="C:\A", abs="C:\A\B\a.txt" ... new="C:\A\B\"
'// (sample) writable="C:\A\*", passed="C:\A", abs="C:\A\B\C\a.txt" ... new="C:\A\B\"
'// (sample) writable="C:\*", passed="C:", abs="C:\A\B\C\a.txt" ... new="C:\A\"
ReDim Preserve m_NewWritables( UBound( m_NewWritables ) + 1 )
Dim i : i = InStr( Len(passed_path)+2, abs_path, "\" )
If i = 0 Then
m_NewWritables( UBound( m_NewWritables ) ) = abs_path + "\"
Else
m_NewWritables( UBound( m_NewWritables ) ) = Left( abs_path, i )
End If
End Sub
'********************************************************************************
' <<< [AppKeyClass::CheckNewWritable] >>>
'********************************************************************************
Public Function CheckNewWritable( AbsPath )
If g_AppKey Is Me Then CheckNewWritable = m_Key.CheckNewWritable( AbsPath ) : Exit Function
Dim writable
For Each writable In m_NewWritables
If StrComp( writable, Left( AbsPath, Len( writable ) ), 1 ) = 0 Then Exit Function
Next
CheckNewWritable = AbsPath
End Function
'********************************************************************************
' <<< [AppKeyClass::Ask] >>>
'********************************************************************************
Public Sub Ask( CheckPath )
If g_AppKey Is Me Then m_Key.Ask( CheckPath ) : Exit Sub
Dim msg2 : msg2 = "" : If exist( CheckPath ) Then msg2 = "Cannot overwrite, "
Dim writable
For Each writable In g_CurrentWritables.CurrentPathes
If Right( writable, 3 ) = "\*\" Then
If Left( writable, Len(writable) - 2 ) = Left( CheckPath, Len( writable ) - 2 ) or _
Left( writable, Len(writable) - 3 ) = CheckPath Then
If g_fs.FileExists( CheckPath ) Then
msg2 = "Cannot overwrite NOT NEW file, "
Else
msg2 = "Cannot overwrite NOT NEW folder, "
End If
End If
End If
Next
If m_WritableMode <> F_ErrIfWarn Then
echo_r GetWarningMessage( msg2, CheckPath ), ""
End If
If m_WritableMode = F_AskIfWarn Then
Dim s
Do
echo_flush
If g_CommandPrompt = 0 Then
s = InputBox( "直前のダイアログウィンドウに表示したパスにファイルを出力します。" & vbCRLF & _
"(Y) はい。ファイル出力を許可します" & vbCRLF & "(A) 以後、すべてはい" & vbCRLF & _
"(N) いいえ。プログラムを終了します" & vbCRLF & "(R) パスをもう一度表示します", _
"[WARNING] " +msg2+ "Out of Writable", "Y" )
Else
s = InputBox( "コマンドプロンプトに表示したパスにファイルを出力します。" & vbCRLF & _
"(Y) はい。ファイル出力を許可します" & vbCRLF & "(A) 以後、すべてはい" & vbCRLF & _
"(N) いいえ。プログラムを終了します" & vbCRLF & "(R) パスをもう一度表示します", _
"[WARNING] " +msg2+ "Out of Writable", "Y" )
End If
If s="Y" or s="y" Then
Exit Do
ElseIf s="A" or s="a" Then
SetWritableMode F_IgnoreIfWarn
Exit Do
ElseIf s="R" or s="r" Then
MsgBox CheckPath, vbOKOnly, "[WARNING] Out of Writable"
Else
Err.Raise E_OutOfWritable,, "Out of Writable """ & CheckPath & """"
' Watch g_CurrentWritables.CurrentPathes and CheckPath
End If
Loop
End If
If m_WritableMode = F_BreakIfWarn Then Stop '// Look at caller function using debugger
If m_WritableMode = F_BreakIfWarn or m_WritableMode = F_ErrIfWarn Then
echo_r GetWarningMessage( msg2, CheckPath ), ""
Err.Raise E_OutOfWritable,, msg2+"Out of Writable """ & CheckPath & """"
' Watch g_CurrentWritables.CurrentPathes and Path (CheckPath)
End If
End Sub
Public Function GetWarningMessage( msg2, CheckPath )
Dim s, writable
s = ""+vbCRLF
For Each writable In g_CurrentWritables.CurrentPathes
s=s+ " "+vbCRLF
Next
GetWarningMessage = s+ ""
End Function
'********************************************************************************
' <<< [AppKeyClass::InPath] >>>
'********************************************************************************
Public Function InPath( ChkPathes, WritablePathes )
If TypeName( ChkPathes ) = "ArrayClass" Then
InPath = InPath( ChkPathes.m_Array, WritablePathes )
Exit Function
End If
If TypeName( WritablePathes ) = "ArrayClass" Then
InPath = InPath( ChkPathes, WritablePathes.m_Array )
Exit Function
End If
Dim c, w, b
'// ChkPathes To abs path
If IsArray( ChkPathes ) Then
ReDim cs( UBound( ChkPathes ) )
For i=0 To UBound( cs )
cs(i) = g_fs.GetAbsolutePathName( ChkPathes(i) ) + "\"
Next
Else
ReDim cs(0)
cs(0) = g_fs.GetAbsolutePathName( ChkPathes ) + "\"
End If
'// WritablePathes To abs path
If IsArray( WritablePathes ) Then
ReDim ws( UBound( WritablePathes ) )
For i=0 To UBound( ws )
ws(i) = g_fs.GetAbsolutePathName( WritablePathes(i) ) + "\"
Next
Else
ReDim ws(0)
ws(0) = g_fs.GetAbsolutePathName( WritablePathes ) + "\"
End If
'// Compare path
For Each c In cs
b = False
For Each w In ws
If Left( c, Len(w) ) = w Then b = True : Exit For
Next
If not b Then InPath = False : Exit Function
Next
InPath = True
End Function
'********************************************************************************
' <<< [AppKeyClass::BreakByPath] >>>
'********************************************************************************
Public Function BreakByPath( Path )
If StrComp( m_BreakByFName, g_fs.GetFileName( Path ), vbTextCompare ) = 0 Then
echo_r "Break by """ + g_AppKey.m_BreakByFName + """", ""
Stop
End If
End Function
'********************************************************************************
' <<< [AppKeyClass::BreakByWildcard] >>>
'********************************************************************************
Public Function BreakByWildcard( Path, Flags )
Dim folder, fnames()
Dim fname
ExpandWildcard Path, Flags, folder, fnames
For Each fname in fnames
If StrComp( m_BreakByFName, g_fs.GetFileName( fname ), vbTextCompare ) = 0 Then
echo_r "Break by """ + g_AppKey.m_BreakByFName + """", ""
Stop
End If
Next
End Function
End Class
'********************************************************************************
' <<< [Writables] Class >>>
'********************************************************************************
Class Writables
Private m_Pathes()
Private m_AppKey
Public Sub SetPathes( AppKey, Pathes )
Dim abs_path
If not IsEmpty( m_AppKey ) Then Err.Raise 1,,"Double key"
If not g_AppKey.IsSame( AppKey ) Then Err.Raise 1,,"Invalied AppKey"
GetObject_g_TempFile
If IsArray( Pathes ) Then
ReDim m_Pathes( UBound( Pathes ) + 1 )
For i=0 To UBound( Pathes )
abs_path = GetAbsPath( Pathes(i), Empty )
g_CurrentWritables.AskFileAccess abs_path
m_Pathes(i) = abs_path + "\"
Next
ElseIf TypeName( Pathes ) = "ArrayClass" Then
ReDim m_Pathes( UBound( Pathes.m_Array ) + 1 )
For i=0 To UBound( Pathes.m_Array )
abs_path = GetAbsPath( Pathes(i), Empty )
g_CurrentWritables.AskFileAccess abs_path
m_Pathes(i) = abs_path + "\"
Next
Else
ReDim m_Pathes( 1 )
abs_path = GetAbsPath( Pathes, Empty )
g_CurrentWritables.AskFileAccess abs_path
m_Pathes(0) = abs_path + "\"
End If
m_Pathes( UBound( m_Pathes ) ) = g_TempFile.m_FolderPath '// Last is Temp
Set m_AppKey = AppKey
End Sub
Public Function Enable()
Dim st : Set st = new WritablesStack : ErrCheck
st.PushPathes m_AppKey, m_Pathes
Set Enable = st
End Function
End Class
'********************************************************************************
' <<< [WritablesStack] Class >>>
'********************************************************************************
Class WritablesStack
Private m_AppKey
Private m_Pathes
Public Sub PushPathes( AppKey, Pathes )
Set m_Pathes = new ArrayClass : ErrCheck
m_Pathes.Copy Pathes
Set m_AppKey = AppKey
g_CurrentWritables.PushPathes AppKey, Pathes
End Sub
Private Sub Class_Terminate()
g_CurrentWritables.PopPathes m_AppKey, m_Pathes
End Sub
End Class
'********************************************************************************
' <<< [CurrentWritables] Class >>>
'********************************************************************************
Class CurrentWritables
Private m_PathesStack ' as ArrayClass of ArrayClass
Private m_ProgramFiles
Private m_windir
Private m_APPDATA
Private m_LOCALAPPDATA
Public Property Get CurrentPathes
If m_PathesStack.Count > 0 Then
CurrentPathes = m_PathesStack.m_Array( m_PathesStack.Count-1 ).m_Array
Else
CurrentPathes = m_PathesStack.m_Array
End If
End Property
Public Property Get PathesStack : Set PathesStack = m_PathesStack : End Property
Private Sub Class_Initialize()
Set m_PathesStack = new ArrayClass : ErrCheck
m_ProgramFiles = g_sh.ExpandEnvironmentStrings( "%ProgramFiles%" )
m_windir = g_sh.ExpandEnvironmentStrings( "%windir%" )
m_APPDATA = g_sh.ExpandEnvironmentStrings( "%APPDATA%" )
m_LOCALAPPDATA = g_sh.ExpandEnvironmentStrings( "%LOCALAPPDATA%" )
If m_ProgramFiles = "%ProgramFiles%" Then m_ProgramFiles = Empty
If m_windir = "%windir%" Then m_windir = Empty
If m_APPDATA = "%APPDATA%" Then m_APPDATA = Empty
If m_LOCALAPPDATA = "%LOCALAPPDATA%" Then m_LOCALAPPDATA = Empty
End Sub
Public Sub PushPathes( AppKey, Pathes )
Dim i
If not g_AppKey.IsSame( AppKey ) Then Err.Raise 1,,"Invalied AppKey"
Dim new_pathes : Set new_pathes = new ArrayClass : ErrCheck
new_pathes.Copy Pathes
m_PathesStack.Push new_pathes
End Sub
Public Sub PopPathes( AppKey, Pathes )
Dim i,j
If not g_AppKey.IsSame( AppKey ) Then Err.Raise 1,,"Invalied AppKey"
For i=m_PathesStack.Count-1 To 0 Step -1
If Pathes.Count = m_PathesStack.m_Array(i).Count Then
For j=0 To Pathes.Count-1
If Pathes.m_Array(j) <> m_PathesStack.m_Array(i).m_Array(j) Then Exit For
Next
If j = Pathes.Count Then Exit For '// If same all Pathes
End If
Next
If i = -1 Then Err.Raise 1
For i=i To m_PathesStack.Count-2
Set m_PathesStack.m_Array(i) = m_PathesStack.m_Array(i+1)
Next
m_PathesStack.Pop
End Sub
Public Function CheckWritable( Path, Opt )
Dim abs_path, writable, s
abs_path = g_fs.GetAbsolutePathName( Path )
If Right( Path, 2 ) = "\." Then abs_path = abs_path + "\."
For Each writable In Me.CurrentPathes
If StrComp( writable, Left( abs_path, Len( writable ) ), 1 ) = 0 Then Exit Function
Next
s = abs_path + "\"
For Each writable In Me.CurrentPathes
If StrComp( writable, s, 1 ) = 0 Then Exit Function
Next
If Opt = 1 Then
s = abs_path : If Right( s, 2 ) = "\." Then s = Left( s, Len( s ) - 1 )
For Each writable In Me.CurrentPathes
If StrComp( s, Left( writable, Len( s ) ), 1 ) = 0 Then Exit Function
Next
End If
abs_path = g_AppKey.CheckNewWritable( abs_path )
If IsEmpty( abs_path ) Then Exit Function
If Right( abs_path, 2 ) = "\." Then abs_path = Left( abs_path, Len( abs_path ) - 2 )
CheckWritable = abs_path
End Function
Public Function CheckAddNewWritable( Path, out_PassedPath )
Dim abs_path, writable
abs_path = g_fs.GetAbsolutePathName( Path )
If Right( Path, 2 ) = "\." Then abs_path = abs_path + "\."
If not exist( Path ) Then
'// If the folder already exists, do not writable
For Each writable In Me.CurrentPathes
If Right( writable, 3 ) = "\*\" Then
If Left( writable, Len(writable) - 2 ) = Left( abs_path, Len( writable ) - 2 ) or _
Left( writable, Len(writable) - 3 ) = abs_path Then
out_PassedPath = Left( writable, Len(writable) - 3 )
Exit Function
End If
End If
Next
End If
If Right( abs_path, 2 ) = "\." Then abs_path = Left( abs_path, Len( abs_path ) - 2 )
CheckAddNewWritable = abs_path
End Function
Public Sub AskFileAccess( AbsPath )
If Left( AbsPath, Len( g_TempFile.m_FolderPath ) + 1 ) = g_TempFile.m_FolderPath + "\" Then _
Exit Sub
If not IsEmpty( m_ProgramFiles ) Then _
If Left( AbsPath, Len( m_ProgramFiles ) ) = m_ProgramFiles or _
Left( m_ProgramFiles, Len( AbsPath ) ) = AbsPath Then _
g_AppKey.Ask AbsPath
If not IsEmpty( m_windir ) Then _
If Left( AbsPath, Len( m_windir ) ) = m_windir or _
Left( m_windir, Len( AbsPath ) ) = AbsPath Then _
g_AppKey.Ask AbsPath
If not IsEmpty( m_APPDATA ) Then _
If Left( AbsPath, Len( m_APPDATA ) ) = m_APPDATA or _
Left( m_APPDATA, Len( AbsPath ) ) = AbsPath Then _
g_AppKey.Ask AbsPath
If not IsEmpty( m_LOCALAPPDATA ) Then _
If Left( AbsPath, Len( m_LOCALAPPDATA ) ) = m_LOCALAPPDATA or _
Left( m_LOCALAPPDATA, Len( AbsPath ) ) = AbsPath Then _
g_AppKey.Ask AbsPath
End Sub
End Class
'********************************************************************************
' <<< [SetWritableMode] >>>
'********************************************************************************
Sub SetWritableMode( Flags )
g_AppKey.SetWritableMode Flags
End Sub
'********************************************************************************
' <<< [CheckWritable] Check not to modify out of working folder >>>
' comment
' - If path is out of workfolder, raise error of E_OutOfWritable.
' - This function is overritable, because other APIs calling this and g_CurrentWritables
' can overrite.
'********************************************************************************
Sub CheckWritable( Path )
Dim abs_path
abs_path = g_CurrentWritables.CheckWritable( Path, Empty )
If IsEmpty( abs_path ) Then Exit Sub
g_AppKey.Ask abs_path
End Sub
'********************************************************************************
' <<< [set_workfolder] old function >>>
'********************************************************************************
Sub set_workfolder( ByVal dir )
If g_cut_old Then Stop
End Sub
Class WorkFolderStack
Private Sub Class_Initialize()
If g_cut_old Then Stop
End Sub
Public Sub set_( x ) : End Sub
End Class
'********************************************************************************
' <<< [SetBreakByFName] >>>
'********************************************************************************
Sub SetBreakByFName( FName )
g_AppKey.m_BreakByFName = FName
End Sub
'********************************************************************************
' <<< [cd] change current directory >>>
' sample
' cd "sub"
'********************************************************************************
Sub cd( ByVal dir )
echo ">cd """ & dir & """"
Dim en,ed
On Error Resume Next
g_sh.CurrentDirectory = dir
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = E_WIN32_FILE_NOT_FOUND or en = E_WIN32_DIRECTORY Then _
Err.Raise en,, "フォルダではありません : " & dir
If en <> 0 Then Err.Raise en,,ed
End Sub
'********************************************************************************
' <<< [CurDirStack] >>>
'********************************************************************************
Class CurDirStack
Public m_Prev
Private Sub Class_Initialize
m_Prev = g_sh.CurrentDirectory
End Sub
Private Sub Class_Terminate
g_sh.CurrentDirectory = m_Prev
End Sub
End Class
'********************************************************************************
' <<< [pushd] push and change current directory >>>
' sample
' pushd "sub"
'********************************************************************************
Dim g_pushd_stack()
Dim g_pushd_stack_n
Sub pushd( ByVal dir )
echo ">pushd " & dir
Dim sh
g_pushd_stack_n = g_pushd_stack_n + 1
Redim Preserve g_pushd_stack( g_pushd_stack_n )
Set sh = WScript.CreateObject("WScript.Shell")
g_pushd_stack( g_pushd_stack_n ) = sh.CurrentDirectory
sh.CurrentDirectory = dir
End Sub
'********************************************************************************
' <<< [popd] pop current directory >>>
'********************************************************************************
Sub popd
echo ">popd"
Dim sh
If g_pushd_stack_n < 1 Then Exit Sub
Set sh = WScript.CreateObject("WScript.Shell")
sh.CurrentDirectory = g_pushd_stack( g_pushd_stack_n )
g_pushd_stack_n = g_pushd_stack_n - 1
End Sub
'********************************************************************************
' <<< [copy] >>>
' argument
' - src : source file or folder path or wild card
' - dst : destination folder path or renaming file path
' comment
' - reference: vbslib.svg#copy
'********************************************************************************
Sub copy( ByVal src, ByVal dst )
Dim en,ed
' If src had Wild card
If IsWildcard( src ) Then
Dim fo
echo ">copy """ & src & """, """ & dst & """"
If Not g_fs.FolderExists( dst ) Then Set en=new EchoOff : mkdir dst : en=Empty
If Not g_fs.FolderExists( GetParentAbsPath( src ) ) Then _
Err.Raise E_PathNotFound,,"パスが見つかりません。"
g_AppKey.AddNewWritableFolder dst + "\." '// "\." is for able to make writable folder
If g_debug_or_test Then g_AppKey.BreakByWildcard src, F_File
On Error Resume Next
g_fs.CopyFile src, dst, True
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = E_FileNotExist Then en = 0
If en <> 0 Then Err.Raise en,,ed
Dim i_retry '// 1回目に E_WriteAccessDenied になることがたまにあるため
For i_retry = 1 To 2
On Error Resume Next
g_fs.CopyFolder src, dst, True
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = E_PathNotFound Then en = 0
If i_retry >= 2 and en <> E_WriteAccessDenied Then
If en <> 0 Then Err.Raise en,,ed
End If
If en = 0 Then Exit For
echo_r "", ""
Sleep g_FileSystemRetryMSec
Next
' If src is file
ElseIf g_fs.FileExists( src ) Then
Dim dst_fo
If g_fs.FolderExists( dst ) Then
dst = g_fs.BuildPath( dst, g_fs.GetFileName( src ) )
Else
dst_fo = GetParentAbsPath( dst )
If dst_fo <> "" And Not g_fs.FolderExists( dst_fo ) Then _
Set en=new EchoOff : mkdir dst_fo : en=Empty
End If
echo ">copy """ & src & """, """ & dst & """"
If not g_fs.FileExists( dst ) Then
g_AppKey.AddNewWritableFolder dst + "\." '// "\." is for able to make writable folder
Else
g_AppKey.AddNewWritableFolder dst
End If
On Error Resume Next
g_fs.CopyFile src, dst, True
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = 70 Then ed = ed + " : " + dst
If en <> 0 Then Err.Raise en,,ed
' If src is folder
ElseIf g_fs.FolderExists( src ) Then
If Not g_fs.FolderExists( dst ) Then Set en=new EchoOff : mkdir dst : en=Empty
echo ">copy """ & src & """, """ & dst & """"
g_AppKey.AddNewWritableFolder dst
If g_debug_or_test Then g_AppKey.BreakByWildcard src+"\*", F_File or F_SubFolder
g_fs.CopyFolder src, g_fs.BuildPath( dst, g_fs.GetFileName( src ) ), True
' not found
Else
echo ">copy """ & src & """, """ & dst & """"
g_AppKey.AddNewWritableFolder dst + "\." '// "\." is for able to make writable folder
g_fs.CopyFile src, dst, True ' Error occurs
End If
End Sub
'********************************************************************************
' <<< [move] >>>
'********************************************************************************
Sub move( ByVal src, ByVal dst )
' If src had Wild card
If IsWildcard( src ) Then
Dim fo,en,ed
If Not g_fs.FolderExists( dst ) Then mkdir dst
echo ">move """ & src & """, """ & dst & """"
If Not g_fs.FolderExists( g_fs.GetParentFolderName( src ) ) Then _
Err.Raise E_PathNotFound,,"パスが見つかりません。"
g_AppKey.AddNewWritableFolder dst + "\." '// "\." is for able to make writable folder
If g_debug_or_test Then g_AppKey.BreakByWildcard src, F_File
On Error Resume Next
g_fs.MoveFile src, dst
g_fs.MoveFolder src, dst
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = E_PathNotFound Then en = 0
If en = E_FileNotExist Then en = 0
If en <> 0 Then Err.Raise en,,ed
' If src is file
ElseIf g_fs.FileExists( src ) Then
Dim dst_fo
If g_fs.FolderExists( dst ) Then
dst = g_fs.BuildPath( dst, g_fs.GetFileName( src ) )
Else
dst_fo = GetParentAbsPath( dst )
If Not g_fs.FolderExists( dst_fo ) Then mkdir dst_fo
End If
echo ">move """ & src & """, """ & dst & """"
g_AppKey.AddNewWritableFolder src
If IsWildcard( src ) or not g_fs.FileExists( dst ) Then
g_AppKey.AddNewWritableFolder dst + "\." '// "\." is for able to make writable folder
Else
g_AppKey.AddNewWritableFolder dst
del dst
End If
g_fs.MoveFile src, dst
' If src is folder
ElseIf g_fs.FolderExists( src ) Then
If Not g_fs.FolderExists( dst ) Then mkdir dst
echo ">move """ & src & """, """ & dst & """"
g_AppKey.AddNewWritableFolder dst
If g_debug_or_test Then g_AppKey.BreakByWildcard src+"\*", F_File or F_SubFolder
g_fs.MoveFolder src, g_fs.BuildPath( dst, g_fs.GetFileName( src ) )
' not found
Else
echo ">move """ & src & """, """ & dst & """"
g_AppKey.AddNewWritableFolder dst + "\." '// "\." is for able to make writable folder
g_fs.MoveFile src, dst ' Error occurs
End If
End Sub
'********************************************************************************
' <<< [ren] >>>
'********************************************************************************
Sub ren( src, dst )
echo ">ren """ & src & """, """ & dst & """"
Dim f
If g_fs.FileExists( src ) Then
g_AppKey.AddNewWritableFolder src
Set f = g_fs.GetFile( src )
f.Name = g_fs.GetFileName( dst )
Else
g_AppKey.AddNewWritableFolder src + "\." '// "\." is for able to make writable folder
Set f = g_fs.GetFolder( src )
f.Name = g_fs.GetFileName( dst )
End If
End Sub
'********************************************************************************
' <<< [SafeFileUpdate] >>>
'********************************************************************************
Sub SafeFileUpdate( FromTmpFilePath, ToUpdateFilePath )
echo ">SafeFileUpdate """ & FromTmpFilePath & """, """ & ToUpdateFilePath & """"
Dim en,ed,en2,ed2,i,path
For i=1 To 999
path = GetParentAbsPath( ToUpdateFilePath ) + "\" + _
g_fs.GetBaseName( ToUpdateFilePath ) + "." & i & "." + g_fs.GetExtensionName( ToUpdateFilePath )
If not exist( path ) Then Exit For
Next
If exist( path ) Then Err.Raise E_Other,,"バックアップのファイル名が作れません。:" + ToUpdateFilePath
On Error Resume Next
g_fs.CopyFile ToUpdateFilePath, path, False
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en <> 0 Then Err.Raise en,,"バックアップコピーに失敗しました。"+vbCR+vbLF+_
"バックアップ元:"+ToUpdateFilePath+vbCR+vbLF+ "バックアップ先:"+path+vbCR+vbLF+ ed
del_to_trashbox path
On Error Resume Next
g_fs.CopyFile FromTmpFilePath, ToUpdateFilePath, True
en2 = Err.Number : ed2 = Err.Description : On Error GoTo 0
On Error Resume Next
g_fs.DeleteFile FromTmpFilePath
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en2 <> 0 Then Err.Raise en2,,"上書きコピーに失敗しました。ゴミ箱に入れた元のファイルを復活させてください。"+vbCR+vbLF+_
"コピー元:"+FromTmpFilePath+vbCR+vbLF+ "コピー先:"+ToUpdateFilePath+vbCR+vbLF+ ed2
If en <> 0 Then WScript.Echo "更新は成功しましたが、一時ファイルの削除に失敗しました。"+vbCR+vbLF+_
"一時ファイル:"+FromTmpFilePath+vbCR+vbLF+ "更新済みファイル:"+ToUpdateFilePath+vbCR+vbLF+ ed
End Sub
'********************************************************************************
' <<< [del] >>>
'********************************************************************************
Sub del( ByVal path )
echo ">del """ & path & """"
Dim ec : Set ec = new EchoOff
' If path had Wild card
If IsWildCard( path ) Then
Dim folder, fname, fnames()
ExpandWildcard path, F_File, folder, fnames
For Each fname in fnames
del g_fs.BuildPath( folder, fname )
Next
ExpandWildcard path, F_Folder, folder, fnames
For Each fname in fnames
del g_fs.BuildPath( folder, fname )
Next
' If path was file or folder path
Else
If g_fs.FileExists( path ) Then
g_AppKey.AddNewWritableFolder path
g_fs.DeleteFile path
ElseIf g_fs.FolderExists( path ) Then
rmdir path
End If
End If
End Sub
'********************************************************************************
' <<< [del_subfolder] >>>
'********************************************************************************
Sub del_subfolder( ByVal path )
echo ">del_subfolder """ & path & """"
Dim folder, fname, fnames()
ExpandWildcard path, F_File Or F_SubFolder, folder, fnames
For Each fname in fnames
del g_fs.BuildPath( folder, fname )
Next
ExpandWildcard path, F_Folder Or F_SubFolder, folder, fnames
For Each fname in fnames
del g_fs.BuildPath( folder, fname )
Next
End Sub
'********************************************************************************
' <<< [del_to_trashbox] >>>
'********************************************************************************
Sub del_to_trashbox( ByVal path )
echo ">del_to_trashbox """ & path & """"
Dim en,ed
Dim sh_ap, TrashBox, folder, item, fname
Set sh_ap = CreateObject("Shell.Application")
Const ssfBITBUCKET = 10
g_AppKey.AddNewWritableFolder path + "\." '// "\." is for able to make writable folder
'//=== Check deletable by rename for Windows XP
On Error Resume Next
ren path, g_fs.GetFileName( path ) + "_deleting"
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = 70 Then Err.Raise 17,,"ゴミ箱へ移動できません : " + path
If en = 76 Then Exit Sub ' not found path
If en <> 0 Then Err.Raise en,,ed
On Error Resume Next
ren path + "_deleting", g_fs.GetFileName( path )
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en <> 0 and en <> E_OutOfWritable Then Err.Raise en,,ed
'//=== move to trashbox
path = g_fs.GetAbsolutePathName( path )
fname = g_fs.GetFileName( path )
Set folder = sh_ap.NameSpace( g_fs.GetParentFolderName( path ) )
If folder is Nothing Then Exit Sub
Set item = folder.Items.Item( fname )
If item is Nothing Then Exit Sub
Set TrashBox = sh_ap.NameSpace( ssfBITBUCKET )
TrashBox.MoveHere item
'//=== for Windows Vista
' If exist( path ) Then Err.Raise 17,,"ゴミ箱へ移動できません : " + path
'//=== for Windows XP
Do
WScript.Sleep 300
Set item = folder.Items.Item( fname )
If item is Nothing Then Exit Do
item = Empty
Loop
End Sub
'********************************************************************************
' <<< [del_confirmed] >>>
'********************************************************************************
Function del_confirmed( Path )
echo ">del_confirmed """ & Path & """"
If exist( Path ) Then
Dim r : r = input( "削除してよろしいですか? : " + Path + " (Y/N)" )
del_confirmed = ( r="Y" or r="y" )
If del_confirmed Then del Path
Else
del_confirmed = True
End If
End Function
'********************************************************************************
' <<< [mkdir] >>>
'********************************************************************************
Function mkdir( ByVal Path )
echo ">mkdir """ & Path & """"
Dim i, n, names(), fo2
g_AppKey.AddNewWritableFolder_sub Path + "\.", 1
If g_fs.FolderExists( Path ) Then mkdir = 0 : Exit Function
n = 0
fo2 = g_fs.GetAbsolutePathName( Path )
Do
If g_fs.FolderExists( fo2 ) Then Exit Do
n = n + 1
Redim Preserve names(n)
names(n) = g_fs.GetFileName( fo2 )
fo2 = g_fs.GetParentFolderName( fo2 )
Loop
mkdir = n
For n=n To 1 Step -1
fo2 = g_fs.BuildPath( fo2, names(n) )
g_fs.CreateFolder fo2
Next
End Function
'********************************************************************************
' <<< [mkdir_for] >>>
'********************************************************************************
Sub mkdir_for( Path )
Dim s
s = g_fs.GetParentFolderName( Path )
If s = "" Then Exit Sub
mkdir s
End Sub
'********************************************************************************
' <<< [rmdir] >>>
'********************************************************************************
Sub rmdir( ByVal Path )
echo ">rmdir """ & Path & """"
Dim path2, iFolder, nFolder, fo, subf, f, file
If Not g_fs.FolderExists( Path ) Then Exit Sub
g_AppKey.AddNewWritableFolder Path + "\." '// "\." is for able to make writable folder
' Cut last \
path2 = Path
If Right( path2, 1 ) = "\" Then path2 = Left( path2, Len( path2 ) - 1 )
nFolder = 1
ReDim folderPathes(nFolder)
folderPathes(nFolder) = path2
' Enum sub folders
iFolder = 1
While iFolder <= nFolder
Set fo = g_fs.GetFolder( folderPathes(iFolder) )
For Each subf in fo.SubFolders
nFolder = nFolder + 1
ReDim Preserve folderPathes(nFolder)
folderPathes(nFolder) = subf.Path
Next
iFolder = iFolder + 1
WEnd
' Remove read only attribute of all files in sub folders
For iFolder = 1 To nFolder
Set fo = g_fs.GetFolder( folderPathes(iFolder) )
For Each f in fo.Files
Set file = g_fs.GetFile( f.Path )
If g_debug_or_test Then g_AppKey.BreakByPath( f.Path )
file.Attributes = file.Attributes And Not ReadOnly
Next
Next
' Delete folders
Dim en,ed
Dim i_retry '// 1回目に E_WriteAccessDenied になることがたまにあるため
For i_retry = 1 To 2
On Error Resume Next
g_fs.DeleteFolder( Path )
en = Err.Number : ed = Err.Description : On Error GoTo 0
If i_retry >= 2 and en <> E_WriteAccessDenied Then
If en = E_WriteAccessDenied Then ed = "Denied to delete the folder: "+ Path
If en <> 0 Then Err.Raise en,,ed
End If
If en = 0 Then Exit For
echo_r "", ""
Sleep g_FileSystemRetryMSec
Next
End Sub
'********************************************************************************
' <<< [exist] >>>
'********************************************************************************
Function exist( ByVal path )
If IsWildcard( path ) Then
Dim folder, fnames()
ExpandWildcard path, F_File or F_Folder, folder, fnames
exist = UBound( fnames ) <> -1
Else
exist = ( g_fs.FileExists( path ) = True ) Or ( g_fs.FolderExists( path ) = True )
End If
End Function
'********************************************************************************
' <<< [fc] file compare as binary >>>
' argument
' - return : True=same, False=different
'********************************************************************************
Function fc( path_a, path_b )
fc = fc_r( path_a, path_b, "" )
End Function
'********************************************************************************
' <<< [fc_r] file compare as binary >>>
' argument
' - return : True=same, False=different
'********************************************************************************
Function fc_r( path_a, path_b, redirect_path )
Dim opt : Set opt = new fc_option : ErrCheck
opt.m_RedirectPath = redirect_path
fc_r = fc_ex( path_a, path_b, opt )
End Function
'********************************************************************************
' <<< [fc_ex] file compare as binary >>>
'********************************************************************************
Function fc_ex( PathA, PathB, Opt )
Dim cmdline, opt_echo, redirect_path, b_stdout
Dim s, b
'//=== set cmdline from Opt.m_IniPath
cmdline = """" + g_vbslib_ver_folder + "feq.exe"""
If not IsEmpty( Opt ) Then
If not IsEmpty( Opt.m_IniPath ) Then
cmdline = cmdline + " /ini:""" + Opt.m_IniPath + """"
opt_echo = " /ini:" + g_fs.GetFileName( Opt.m_IniPath )
End If
End If
cmdline = cmdline + " """ + PathA + """ """ + PathB + """"
'//=== set redirect_path from Opt.m_RedirectPath
If not IsEmpty( Opt ) Then
redirect_path = Opt.m_RedirectPath
b_stdout = Opt.m_bStdOut
End If
'//=== echo
b = True : If Not IsEmpty( Opt ) Then b = (Opt.m_RedirectPath = "")
If b Then '// IsEmpty or
echo ">fc " + opt_echo + " """ + PathA + """ """ + PathB + """"
Else
Dim f : Set f = g_fs.OpenTextFile( redirect_path, 8, True, False )
f.WriteLine ">fc " + opt_echo + " """ + PathA + """ """ + PathB + """"
f = Empty
End If
'//=== Exec
Dim ex
chk_exist_in_lib "feq.exe"
Set ex = g_sh.Exec( cmdline )
If not IsEmpty( redirect_path ) Then redirect_path = g_sh.ExpandEnvironmentStrings( redirect_path )
fc_ex = ( WaitForFinishAndRedirect( ex, redirect_path ) = 0 )
End Function
'********************************************************************************
' <<< [fc_option] >>>
'********************************************************************************
Class fc_option
Public m_IniPath
Public m_RedirectPath
Public m_bStdOut
End Class
'********************************************************************************
' <<< [find] find lines including keyword >>>
'********************************************************************************
Function find( ByVal keyword, ByVal path )
Dim f, line, ret
Set f = g_fs.OpenTextFile( path )
ret = ""
Do Until f.AtEndOfStream
line = f.ReadLine
If InStr( line, keyword ) > 0 Then ret = ret + line
Loop
f.Close
find = ret
End Function
'********************************************************************************
' <<< [find_c] find lines count including keyword >>>
'********************************************************************************
Function find_c( ByVal keyword, ByVal path )
Dim f, line, ret
Set f = g_fs.OpenTextFile( path )
ret = 0
Do Until f.AtEndOfStream
line = f.ReadLine
If InStr( line, keyword ) > 0 Then ret = ret + 1
Loop
f.Close
find_c = ret
End Function
'********************************************************************************
' <<< [grep] >>>
'********************************************************************************
Sub grep( Keyword, FolderPath, OutFName, Opt )
Dim ds_:Set ds_= New CurDirStack : ErrCheck
del "_grep_out.txt"
cd FolderPath
del "_grep_out.txt"
RunProg "cmd /C for /R %i in (*) do find """ + Keyword + """ ""%i"" >> _grep_out.txt", ""
ds_= Empty
move FolderPath + "\_grep_out.txt", "."
If OutFName <> "_grep_out.txt" Then ren "_grep_out.txt", OutFName
End Sub
'********************************************************************************
' <<< [sort] >>>
'********************************************************************************
Sub sort( InPath, OutPath )
RunProg "cmd /C sort """ + InPath + """ /o """ + OutPath + """", ""
End Sub
'********************************************************************************
' <<< [CreateFile] Create 1 line text file >>>
'********************************************************************************
Function CreateFile( ByVal Path, ByVal Text )
Dim t, folder
t = InStr( Text, vbCRLF )
If t = 0 Then t = Text+"""" Else t = Left( Text, t-1 ) + """+vbCRLF+..."
echo ">CreateFile """ & Path & """, """ & t
If IsWildcard( Path ) Then Path = GetTempPath( Path ) : echo "Create """ & Path & """"
Dim ec : Set ec = new EchoOff : ErrCheck
g_AppKey.AddNewWritableFolder Path
Path = g_fs.GetAbsolutePathName( Path )
folder = g_fs.GetParentFolderName( Path )
If not g_fs.FolderExists( folder ) Then mkdir folder
Set t = g_fs.CreateTextFile( Path, True, (g_TextFileCreateFormat = F_Unicode) )
t.Write Text
t.Close
CreateFile = Path
End Function
'********************************************************************************
' <<< [ReadFile] >>>
'********************************************************************************
Function ReadFile( Path )
Dim f, en, ed
ReadFile = ""
On Error Resume Next
Set f = g_fs.OpenTextFile( Path, 1, False, -2 )
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = E_FileNotExist or en = E_PathNotFound Then Exit Function
'// E_PathNotFound is not found parent folder
If en <> 0 Then Err.Raise en,,ed
ReadFile = ReadAll( f )
End Function
'********************************************************************************
' <<< [type_] >>>
'********************************************************************************
Sub type_( Path )
echo ">type_ """ & Path & """"
echo ReadFile( Path )
End Sub
'********************************************************************************
' <<< [OpenForRead] >>>
'********************************************************************************
Function OpenForRead( Path )
echo ">OpenForRead """ & Path & """"
Dim en, ed
On Error Resume Next
Set OpenForRead = g_fs.OpenTextFile( Path,,,-2 )
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = E_FileNotExist or en = E_PathNotFound Then Err.raise en,,ed+" : "+Path
If en <> 0 Then Err.Raise en,,ed
End Function
'********************************************************************************
' <<< [OpenForWrite] >>>
'********************************************************************************
Const F_Shift_JIS = &h1000
Const F_Unicode = 2
Const F_Append = 4
Function OpenForWrite( ByVal Path, Flags )
echo ">OpenForWrite """ & Path & """"
Dim en, ed
Dim bUnicode : bUnicode = ((Flags and F_Unicode) = F_Unicode)
Dim bAppend : bAppend = ((Flags and F_Append) = F_Append)
If ( Flags and (F_Shift_JIS or F_Unicode) ) = 0 Then _
bUnicode = (g_TextFileCreateFormat = F_Unicode)
If IsWildcard( Path ) Then Path = GetTempPath( Path ) : echo "Create """ & Path & """"
g_AppKey.AddNewWritableFolder Path
On Error Resume Next
If bAppend Then
Set OpenForWrite = g_fs.OpenTextFile( Path, 8, True, -2 )
Else
Set OpenForWrite = g_fs.CreateTextFile( Path, True, bUnicode )
End If
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = E_PathNotFound Then
Dim fo : fo = g_fs.GetParentFolderName( Path )
If not g_fs.FolderExists( fo ) Then
mkdir fo
On Error Resume Next
Set OpenForWrite = g_fs.CreateTextFile( Path, True, bUnicode )
en = Err.Number : ed = Err.Description : On Error GoTo 0
End If
End If
If en <> 0 Then Err.Raise en,,ed
End Function
'********************************************************************************
' <<< [GetTempPath] >>>
'********************************************************************************
Class TempFileClass
Public m_FolderPath
Public m_LimitDate
End Class
Dim g_TempFile
Function GetTempPath( Param )
Dim param_abs, path, t, i, fo, f
GetObject_g_TempFile
'//=== Delete old files
If not g_fs.FolderExists( g_TempFile.m_FolderPath ) Then _
mkdir g_TempFile.m_FolderPath
Set fo = g_fs.GetFolder( g_TempFile.m_FolderPath )
For Each f in fo.Files
If f.DateLastModified < g_TempFile.m_LimitDate Then
g_fs.DeleteFile f.Path
End If
Next
For Each f in fo.SubFolders
If f.DateLastModified < g_TempFile.m_LimitDate Then
g_fs.DeleteFolder f.Path
End If
Next
'//=== path : Make unique path
t = Now()
param_abs = GetAbsPath( Param, g_TempFile.m_FolderPath +"\"+ _
Right( "0" & (Year(t) mod 100), 2 ) & _
Right( "0" & Month(t), 2 ) & Right( "0" & Day(t), 2 ) )
t = Right( "0" & (Year(t) mod 100), 2 ) & _
Right( "0" & Month(t), 2 ) & Right( "0" & Day(t), 2 ) & "_" & _
Right( "0" & Hour(t), 2 ) & Right( "0" & Minute(t), 2 ) & "_"
i = 1
Do
path = Replace( param_abs, "*", t & i )
If not exist( path ) Then Exit Do
i = i + 1
If InStr( param_abs, "*" ) = 0 Then Exit Do
Loop
GetTempPath = path
End Function
'********************************************************************************
' <<< [GetObject_g_TempFile] >>>
'********************************************************************************
Sub GetObject_g_TempFile()
If IsEmpty( g_TempFile ) Then
Set g_TempFile = new TempFileClass : ErrCheck
If IsDefined( "Setting_getTemp" ) Then
Dim out1, out2
Setting_getTemp out1, out2
g_TempFile.m_FolderPath = out1
g_TempFile.m_LimitDate = out2
End If
If IsEmpty( g_TempFile.m_FolderPath ) Then _
g_TempFile.m_FolderPath = env( "%Temp%\Report" )
If IsEmpty( g_TempFile.m_LimitDate ) Then _
g_TempFile.m_LimitDate = DateAdd( "d", -2, Now() )
If InStr( g_TempFile.m_FolderPath, "Temp" ) = 0 Then
echo "Not found ""Temp"" in temporary folder path in %Temp% or Setting_getTemp."
echo "Is this temporary folder path to delete? : " + g_TempFile.m_FolderPath
echo "これは削除してもよい一時フォルダのパスですか? : " + g_TempFile.m_FolderPath
pause
End If
g_AppKey.AddNewWritableFolder g_TempFile.m_FolderPath + "\."
End If
End Sub
'********************************************************************************
' <<< [ReadAll] >>>
'********************************************************************************
Function ReadAll( FileStream )
Dim en, ed
ReadAll = ""
On Error Resume Next
ReadAll = FileStream.ReadAll
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = E_EndOfFile Then en = 0
If en <> 0 Then Err.Raise en,,ed
End Function
'********************************************************************************
' <<< [Txt2BinTxt] >>>
'********************************************************************************
Sub Txt2BinTxt( SrcPath, DstPath )
Dim r
Dim txt2bintxt_exe : txt2bintxt_exe = g_vbslib_ver_folder + "txt2bintxt.exe"
If not g_fs.FileExists( txt2bintxt_exe ) Then _
Err.Raise 1,, "not found txt2bintxt.exe in vbslib folder"
r = RunProg( """"+txt2bintxt_exe+""" """+SrcPath+""" """+DstPath+"""", Empty )
If r<>0 Then Err.Raise 1,, "error 0x" & Hex(r) & " in txt2bintxt.exe"
End Sub
'********************************************************************************
' <<< [WriteVBSLibHeader] >>>
'********************************************************************************
Sub WriteVBSLibHeader( OutFileStream, Opt )
Dim f, line
Set f = g_fs.OpenTextFile( WScript.ScriptFullName )
Do Until f.AtEndOfStream
line = f.ReadLine
If InStr( line, "g_CommandPrompt =" ) > 0 and not IsEmpty( Opt ) Then
If not IsEmpty( Opt.m_OverCommandPrompt ) Then
line = " g_CommandPrompt = " & Opt.m_OverCommandPrompt
End If
End If
If InStr( line, "main()" ) > 0 Then Exit Do
If InStr( line, "main2(" ) > 0 Then Exit Do
OutFileStream.WriteLine line
Loop
End Sub
Class WriteVBSLibHeader_Option
Public m_OverCommandPrompt
End Class
'********************************************************************************
' <<< [GetAbsPath] >>>
'********************************************************************************
Function GetAbsPath( StepPath, ByVal BasePath )
Dim i, ii, i3, sep_ch, path
Dim i_root
If IsEmpty( BasePath ) Then BasePath = g_sh.CurrentDirectory
If IsAbsPath( StepPath ) Then BasePath = Empty
'//=== sep_ch = separetor "\" or "/"
If IsEmpty( BasePath ) Then
i = InStr( StepPath, "\" )
ii = InStr( StepPath, "/" )
Else
i = InStr( BasePath, "\" )
ii = InStr( BasePath, "/" )
End If
If i > 0 Then
If ii > 0 Then
If i > ii Then sep_ch = "/" Else sep_ch = "\"
Else
sep_ch = "\"
End If
Else
If ii > 0 Then sep_ch = "/" Else sep_ch = "\"
End If
'(debug point) watch "sep_ch"
'//=== Joint and Replace to sep_ch
If Right( BasePath, 1 ) = sep_ch or IsEmpty( BasePath ) Then
path = BasePath + StepPath
Else
path = BasePath + sep_ch + StepPath
End If
If sep_ch = "\" Then
path = Replace( path, "/", "\" )
Else
path = Replace( path, "\", "/" )
End If
'(debug point) watch "path"
'//=== Get i_root
i_root = InStr( path, sep_ch )
If Mid( path, i_root+1, 1 ) = sep_ch Then
i = InStr( i_root+2, path, sep_ch )
If i > 0 Then
i_root = i
Else
path = path + sep_ch
i_root = Len( path ) + 1
End If
End If
'//=== Cut \.\
Do
i = InStr( path, sep_ch+"."+sep_ch )
If i = 0 Then Exit Do
path = Left( path, i ) + Mid( path, i+3 )
Loop
If Right( path, 2 ) = sep_ch+"." Then path = Left( path, Len(path)-2 )
'//=== Cut xxx\..\
Do
i = InStr( path, sep_ch+".."+sep_ch )
If i = 0 Then Exit Do
i3 = 0
Do
ii = InStr( i3+1, path, sep_ch )
If ii = 0 Then Exit Do
If ii = i Then
If i = i_root Then
path = Left( path, i ) + Mid( path, i+4 ) '// Cut "\..\"
Else
path = Left( path, i3 ) + Mid( path, i+4 ) '// Cut xxx\..\
End If
Exit Do
End If
i3 = ii
Loop
Loop
'//=== Cut xxx\..
If Right( path, 3 ) = sep_ch+".." Then
i = Len( path ) - 2
If i = i_root Then
path = Left( path, i )
Else
i = InStrRev( path, sep_ch, i-1 )
If i = i_root Then
path = Left( path, i )
Else
path = Left( path, i-1 )
End If
End If
End If
If Right( path, 1 ) = ":" Then path = path + sep_ch
'(debug point) watch "path"
GetAbsPath = path
End Function
'********************************************************************************
' <<< [GetStepPath] >>>
' - AbsPath, BasePath, (return) as string
'********************************************************************************
Function GetStepPath( AbsPath, BasePath )
Dim AbsPathU, BasePathU, path, sep_ch, i, ii
AbsPathU = UCase(AbsPath)
If IsEmpty( BasePath ) Then
BasePathU = UCase(g_sh.CurrentDirectory)
Else
BasePathU = UCase(BasePath)
End If
'// sep_ch = separetor "\" or "/"
i = InStr( AbsPath, "\" )
ii = InStr( AbsPath, "/" )
If i > 0 Then
If ii > 0 Then
If i > ii Then sep_ch = "/" Else sep_ch = "\"
Else
sep_ch = "\"
End If
Else
If ii > 0 Then sep_ch = "/" Else sep_ch = "\"
End If
'(debug point) watch "sep_ch"
'// path = common parent folder path. The last character is not sep_ch
path = BasePathU
If Right( BasePathU, 1 ) = sep_ch Then path = Left( BasePathU, Len(BasePathU)-1 )
Do
If path = Left( AbsPathU, Len(path) ) Then Exit Do
path = g_fs.GetParentFolderName( path )
Loop
If path = "" Then GetStepPath = AbsPath : Exit Function
If Right( path, 1 ) = sep_ch Then path = Left( path, Len(path)-1 )
'(debug point) watch "path"
'// GetStepPath = step path without ..\
GetStepPath = Mid( AbsPath, Len(path) + 2 )
'(debug point) watch "GetStepPath"
'// GetStepPath: Add "..\"
path = Mid( BasePath, Len(path) + 2 )
Do
If path = "" Then Exit Do
path = g_fs.GetParentFolderName( path )
GetStepPath = ".." + sep_ch + GetStepPath
Loop
'(debug point) watch "GetStepPath"
If GetStepPath = "" Then GetStepPath = "."
End Function
'********************************************************************************
' <<< [GetParentAbsPath] >>>
'********************************************************************************
Function GetParentAbsPath( Path )
GetParentAbsPath = g_fs.GetParentFolderName( g_fs.GetAbsolutePathName( Path ) )
End Function
'********************************************************************************
' <<< [IsAbsPath] >>>
'********************************************************************************
Function IsAbsPath( Path )
Dim bs : bs = InStr( Path, "\" )
Dim sl : sl = InStr( Path, "/" )
Dim co : co = InStr( Path, ":" )
IsAbsPath = ( co > 0 and ( bs = co+1 or sl = co+1 ) )
End Function
'********************************************************************************
' <<< [FindParent] >>>
'********************************************************************************
Function FindParent( TargetStepPath, StartFolderPath )
Dim base : base = GetAbsPath( StartFolderPath, Empty )
Dim path
Do
path = base + "\" + TargetStepPath
If g_fs.FileExists( path ) or g_fs.FolderExists( path ) Then Exit Do
base = g_fs.GetParentFolderName( base )
If base = "" Then Raise E_PathNotFound, _
""
Loop
FindParent = path
End Function
'********************************************************************************
' <<< [GetTagJumpPath] >>>
'********************************************************************************
Function GetTagJumpPath( PathAndLine )
Dim i : i = InStrRev( PathAndLine, "(" )
If i > 0 Then
GetTagJumpPath = Left( PathAndLine, i-1 )
Else
GetTagJumpPath = PathAndLine
End If
End Function
'********************************************************************************
' <<< [IsWildcard] >>>
'********************************************************************************
Function IsWildcard( ByVal path )
IsWildcard = InStr( path, "?" ) <> 0 Or InStr( path, "*" ) <> 0
End Function
'********************************************************************************
' <<< [ExpandWildcard] >>>
'********************************************************************************
Sub ExpandWildcard( ByVal wildcard_path, flags, folder, fnames )
Dim s, re
folder = g_fs.GetParentFolderName( g_fs.GetAbsolutePathName( wildcard_path ) )
Set re = CreateObject("VBScript.RegExp")
re.Global = True
s = g_fs.GetFileName( wildcard_path )
re.Pattern = "\\" : s = re.Replace( s, "\\" )
re.Pattern = "\." : s = re.Replace( s, "\." )
re.Pattern = "\$" : s = re.Replace( s, "\$" )
re.Pattern = "\^" : s = re.Replace( s, "\^" )
re.Pattern = "\{" : s = re.Replace( s, "\{" )
re.Pattern = "\}" : s = re.Replace( s, "\}" )
re.Pattern = "\[" : s = re.Replace( s, "\[" )
re.Pattern = "\]" : s = re.Replace( s, "\]" )
re.Pattern = "\(" : s = re.Replace( s, "\(" )
re.Pattern = "\)" : s = re.Replace( s, "\)" )
re.Pattern = "\|" : s = re.Replace( s, "\|" )
re.Pattern = "\+" : s = re.Replace( s, "\+" )
re.Pattern = "\*" : s = re.Replace( s, ".*" )
re.Pattern = "\?" : s = re.Replace( s, "." )
re.Pattern = "^" + s
If Left( re.Pattern, 3 ) = "^.*" Then re.Pattern = Mid( re.Pattern, 4 )
re.Global = False
re.IgnoreCase = True
ReDim fnames( -1 )
ExpandWildcard_sub re, flags, folder, "", fnames
End Sub
Sub ExpandWildcard_sub( re, flags, folder, step_folder, fnames )
Dim fo, f
If not g_fs.FolderExists( folder ) Then Exit Sub
Set fo = g_fs.GetFolder( folder )
If flags And F_File Then
For Each f in fo.Files
If re.Test( f.Name ) Then
ReDim Preserve fnames( UBound(fnames) + 1 )
fnames( UBound(fnames) ) = step_folder + f.Name
End If
Next
End If
If flags And F_Folder Then
For Each f in fo.SubFolders
If re.Test( f.Name ) Then
ReDim Preserve fnames( UBound(fnames) + 1 )
fnames( UBound(fnames) ) = step_folder + f.Name
End If
Next
End If
If flags And F_SubFolder Then
For Each f in fo.SubFolders
ExpandWildcard_sub re, flags, f.Path, step_folder + f.Name + "\", fnames
Next
End If
End Sub
'********************************************************************************
' <<< [GetSubFolders] >>>
' argument
' - folders : (out) array of folder pathes
' - path : base folder path
'********************************************************************************
Sub GetSubFolders( folders, ByVal path )
ReDim folders(-1)
EnumSubFolders folders, g_fs.GetFolder( path )
End Sub
Sub EnumSubFolders( folders, fo )
Dim subfo
ReDim Preserve folders( UBound(folders) + 1 )
folders( UBound(folders) ) = fo.Path
For Each subfo in fo.SubFolders
EnumSubFolders folders, subfo
Next
End Sub
'********************************************************************************
' <<< [EnumFolderObject] >>>
'(argument)
' out_Folders as Folder
' FolderPath as string
'(sample)
' For Each fo In folders
' For Each f In fo.Files
' n = f.DateLastModified
' Next
' Next
'********************************************************************************
Sub EnumFolderObject( FolderPath, out_Folders )
Dim i_set, i_get, n, f
ReDim out_Folders(0)
Set out_Folders(0) = g_fs.GetFolder( FolderPath )
i_set = 1 : i_get = 0
While i_get <= UBound( out_Folders )
n = out_Folders( i_get ).SubFolders.Count
ReDim Preserve out_Folders( UBound( out_Folders ) + n )
For Each f In out_Folders( i_get ).SubFolders
Set out_Folders( i_set ) = f
i_set = i_set + 1
Next
i_get = i_get + 1
WEnd
End Sub
'********************************************************************************
' <<< [RemoveWildcard] >>>
'********************************************************************************
Sub RemoveWildcard( WildCard, fnames )
Dim s, path, fname, i, n, wc, wc_len
'//=== check by with wildcard
If Left( WildCard, 1 ) = "*" Then
wc = LCase( Mid( WildCard, 2 ) ) : wc_len = Len( wc )
n = UBound( fnames )
For i = 0 To n
path = fnames(i)
Do
fname = g_fs.GetFileName( path )
If LCase( Right( fname, wc_len ) ) = wc Then fnames(i) = Empty : Exit Do
path = g_fs.GetParentFolderName( path )
If path = "" Then Exit Do
Loop
Next
'//=== check by no wildcard
Else
wc = LCase( WildCard )
n = UBound( fnames )
For i = 0 To n
path = fnames(i)
Do
fname = g_fs.GetFileName( path )
If LCase( fname ) = wc Then fnames(i) = Empty : Exit Do
path = g_fs.GetParentFolderName( path )
If path = "" Then Exit Do
Loop
Next
End If
'//=== shrink the array
n = 0
For i = 0 To UBound( fnames )
If not IsEmpty( fnames(i) ) Then fnames(n) = fnames(i) : n = n + 1
Next
Redim Preserve fnames( n - 1 )
End Sub
'********************************************************************************
' <<< [MeltCSV] >>>
'********************************************************************************
Function MeltCSV( Line, in_out_Start )
Dim s, i, c
i = in_out_Start
If i=0 Then Exit Function
'//=== Skip space character
Do
c = Mid( Line, i, 1 )
If c<>" " and c<>vbTab Then Exit Do
i = i + 1
Loop
Select Case c
'//=== If enclosed by " "
Case """"
Do
i = i + 1
c = Mid( Line, i, 1 )
If c = "" Then Exit Do
If c = """" Then
i = i + 1
c = Mid( Line, i, 1 )
If c = """" Then s = s + c Else Exit Do
Else
s = s + c
End If
Loop
MeltCSV = s
Do
If c = "" Then in_out_Start = 0 : Exit Function
If c = "," Then in_out_Start = i+1 : Exit Function
i = i + 1
c = Mid( Line, i, 1 )
Loop
'//=== If no value
Case ","
in_out_Start = i+1 : Exit Function
Case ""
in_out_Start = 0 : Exit Function
'//=== If NOT enclosed by " "
Case Else
Do
If c = "" or c = "," Then Exit Do
s = s + c
i = i + 1
c = Mid( Line, i, 1 )
Loop
MeltCSV = Trim( s )
If c = "" Then in_out_Start = 0 : Exit Function
If c = "," Then in_out_Start = i+1 : Exit Function
End Select
End Function
'********************************************************************************
' <<< [CSVText] >>>
'********************************************************************************
Function CSVText( s )
If InStr( s, """" ) = 0 and InStr( s, "," ) = 0 and InStr( s, vbCRLF ) = 0 and _
Left( s, 1 ) <> " " and Right( s, 1 ) <> " " Then CSVText = s : Exit Function
CSVText = """" + Replace( s, """", """""" ) + """"
End Function
'********************************************************************************
' <<< [XmlAttr] >>>
'********************************************************************************
Function XmlAttr( s )
XmlAttr = Replace( s, "&", "&" )
XmlAttr = Replace( XmlAttr, """", """ )
XmlAttr = Replace( XmlAttr, "<", "<" )
End Function
'********************************************************************************
' <<< [XmlText] >>>
'********************************************************************************
Function XmlText( s )
XmlText = Replace( s, "&", "&" )
XmlText = Replace( XmlText, "<", "<" )
XmlText = Replace( XmlText, ">", ">" )
End Function
'********************************************************************************
' <<< [LoadXML] >>>
'********************************************************************************
Const F_NoRoot = 1
Const F_Str = &h8000
Function LoadXML( PathOrStr, Opt )
Dim xml, r, t, i, c, f
Const start_tag = ""
Const end_tag = ""
If Opt and F_Str Then
i=1 : Do : c = Mid( PathOrStr, i, 1 ) : If c<>" " and c<>vbTab Then Exit Do
i=i+1 : Loop
If (Opt and F_NoRoot) or c<>"<" Then
t = start_tag + PathOrStr + end_tag
Else
t = PathOrStr
End If
Else
Set f = OpenForRead( PathOrStr )
t = ReadAll( f )
i=1 : Do : c = Mid( t, i, 1 ) : If c<>" " and c<>vbTab Then Exit Do
i=i+1 : Loop
If (Opt and F_NoRoot) or c<>"<" Then
t = start_tag + t + end_tag
End If
End If
Set xml = CreateObject("MSXML2.DOMDocument")
r = xml.loadXML( t )
If not r Then
t = start_tag + t + end_tag
r = xml.loadXML( t )
End If
If not r Then Raise 1,"""" + PathOrStr + """ が Unicode でないか、正しい XML 形式になっていません"
Set LoadXML = xml.lastChild '// If firstChild, may be got.
End Function
'Function LoadXML( Path, Opt )
' Dim xml, r
'
' If not g_fs.FileExists( Path ) Then Err.Raise 53,,"""" + Path + """ が見つかりません"
' Set xml = WScript.CreateObject("MSXML2.DOMDocument")
' r = xml.load( Path )
' If r=0 Then Err.Raise 53,,"""" + Path + """ が Unicode でないか、正しい XML 形式ではありません"
' Set LoadXML = xml.firstChild
'End Function
'*-------------------------------------------------------------------------*
'* ### <<<< Function call and include >>>>
'*-------------------------------------------------------------------------*
'********************************************************************************
' <<< [call_vbs] >>>
'********************************************************************************
Function call_vbs( path, func, param )
echo ">call_vbs """ & path & """, " & func
If g_debug Then
call_vbs = call_vbs_d( path, func, param )
Else
call_vbs = call_vbs_t( path, func, param )
End If
End Function
'*-------------------------------------------------------------------------*
'* ### <<<< Support of vbsool >>>>
'*-------------------------------------------------------------------------*
'********************************************************************************
' <<< [ObjToXML] >>>
'********************************************************************************
Function ObjToXML( TagName, Objs, Opt )
Dim o
Dim out
If not IsEmpty( TagName ) Then out = "<" + TagName + ">" + vbCRLF
If IsArray( Objs ) Then
For Each o In Objs : If not IsEmpty(o) Then ObjToXML1 o, out
Next
ElseIf TypeName( Objs ) = "ArrayClass" Then
For Each o In Objs.m_Array : ObjToXML1 o, out : Next
ElseIf IsObject( Objs ) Then
ObjToXML1 Objs, out
End If
If not IsEmpty( TagName ) Then out = out + "" + TagName + ">" + vbCRLF
ObjToXML = Left( out, Len( out ) - 2 )
End Function
Sub ObjToXML1( Obj, Out )
Dim en,ed
Out = Out + "<" + TypeName( Obj )
On Error Resume Next
ed = Obj.Name
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = 0 Then Out = Out + " Name=""" & XmlAttr( Obj.Name ) & """"
If en = 438 Then en = 0
If en <> 0 Then Err.Raise en,,ed
On Error Resume Next
ed = Obj.DefinePath
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = 0 Then Out = Out + " DefinePath=""" & XmlAttr( Obj.DefinePath ) & """"
If en = 438 Then en = 0
If en <> 0 Then Err.Raise en,,ed
Out = Out + "/>" + vbCRLF
End Sub
'********************************************************************************
' <<< [get_Object] >>>
'********************************************************************************
Function get_Object( Name )
Dim en,ed
On Error Resume Next
Dim get_func : Set get_func = GetRef( "get_" + Name )
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = 5 Then Err.Raise en,,ed + " : Not defined 'get_" + Name + "'"
If en <> 0 Then Err.Raise en,,ed
Set get_Object = get_func()
End Function
'********************************************************************************
' <<< [get_ObjectFromFile] >>>
'********************************************************************************
Function get_ObjectFromFile( ModulePath, Name )
Dim f
g_SrcPath = g_fs.GetAbsolutePathName( ModulePath )
If g_debug Then echo ">include """ + g_SrcPath + """"
Set f = g_fs.OpenTextFile( g_SrcPath )
If g_debug Then
ExecuteGlobal "'// " + g_SrcPath +vbCRLF+ f.ReadAll()
Else
ExecuteGlobal f.ReadAll()
End If
Dim get_func : Set get_func = GetRef( "get_" + Name )
Set get_ObjectFromFile = get_func()
End Function
'********************************************************************************
' <<< [get_NameDelegator] >>>
'********************************************************************************
Dim g_NameDic : Set g_NameDic = CreateObject( "Scripting.Dictionary" )
Function get_NameDelegator( Name, TrueName, InterfaceName )
If g_NameDic.Exists( Name +"__"+ TrueName ) Then
Set get_NameDelegator = g_NameDic.Item( Name +"__"+ TrueName +"_"+ InterfaceName )
Exit Function
End If
Set get_NameDelegator = new_X( InterfaceName + "_Delegator" ) : With get_NameDelegator
.Name = Name
.m_Delegate = TrueName '// if validated was need.
If not g_bNeedValidateDelegate Then _
Set .m_Delegate = get_Object( TrueName ) '// if validated was not need.
End With
Set g_NameDic.Item( Name +"__"+ TrueName +"_"+ InterfaceName ) = get_NameDelegator
End Function
Const F_ValidateOnlyDelegate = &h40000000
Dim g_bNeedValidateDelegate
Function NameDelegator_getTrueName( m )
If VarType( m.m_Delegate ) = vbString Then
NameDelegator_getTrueName = m.m_Delegate
Else
NameDelegator_getTrueName = m.m_Delegate.TrueName
End If
End Function
Sub NameDelegator_validate( m, Flags )
If VarType( m.m_Delegate ) = vbString Then
Set m.m_Delegate = get_Object( m.m_Delegate )
End If
If ( Flags and F_ValidateOnlyDelegate ) = 0 Then _
m.m_Delegate.Validate Flags
End Sub
Function NameDelegator_getXML( m )
If VarType( m.m_Delegate ) = vbString Then
NameDelegator_getXML = "<" + TypeName( m ) + _
" Name='" + m.Name + "' TrueName='" + m.TrueName + "'/>"
Else
NameDelegator_getXML = "<" + TypeName( m ) + _
" Name='" + m.Name + "' TrueName='" + m.TrueName + "'>" +vbCRLF+_
m.m_Delegate.xml + vbCRLF + "" + TypeName( m ) + ">"
End If
End Function
'********************************************************************************
' <<< [new_X] >>>
'********************************************************************************
Function new_X( Name )
Dim en,ed
On Error Resume Next
Dim new_f : Set new_f = GetRef( "new_" + Name )
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = 5 Then Err.Raise en,,ed + " : Not defined 'new_" + Name + "'"
If en <> 0 Then Err.Raise en,,ed
Set new_X = new_f()
End Function
'********************************************************************************
' <<< [include_objs] >>>
'********************************************************************************
Dim g_included_paths : Set g_included_paths = CreateObject( "Scripting.Dictionary" )
Sub include_objs( Wildcard, Flags, out_GetObjectFuncs )
Dim ds_:Set ds_= new CurDirStack
Dim folder_path, fname_key_s, folders, fo, f, fi, t, en, ed
Dim fname_key : Set fname_key = new StrMatchKey
If g_fs.FolderExists( Wildcard ) Then
folder_path = Wildcard : fname_key_s = "*_obj.vbs"
Else
folder_path = GetParentAbsPath( Wildcard ) : fname_key_s = g_fs.GetFileName( Wildcard )
End If
fname_key.Keyword = LCase( fname_key_s )
ReDim out_GetObjectFuncs(-1)
EnumFolderObject folder_path, folders '// [out] folders
For Each fo In folders
For Each f In fo.Files
If fname_key.IsMatch( f.Name ) Then
g_SrcPath = f.Path
If IsEmpty( g_included_paths.Item( g_SrcPath ) ) Then
If g_debug Then echo ">include """ + f.Path + """"
ExecuteGlobal "Sub get_StaticObjects(a,b) : End Sub"
Set fi = g_fs.OpenTextFile( g_SrcPath )
If g_debug Then t = "'// " + g_SrcPath +vbCRLF+ fi.ReadAll() Else t = fi.ReadAll()
fi.Close
g_sh.CurrentDirectory = fo.Path
If not IsEmpty( g_debug_vbs_path ) and _
InStr( g_SrcPath, g_debug_vbs_path ) > 0 Then
InvestigateInterpretError2 g_SrcPath, en, ed
Else
On Error Resume Next
ExecuteGlobal t '// Interpret g_SrcPath
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en <> 0 Then
InvestigateInterpretError g_SrcPath, en, ed
End If
End If
ReDim Preserve out_GetObjectFuncs( UBound( out_GetObjectFuncs ) + 1 )
Set out_GetObjectFuncs( UBound( out_GetObjectFuncs ) ) = GetRef( "get_StaticObjects" )
Set g_included_paths.Item( g_SrcPath ) = out_GetObjectFuncs( UBound( out_GetObjectFuncs ) )
Else
ReDim Preserve out_GetObjectFuncs( UBound( out_GetObjectFuncs ) + 1 )
Set out_GetObjectFuncs( UBound( out_GetObjectFuncs ) ) = g_included_paths.Item( g_SrcPath )
End If
End If
Next
Next
g_SrcPath = Empty
End Sub
'********************************************************************************
' <<< [get_ObjectsFromFile] >>>
'********************************************************************************
Sub get_ObjectsFromFile( GetObjectFuncs, InterfaceName, out_Objs )
If VarType( GetObjectFuncs ) = vbString Then
Dim create_funcs
include_objs GetObjectFuncs, Empty, create_funcs '// [out] create_funcs
get_ObjectsFromFile_sub create_funcs, InterfaceName, out_Objs
Else
get_ObjectsFromFile_sub GetObjectFuncs, InterfaceName, out_Objs
End If
End Sub
Sub get_ObjectsFromFile_sub( GetObjectFuncs, InterfaceName, out_Objs )
Dim func, objs
ReDim out_Objs(-1)
For Each func In GetObjectFuncs
objs = Empty
Call func( InterfaceName, objs ) '// [out] objs
AddArrElem out_Objs, objs
Next
End Sub
'********************************************************************************
' <<< [get_DefineInfoObject] >>>
'********************************************************************************
Class DefineInfoClass
Public FullPath
End Class
Sub get_DefineInfoObject( in_out_Object, FullPath )
If not IsEmpty( in_out_Object ) and not g_bInvestigateInterpretError Then _
Raise 1, "2nd execute(include)"
Set in_out_Object = new DefineInfoClass
in_out_Object.FullPath = FullPath
End Sub
'********************************************************************************
' <<< [InvestigateInterpretError] >>>
'********************************************************************************
Dim g_debug_vbs_path
Dim g_debug_vbs_err_num
Dim g_bInvestigateInterpretError
Sub InvestigateInterpretError( Path, en, ed )
Dim f, t
echo ""
echo ">InvestigateInterpretError """ + Path + """"
g_bInvestigateInterpretError = True
Set f = g_fs.OpenTextFile( Path ) : t = f.ReadAll() : f.Close
Dim en2, ed2
On Error Resume Next
ExecuteGlobal t
en2 = Err.Number : ed2 = Err.Description : On Error GoTo 0
If en2 = 0 Then
Err.Raise en,,""
End If
echo GetErrStr( en, ed )
'// Try to display error line
RunProg "wscript.exe """ + Path + """", ""
'// Error of Duplicate Name
If en2 = 1041 Then
Err.Raise en,,""
End If
'// Try to break at error line ([attention] 2nd execute may different behavior)
Set f = g_fs.OpenTextFile( Path ) : t = f.ReadAll() : f.Close
ExecuteGlobal "'// This is 2nd execute(include) from InvestigateInterpretError." +vbCRLF + t
'// This is no new hint
Err.Raise en,,""
End Sub
'********************************************************************************
' <<< [InvestigateInterpretError2] >>>
'********************************************************************************
Sub InvestigateInterpretError2( Path, en, ed )
Dim f, t
If g_debug_vbs_err_num = 1041 Then
Stop
InvestigateDuplicatedNameError g_SrcPath, en, ed
Stop
ElseIf g_debug_vbs_err_num = -1041 Then
Stop ' This is 1st include. Next is ...
g_debug_vbs_err_num = 1041
Set f = g_fs.OpenTextFile( Path ) : t = f.ReadAll() : f.Close
ExecuteGlobal t '// Interpret g_SrcPath
Else
Stop
Set f = g_fs.OpenTextFile( Path ) : t = f.ReadAll() : f.Close
ExecuteGlobal t '// Interpret g_SrcPath
End If
End Sub
'********************************************************************************
' <<< [InvestigateDuplicatedNameError] >>>
'********************************************************************************
Sub InvestigateDuplicatedNameError( Path, en, ed )
Dim f, t, i, j, c
Set f = g_fs.OpenTextFile( Path )
Do Until f.AtEndOfStream
t = f.ReadLine()
i = InStr( t, "Class" )
If i = 0 Then i = InStr( t, "Dim" )
If i > 0 Then
i=i+1
Do
If Mid(t,i,1)=" " Then Exit Do
i=i+1
Loop
Do
If Mid(t,i,1)<>" " Then Exit Do
i=i+1
Loop
j=i
Do
c = Mid(t,j,1)
If not( (c>="A" and c<="Z") or (c>="a" and c<="z") or (c>="0" and c<="9") or c="_" ) Then _
Exit Do
j=j+1
Loop
If j > i Then
If InStr( t, "Class" ) > 0 Then
c = "Class " + Mid( t, i, j-i ) + " : End Class"
Else
c = "Dim " + Mid( t, i, j-i )
End If
echo ">ExecuteGlobal """ + c + """"
ExecuteGlobal c
End If
End If
Loop
f.Close
Err.Raise en,,""
End Sub
'*-------------------------------------------------------------------------*
'* ### <<<< Process >>>>
'*-------------------------------------------------------------------------*
'********************************************************************************
' <<< [env] Expand environment strings >>>
'********************************************************************************
Function env( s )
If IsEmpty( s ) Then Exit Function '// for avoid to s=""
Dim p1, p2, symbol, value
Dim i : i = 1
Do
p1 = InStr( i, s, "%" )
If p1 = 0 Then
env = env & Mid( s, i )
Exit Function
Else
env = env & Mid( s, i, p1 - i )
p2 = InStr( p1+1, s, "%" )
If p2 = p1+1 Then
env = env & "%"
Else
symbol = Mid( s, p1+1, p2-p1-1 )
value = GetVar( symbol )
If IsEmpty( value ) Then _
Err.Raise E_NotFoundSymbol,, ""
env = env & value
End If
i = p2 + 1
End If
Loop
End Function
'********************************************************************************
' <<< [start] >>>
'********************************************************************************
Sub start( cmdline )
echo ">start " & cmdline
cmdline = g_sh.ExpandEnvironmentStrings( cmdline )
Dim en,ed
On Error Resume Next
g_sh.Run cmdline,, FALSE
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = E_WIN32_FILE_NOT_FOUND Then _
Err.Raise en,,"ファイルかフォルダが見つかりません : " + cmdline
If en <> 0 Then Err.Raise en,,ed
End Sub
'********************************************************************************
' <<< [RunProg] >>>
'********************************************************************************
Function RunProg( ByVal cmdline, stdout_stderr_redirect )
Dim dbg_cmd
'// Set debug mode
If stdout_stderr_redirect = "_debug" Then
dbg_cmd = "cmd /K " : stdout_stderr_redirect = ""
Else
dbg_cmd = ""
End If
'// Echo command line
echo ">current dir = """ & g_sh.CurrentDirectory & """"
If stdout_stderr_redirect = "" Then
echo ">RunProg " & cmdline
Else
echo ">RunProg " & cmdline+" >> """+stdout_stderr_redirect+""""
End If
'// env
cmdline = g_sh.ExpandEnvironmentStrings( cmdline )
'// avoid to stop by StdIn
if ( Left( cmdline, 7 ) = "cscript" ) Then _
cmdline = cmdline + " /GUI_input:1"
'// Create new process
Dim ex
Set ex = g_sh.Exec( cmdline )
stdout_stderr_redirect = g_sh.ExpandEnvironmentStrings( stdout_stderr_redirect )
RunProg = WaitForFinishAndRedirect( ex, stdout_stderr_redirect )
echo ""
End Function
'********************************************************************************
' <<< [WaitForFinishAndRedirect] >>>
'http://itpro.nikkeibp.co.jp/article/COLUMN/20080805/312155/?ST=develop&P=2
'********************************************************************************
Function WaitForFinishAndRedirect( ex, path )
Dim f
Dim head
If g_debug and IsEmpty( g_ChildHead ) Then g_ChildHead = ">|"
If path <> "" and path <> "nul" Then
Dim ec : Set ec = new EchoOff
Set f = OpenForWrite( path, F_Append )
ec = Empty
End If
Do While ex.Status = 0
If path = "nul" or IsEmpty( path ) Then
Do Until ex.StdOut.AtEndOfStream : ex.StdOut.ReadLine : Loop
Do Until ex.StdErr.AtEndOfStream : ex.StdErr.ReadLine : Loop
ElseIf path = "" Then
EchoStream ex.StdOut, WScript.StdOut, ex, g_ChildHead
EchoStream ex.StdErr, WScript.StdErr, ex, g_ChildHead
Else
Do Until ex.StdOut.AtEndOfStream : f.WriteLine ex.StdOut.ReadLine : Loop
Do Until ex.StdErr.AtEndOfStream : f.WriteLine ex.StdErr.ReadLine : Loop
End If
Loop
If path = "nul" or IsEmpty( path ) Then
Do Until ex.StdOut.AtEndOfStream : ex.StdOut.ReadLine : Loop
Do Until ex.StdErr.AtEndOfStream : ex.StdErr.ReadLine : Loop
ElseIf path = "" Then
EchoStream ex.StdOut, WScript.StdOut, ex, g_ChildHead
EchoStream ex.StdErr, WScript.StdErr, ex, g_ChildHead
Else
Do Until ex.StdOut.AtEndOfStream : f.WriteLine ex.StdOut.ReadLine : Loop
Do Until ex.StdErr.AtEndOfStream : f.WriteLine ex.StdErr.ReadLine : Loop
End If
WaitForFinishAndRedirect = ex.ExitCode
End Function
'********************************************************************************
' <<< [EchoStream] echo supported No vbCRLF >>>
'********************************************************************************
Dim g_EchoStreamBuf
Sub EchoStream( StreamIn, StreamOut, ex, Prompt )
Dim c, b, i
Do Until StreamIn.AtEndOfStream
c = StreamIn.Read(1)
If c <> vbCR and c <> vbLF Then
If g_EchoStreamBuf = "" Then StreamOut.Write Prompt
g_EchoStreamBuf = g_EchoStreamBuf + c
End If
'// pause のみ対応
If Left( g_EchoStreamBuf, 6 ) = "続行するには" Then
i = 0
If g_EchoStreamBuf="続行するには何かキーを押してください . . . " Then i = 1
If g_EchoStreamBuf=Left(g_PauseMsg,g_PauseMsgStone)+"*"+Chr(8) Then i = 3
If g_EchoStreamBuf=g_PauseMsg Then i = 2
If i > 0 Then
StreamOut.Write c
If ex.Status = 0 Then
If i < 3 Then
WScript.StdIn.ReadLine '// Waiting Enter from only main process
If i = 1 Then
ex.StdIn.Write vbCR
StreamIn.ReadLine
Else
ex.StdIn.Write vbCRLF
End If
End If
End If
If not IsEmpty( g_Test ) Then g_Test.WriteLogLine g_EchoStreamBuf
g_EchoStreamBuf = ""
c = ""
End If
End If
'// echo
If c = vbLF Then
StreamOut.Write vbLF
If not IsEmpty( g_Test ) Then g_Test.WriteLogLine g_EchoStreamBuf
g_EchoStreamBuf = ""
Else
StreamOut.Write c
End If
Loop
End Sub
'********************************************************************************
' <<< [ArgumentExist] >>>
'********************************************************************************
Function ArgumentExist( name )
Dim key
For Each key in WScript.Arguments.Named
If key = name Then ArgumentExist = True : Exit Function
Next
ArgumentExist = False
End Function
'********************************************************************************
' <<< [GetSearchOpenCmdLine] >>>
'********************************************************************************
Function GetSearchOpenCmdLine( PathAndName )
Dim cmd
Dim path, name
Dim i_sep, i_sharp, i_kakko, name_type, line_num
Const no_name_type = 0, line_type = 2, str_type = 3
'//=== Get path and name
i_sep = InStrRev( PathAndName, "\" )
i_sharp = InStrRev( PathAndName, "#" )
If i_sep >= i_sharp Then '// NoName = (7,5), (0,0), (7,0)
path = PathAndName : name = Empty
Else '// WithName = (5,7), (0,7)
path = Left( PathAndName, i_sharp - 1 )
name = Mid( PathAndName, i_sharp + 1 )
End If
'//=== Get line number
If IsEmpty( name ) and Right( PathAndName, 1 ) = ")" Then
i_kakko = InStrRev( PathAndName, "(" )
line_num = Mid( PathAndName, i_kakko + 1 )
line_num = CInt( Left( line_num, Len( line_num ) - 1 ) )
'// not use TagJumpPath
path = Left( PathAndName, i_kakko - 1 )
End If
'//=== Check path
path = GetAbsPath( path, Empty )
If not g_fs.FileExists( path ) Then _
Raise E_FileNotExist, ""
'//=== Get command line template
If not IsDefined( "Setting_getEditorCmdLine" ) Then
cmd = """C:\Windows\notepad.exe"" ""%1"""
Else
cmd = Setting_getEditorCmdLine( 3 )
name_type = str_type
If InStr( cmd, "%2" ) = 0 Then cmd = Empty
If IsEmpty( cmd ) and ( not IsEmpty( line_num ) or not IsEmpty( name ) ) Then
cmd = Setting_getEditorCmdLine( 2 )
name_type = line_type
End If
If IsEmpty( cmd ) Then
cmd = Setting_getEditorCmdLine( 1 )
name_type = no_name_type
End If
If IsEmpty( cmd ) Then
cmd = Setting_getEditorCmdLine( 0 )
cmd = """" + cmd + """ ""%1"""
End If
If IsEmpty( cmd ) Then
cmd = """C:\Windows\notepad.exe"" ""%1"""
End If
End If
'//=== Replace command line
Select Case name_type
Case str_type : cmd = Replace( cmd, "%2", name )
Case line_type
If IsEmpty( line_num ) Then line_num = GetLineOfSearchOpen( path, name )
cmd = Replace( cmd, "%d", CStr( line_num ) )
End Select
GetSearchOpenCmdLine = Replace( cmd, "%1", path )
End Function
Function GetLineOfSearchOpen( Path, Name )
Dim f, line, i
Set f = OpenForRead( Path )
i = 1
Do Until f.AtEndOfStream
line = f.ReadLine()
If InStr( line, Name ) > 0 Then
GetLineOfSearchOpen = i
Exit Function
End If
i = i + 1
Loop
f = Empty
GetLineOfSearchOpen = 1
End Function
'********************************************************************************
' <<< [GetDiffCmdLine] >>>
'********************************************************************************
Function GetDiffCmdLine( PathA, PathB )
If not IsDefined( "Setting_getDiffCmdLine" ) Then
echo "Diff """ + PathA + """ """ + PathB + """"
Else
Dim cmd
cmd = Setting_getDiffCmdLine( 2 )
cmd = Replace( cmd, "%1", GetTagJumpPath( PathA ) )
cmd = Replace( cmd, "%2", GetTagJumpPath( PathB ) )
GetDiffCmdLine = cmd
End If
End Function
'********************************************************************************
' <<< [GetDiffCmdLine3] >>>
'********************************************************************************
Function GetDiffCmdLine3( PathA, PathB, PathC )
If not IsDefined( "Setting_getDiffCmdLine" ) Then
echo "Diff """ + PathA + """ """ + PathB + """"
Else
Dim cmd
cmd = Setting_getDiffCmdLine( 3 )
cmd = Replace( cmd, "%1", GetTagJumpPath( PathA ) )
cmd = Replace( cmd, "%2", GetTagJumpPath( PathB ) )
cmd = Replace( cmd, "%3", GetTagJumpPath( PathC ) )
GetDiffCmdLine3 = cmd
End If
End Function
'********************************************************************************
' <<< [GetDiffCmdLineMulti] >>>
'********************************************************************************
Function GetDiffCmdLineMulti( Files )
Dim op, cmd, i
echo "--------------------------------------------------------"
For i=0 To UBound( Files )
echo (i+1) & ". " & Files(i)(0)
Next
op = CInt2( input( "Select number>" ) ) - 1
echo "--------------------------------------------------------"
Select Case UBound( Files(op)(1) )
Case 1: '// 2 files
GetDiffCmdLineMulti = GetDiffCmdLine( _
GetAbsPath( Files(op)(1)(0) +"\"+ Files(op)(0), Empty ), _
GetAbsPath( Files(op)(1)(1) +"\"+ Files(op)(0), Empty ) )
Case 2: '// 3 files
GetDiffCmdLineMulti = GetDiffCmdLine3( _
GetAbsPath( Files(op)(1)(0) +"\"+ Files(op)(0), Empty ), _
GetAbsPath( Files(op)(1)(1) +"\"+ Files(op)(0), Empty ), _
GetAbsPath( Files(op)(1)(2) +"\"+ Files(op)(0), Empty ) )
Case Else
Error
End Select
End Function
'*-------------------------------------------------------------------------*
'* ### <<<< Wait >>>>
'*-------------------------------------------------------------------------*
'********************************************************************************
' <<< [Sleep] >>>
'********************************************************************************
Sub Sleep( ByVal msec )
echo ">Sleep " & msec
WScript.Sleep msec
End Sub
'********************************************************************************
' <<< [WaitForFile] Wait for make the file >>>
'********************************************************************************
Function WaitForFile( Path )
echo ">WaitForFile " & Path
Dim f,en,ed
'//=== Wait for file exists
f = 0
While g_fs.FileExists( Path ) = False
WScript.Sleep 1000
f=f+1 : If f=3 Then WScript.Echo ">WaitForFile " & Path & " ..."
Wend
'//=== Open file supported lock
Do
On Error Resume Next
Set f = g_fs.OpenTextFile( Path )
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en <> E_WriteAccessDenied Then
If en <> 0 Then Err.Raise en,,ed
Exit Do
End If
Loop
'//=== Read file supported lock
Do
On Error Resume Next
WaitForFile = f.ReadLine
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en <> E_EndOfFile Then
If en <> 0 Then Err.Raise en,,ed
Exit Do
End If
Loop
f = Empty
'//=== Delete file
del Path
While g_fs.FileExists( Path )
WScript.Sleep 200 '// Delete may have delay ?
WEnd
End Function
'*-------------------------------------------------------------------------*
'* ### <<<< Sound >>>>
'*-------------------------------------------------------------------------*
'********************************************************************************
' <<< [Play] >>>
'********************************************************************************
Sub Play( Path )
Player_validate '// g_Player
With g_Player.m_Obj
.URL = Path
'// .PreviewMode = True '// Cannot play movie because WSH does not have window.
.Controls.Play
End With
End Sub
'********************************************************************************
' <<< [SystemSound] >>>
'********************************************************************************
Sub SystemSound( Sound )
Const base = "HKEY_CURRENT_USER\AppEvents\Schemes\Apps\"
Const current = "\.Current\"
Const E_PathNotFound = &h80070002
Dim en,ed, parent, reg_path, file_path
For Each parent In Array( ".Default", "Explorer", "devenv", "dexplore", "sapisvr" )
reg_path = base + parent +"\"+ Sound + current
On Error Resume Next
file_path = env( g_sh.RegRead( reg_path ) )
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = 0 Then Exit For
If en <> E_PathNotFound Then Err.Raise en,,ed
Next
If file_path <> "" and file_path <> reg_path Then Play file_path
End Sub
'********************************************************************************
' <<< [WaitForSound] >>>
'********************************************************************************
Sub WaitForSound( Timeout_msec )
Player_validate '// g_Player
Dim i : i = CInt( Timeout_msec / 250 )
If IsEmpty( Timeout_msec ) Then i=9
For i=i To 1 Step -1
If g_Player.m_Obj.PlayState = 1 Then Exit For
If g_Player.m_Obj.PlayState = 10 Then Raise E_PathNotFound, _
""
WScript.Sleep 250
If IsEmpty( Timeout_msec ) Then i=9
Next
g_Player.m_Obj.Controls.Stop
End Sub
'********************************************************************************
' <<< [SetVolume] >>>
'********************************************************************************
Sub SetVolume( Volume )
Player_validate '// g_Player
g_Player.m_Obj.Settings.Volume = Volume
End Sub
'********************************************************************************
' <<< [Player_validate] >>>
'********************************************************************************
Sub Player_validate()
If IsEmpty( g_Player ) Then Set g_Player = new Vbslib_Player
End Sub
Class Vbslib_Player
Public m_Obj
Private Sub Class_Initialize()
Set m_Obj = CreateObject( "WMPlayer.OCX" )
m_Obj.Settings.Volume = 100
End Sub
Private Sub Class_Terminate()
Dim i
For i=1 To 12 '// 12 = 3second for sound effects. Music will stop.
If m_Obj.PlayState = 1 or m_Obj.PlayState = 10 Then Exit For
WScript.Sleep 250
Next
End Sub
End Class
'*-------------------------------------------------------------------------*
'* ### <<<< Variable, Array and collection >>>>
'*-------------------------------------------------------------------------*
'********************************************************************************
' <<< [DicItem] >>>
'********************************************************************************
Function DicItem( Dic, Key )
If not Dic.Exists( Key ) Then Exit Function
If IsObject( Dic.Item( Key ) ) Then Set DicItem = Dic.Item( Key ) Else DicItem = Dic.Item( Key )
End Function
'********************************************************************************
' <<< [DicToArr] >>>
'********************************************************************************
Sub DicToArr( Dic, Arr )
Dim keys : keys = Dic.Keys()
Dim key, i
ReDim Arr( UBound( keys ) )
i = 0
For Each key in keys
Set Arr(i) = new DicElem : ErrCheck
Arr(i).m_Key = key
If IsObject( Dic.Item(key) ) Then
Set Arr(i).m_Item = Dic.Item(key)
Else
Arr(i).m_Item = Dic.Item(key)
End If
i=i+1
Next
End Sub
Class DicElem
Public m_Key
Public m_Item
End Class
'********************************************************************************
' <<< [DicKeyToArr] >>>
'********************************************************************************
Sub DicKeyToArr( Dic, Arr )
Dim keys : keys = Dic.Keys()
Dim key, i
ReDim Arr( UBound( keys ) )
i = 0
For Each key in keys
Arr(i) = key
i=i+1
Next
End Sub
'********************************************************************************
' <<< [DicItemToArr] >>>
'********************************************************************************
Sub DicItemToArr( Dic, Arr )
Dim keys : keys = Dic.Keys()
Dim key, i
ReDim Arr( UBound( keys ) )
i = 0
For Each key in keys
If IsObject( Dic.Item(key) ) Then
Set Arr(i) = Dic.Item(key)
Else
Arr(i) = dic.Item(key)
End If
i=i+1
Next
End Sub
'********************************************************************************
' <<< [CopyArr] >>>
'********************************************************************************
Sub CopyArr( Dst, Src )
If g_cut_old Then Stop ' Do not Dim a(). Dim a,b : b = Array( 1, 2 ) : a = b
If IsArray( Src ) Then
Dim i
ReDim Dst( UBound( Src ) )
For i=UBound( Src ) To 0 Step -1
If IsObject( Src(i) ) Then Set Dst(i) = Src(i) Else Dst(i) = Src(i)
Next
Else
ReDim Dst(0)
If IsObject( Src ) Then Set Dst(0) = Src Else Dst(0) = Src
End If
End Sub
'********************************************************************************
' <<< [AddArrElem] >>>
'********************************************************************************
Sub AddArrElem( Dst, Src )
If TypeName( Dst ) = "Dictionary" Then
Dim key, obj
If IsArray( Src ) Then
For Each obj In Src : If not IsEmpty( obj ) Then
If IsObject( obj ) Then Set Dst.Item( obj.Name ) = obj Else Dst.Item( obj ) = True
End If : Next
ElseIf TypeName( Src ) = "Dictionary" Then
For Each key In Src.Keys()
If IsObject( Src.Item( key ) ) Then
Set Dst.Item( key ) = Src.Item( key )
Else
Dst.Item( key ) = Src.Item( key )
End If
Next
Else
If IsObject( Src ) Then Set Dst.Item( Src.Name ) = Src Else Dst.Item( Src.Name ) = True
End If
Else
Dim i, n
n = UBound( Dst ) + 1
If IsArray( Src ) Then
ReDim Preserve Dst( n + UBound( Src ) )
For i=UBound( Src ) To 0 Step -1
If IsObject( Src(i) ) Then Set Dst(n+i) = Src(i) Else Dst(n+i) = Src(i)
Next
ElseIf not IsEmpty( Src ) Then
ReDim Preserve Dst( n )
If IsObject( Src ) Then Set Dst(n) = Src Else Dst(n) = Src
End IF
End IF
End Sub
'********************************************************************************
' <<< [IsSameArray] >>>
'********************************************************************************
Function IsSameArray( Arr1, Arr2 )
Dim i, low, up
If IsEmpty( Arr1 ) <> IsEmpty( Arr2 ) Then IsSameArray = False : Exit Function
If IsEmpty( Arr1 ) Then IsSameArray = True : Exit Function
If IsArray( Arr1 ) Then
If IsArray( Arr2 ) Then
If UBound( Arr1 ) <> UBound( Arr2 ) Then IsSameArray = False : Exit Function
Else
If UBound( Arr1 ) <> UBound( Arr2.m_Array ) Then IsSameArray = False : Exit Function
End If
low = LBound( Arr1 ) : up = UBound( Arr1 )
Else
If IsArray( Arr2 ) Then
If UBound( Arr1.m_Array ) <> UBound( Arr2 ) Then IsSameArray = False : Exit Function
Else
If UBound( Arr1.m_Array ) <> UBound( Arr2.m_Array ) Then IsSameArray = False : Exit Function
End If
low = 0 : up = UBound( Arr1.m_Array )
End If
For i = low To up
If Arr1(i) <> Arr2(i) Then IsSameArray = False : Exit Function
Next
IsSameArray = True
End Function
'********************************************************************************
' <<< [QuickSort_fromDic] >>>
'dic as Scripting.Dictionary
'out_arr as [out] object array
'********************************************************************************
Sub QuickSort_fromDic( dic, out_arr, compare_func, param )
Dim i, i_last, elem
i_last = dic.Count - 1
Redim out_arr( i_last )
i=0
For Each elem In dic.Items
Set out_arr(i) = elem
i = i + 1
Next
QuickSort out_arr, 0, i_last, compare_func, param
End Sub
'********************************************************************************
' <<< [QuickSort] >>>
'********************************************************************************
Sub QuickSort( arr, i_left, i_right, compare_func, param )
Dim pivot, i_pivot, i_big_eq, i_small, sw, n_min_count
If i_left >= i_right Then Exit Sub ' rule-b'
i_pivot = ( i_left + i_right ) \ 2
Set pivot = arr( i_pivot )
'//== for debug
' Const watch_sort_id = 6 '//**********************************
' Dim sort_debug_id, sort_debug_id2
' g_SortDebugID = g_SortDebugID + 1
' sort_debug_id = g_SortDebugID
' Dim i, sym, value
' echo "QuickSort start (" & sort_debug_id & ") ----------------------"
' For i = i_left To i_right
' QuickSort_Debug_getSym arr, i, sym, value
' If i = i_pivot Then value = value & " (pivot)"
' echo "(" & i & ") " & sym & " = " & value
' Next
' If sort_debug_id = watch_sort_id Then Stop
'//=== Split to [ arr(i_left) ][ smaller than ][ arr(i_pivot) ][ greater equal ][ arr(i_right) ]
i_big_eq = i_left : i_small = i_right
Do
'// Plus i_big_eq. Result is that ( *i_big_eq >= *i_pivot ).
Do
If compare_func( arr(i_big_eq), pivot, param ) >= 0 Then Exit Do
i_big_eq = i_big_eq + 1
Loop
'// Minus i_small. Result is that ( *i_pivot > *i_small ).
Do
If i_small < i_left Then Exit Do
If compare_func( arr(i_small), pivot, param ) < 0 Then Exit Do
i_small = i_small - 1
Loop
'//== for debug
' If sort_debug_id = watch_sort_id Then
' sort_debug_id2 = sort_debug_id2 + 1
' echo "QuickSort swap (" & sort_debug_id & "-" & sort_debug_id2 & ")-----------------"
' For i = i_left To i_right
' QuickSort_Debug_getSym arr, i, sym, value
' If i = i_small Then value = value & " (i_small)"
' If i = i_big_eq Then value = value & " (i_big_eq)"
' If i = i_pivot Then value = value & " (i_pivot)"
' echo "(" & i & ") " & sym & " = " & value
' Next
' End If
'// Splitted
If i_small < i_big_eq Then
If i_left <= i_small Then
Exit Do
'// If *i_pivot is minimum Then (4) collect minimuns at left
Else
Set sw = arr(i_left) : Set arr(i_left) = arr(i_pivot) : Set arr(i_pivot) = sw
i_big_eq = i_big_eq + 1
n_min_count = n_min_count + 1
i_small = i_right '// i_small is iterater to same value as minimum
Do
If i_big_eq >= i_small Then Exit Do
'// while ( *i_big_eq == *i_left ) i_big_eq++
If compare_func( arr(i_big_eq), pivot, param ) = 0 Then
i_big_eq = i_big_eq + 1
n_min_count = n_min_count + 1
'// Swap *i_big_eq and *i_small
Else
Do
If i_small <= i_big_eq Then Exit Do
If compare_func( arr(i_small), pivot, param ) = 0 Then
Set sw = arr(i_small) : Set arr(i_small) = arr(i_big_eq) : Set arr(i_big_eq) = sw
Exit Do
End If
i_small = i_small - 1
Loop
If i_small <= i_big_eq Then Exit Do
End If
Loop
Exit Do
End If
'// If i_big_eq < i_pivot < i_small Then (1) Swap *i_big_eq and *i_small
ElseIf i_big_eq < i_pivot and i_pivot < i_small Then
Set sw = arr(i_big_eq) : Set arr(i_big_eq) = arr(i_small) : Set arr(i_small) = sw
i_big_eq = i_big_eq + 1 : i_small = i_small - 1
'// If i_big_eq = i_pivot < i_small Then (2A) Rotate3 *i_small -> *i_pivot -> *(i_pivot+1); i_pivot++
ElseIf i_big_eq = i_pivot and i_pivot < i_small Then
If i_pivot + 1 < i_small Then
Set sw = arr(i_pivot+1) : Set arr(i_pivot+1) = arr(i_pivot)
Set arr(i_pivot) = arr(i_small) : Set arr(i_small) = sw
i_big_eq = i_big_eq + 1 : i_pivot = i_pivot + 1
'// If i_big_eq = i_pivot and i_pivot+1 = i_small Then (2B) Swap *i_big_eq and *i_small
'// (If rotate3, The result is Not swaped)
Else
Set sw = arr(i_big_eq) : Set arr(i_big_eq) = arr(i_small) : Set arr(i_small) = sw
i_big_eq = i_big_eq + 1
Exit Do
End If
'// If i_big_eq < i_small < i_pivot Then (3) Rotate3 *i_small -> *i_big_eq -> *i_pivot; i_pivot--
ElseIf i_big_eq < i_small and i_small < i_pivot Then
Set sw = arr(i_pivot) : Set arr(i_pivot) = arr(i_big_eq)
Set arr(i_big_eq) = arr(i_small) : Set arr(i_small) = sw
i_big_eq = i_big_eq + 1 : i_small = i_small - 1 : i_pivot = i_pivot - 1
Else
Stop
End If
Loop
'//== for debug
' echo "QuickSort middle (" & sort_debug_id & ") ----------------------"
' For i = i_left To i_right
' QuickSort_Debug_getSym arr, i, sym, value
' If i = i_big_eq-1 Then value = value & " (i_big_eq-1)"
' If i = i_big_eq Then value = value & " (i_big_eq)"
' echo "(" & i & ") " & sym & " = " & value
' Next
' If sort_debug_id = watch_sort_id Then Stop
QuickSort arr, (i_left + n_min_count), i_big_eq-1, compare_func, param ' rule-b
QuickSort arr, i_big_eq, i_right, compare_func, param ' rule-b
'//== for debug
' echo "QuickSort end (" & sort_debug_id & ")----------------------"
' For i = i_left To i_right
' QuickSort_Debug_getSym arr, i, sym, value
' echo "(" & i & ") " & sym & " = " & value
' Next
'If g_debug Then
' For i_small = i_left To i_right - 1
' If compare_func( arr(i_small), arr(i_small + 1), param ) > 0 Then Error
' Next
'End If
End Sub
'//== for debug
'Dim g_SortDebugID
'Sub QuickSort_Debug_getSym( Arr, Index, out_Symbol, out_Value )
' out_Symbol = Index
' out_Value = Arr(Index).id
'End Sub
'********************************************************************************
' <<< [ShakerSort_fromDic] >>>
'dic as Scripting.Dictionary
'out_arr as [out] object array
'********************************************************************************
Sub ShakerSort_fromDic( dic, out_arr, sign, compare_func, param )
Dim i, i_last, elem
i_last = dic.Count - 1
Redim out_arr( i_last )
If sign >= 0 Then
i=0
For Each elem In dic.Items
Set out_arr(i) = elem
i = i + 1
Next
Else
i=i_last
For Each elem In dic.Items
Set out_arr(i) = elem
i = i - 1
Next
End If
ShakerSort out_arr, 0, i_last, compare_func, param
End Sub
'********************************************************************************
' <<< [ShakerSort] >>>
'********************************************************************************
Sub ShakerSort( arr, ByVal i_left, ByVal i_right, compare_func, param )
Dim i_swap, i, sw
Do
i_swap = i_left+1
For i=i_left+1 To i_right
If compare_func( arr(i-1), arr(i), param ) > 0 Then
Set sw = arr(i-1) : Set arr(i-1) = arr(i) : Set arr(i) = sw
i_swap = i
End If
Next
If i_swap = i_left+1 Then Exit Do
i_right = i_swap-1
i_swap = i_right-1
For i=i_right-1 To i_left Step -1
If compare_func( arr(i), arr(i+1), param ) > 0 Then
Set sw = arr(i) : Set arr(i) = arr(i+1) : Set arr(i+1) = sw
i_swap = i
End If
Next
If i_swap = i_right-1 Then Exit Do
i_left = i_swap+1
Loop
End Sub
'********************************************************************************
' <<< [CInt2] >>>
' - no exception
'********************************************************************************
Function CInt2( v )
Dim en, ed
On Error Resume Next
CInt2 = CInt( v )
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = 13 Then '// if sym is not number
CInt2 = 0
ElseIf en <> 0 Then Err.Raise en,,ed End If
End Function
'********************************************************************************
' <<< [MeltQuot] >>>
'********************************************************************************
Function MeltQuot( Line, in_out_Start )
Dim i, j, c
'//=== Skip to "
i = in_out_Start
Do
c = Mid( Line, i, 1 )
If c = "" Then in_out_Start = 0 : Exit Function
If c = """" Then Exit Do
i = i + 1
Loop
j = i + 1
'//=== Search the end of "
i = j
Do
c = Mid( Line, i, 1 )
If c = "" Then in_out_Start = 0 : Exit Do
If c = """" Then in_out_Start = i + 1 : Exit Do
i = i + 1
Loop
'//=== Get the string
MeltQuot = Mid( Line, j, i - j )
End Function
'********************************************************************************
' <<< [CreateGuid] >>>
'********************************************************************************
Dim g_TypeLib
Function CreateGuid()
If g_TestModeFlags and F_NotRandom Then
g_TypeLib = g_TypeLib + 1
CreateGuid = "00000000-0000-0000-0000-" & Right( "000000000000" & g_TypeLib, 12 )
Else
If IsEmpty( g_TypeLib ) Then Set g_TypeLib = CreateObject("Scriptlet.TypeLib")
CreateGuid = Mid( g_TypeLib.Guid, 2, 36 )
End IF
End Function
'********************************************************************************
' <<< [ReplaceTextFile] >>>
'********************************************************************************
Class ReplaceItem
Public Src
Public Dst
End Class
Sub new_ReplaceItem( objs, n )
Dim i:ReDim objs(n-1):For i=0 To n-1:Set objs(i)=new ReplaceItem :Next : ErrCheck
End Sub
Sub ReplaceTextFile( SrcPath, TmpDstPath, bDstWillBeExist, ReplaceList, Opt )
echo ">ReplaceTextFile """ & SrcPath & """, """ & TmpDstPath & """, " & bDstWillBeExist
Dim rep, item, line
Set rep = StartReplace( SrcPath, TmpDstPath, bDstWillBeExist )
Do Until rep.r.AtEndOfStream
line = rep.r.ReadLine
For Each item In ReplaceList
line = Replace( line, item.Src, item.Dst )
Next
rep.w.WriteLine line
Loop
rep.Finish
End Sub
'********************************************************************************
' <<< [StartReplace] >>>
'********************************************************************************
Function StartReplace( SrcPath, TmpDstPath, bDstWillBeExist )
echo ">StartReplace """ & SrcPath & """, """ & TmpDstPath & """, " & bDstWillBeExist
Dim ec : Set ec = new EchoOff : ErrCheck
Dim m : Set m = new StartReplaceObj : ErrCheck
m.Init1 SrcPath, TmpDstPath, bDstWillBeExist
Set StartReplace = m
End Function
'********************************************************************************
' <<< [StartReplace2] >>>
'********************************************************************************
Function StartReplace2( SrcPath, MidPath, Flags, TmpDstPath, bDstWillBeExist )
echo ">StartReplace2 """ & SrcPath & """, """ & MidPath & """, """ & TmpDstPath & """, " & bDstWillBeExist
Dim ec : Set ec = new EchoOff : ErrCheck
Dim m : Set m = new StartReplaceObj : ErrCheck
m.Init2 SrcPath, MidPath, Flags, TmpDstPath, bDstWillBeExist
Set StartReplace2 = m
End Function
Dim F_Txt2BinTxt : F_Txt2BinTxt = 2
Class StartReplaceObj
Public m_SrcPath ' as string
Public m_TmpDstPath ' as string
Public m_bDstWillBeExist ' as boolean
Public m_MidPath ' as string
Public m_Flags ' as bitfield
Public r ' as TextStream of m_SrcPath
Public w ' as TextStream of m_TmpDstPath
Private m_bFinished
Public Sub Init1( SrcPath, TmpDstPath, bDstWillBeExist )
Dim en,ed
Dim ec : Set ec = new EchoOff : ErrCheck
m_SrcPath = SrcPath
m_TmpDstPath = TmpDstPath
m_bDstWillBeExist = bDstWillBeExist
mkdir g_fs.GetParentFolderName( g_fs.GetAbsolutePathName( m_TmpDstPath ) )
Set Me.r = OpenForRead( m_SrcPath )
On Error Resume Next
Set Me.w = g_fs.CreateTextFile( m_TmpDstPath, bDstWillBeExist, (g_TextFileConvertFormat = F_Unicode) )
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = E_AlreadyExist Then Err.Raise en,, "既に同名のファイルが存在しています。: " + m_TmpDstPath
If en <> 0 Then Err.Raise en,,ed
End Sub
Public Sub Init2( SrcPath, MidPath, Flags, TmpDstPath, bDstWillBeExist )
Init1 SrcPath, MidPath, bDstWillBeExist
m_MidPath = MidPath
m_TmpDstPath = TmpDstPath
m_Flags = Flags or 1
End Sub
Public Sub Finish()
Dim ec : Set ec = new EchoOff : ErrCheck
Me.r = Empty
Me.w = Empty
If not IsEmpty( m_MidPath ) Then
If m_Flags and F_Txt2BinTxt Then
Txt2BinTxt m_MidPath, m_TmpDstPath
Else
copy m_MidPath, m_TmpDstPath
End If
del m_MidPath
End If
If not m_bDstWillBeExist Then
copy m_TmpDstPath, m_SrcPath
del m_TmpDstPath
End If
m_bFinished = True
End Sub
Public Sub ExitFinish( Opt )
m_bFinished = True
Class_Terminate
If not IsEmpty( m_MidPath ) Then del m_MidPath
del m_TmpDstPath
End Sub
Private Sub Class_Terminate()
Dim en,ed : en = Err.Number : ed = Err.Description
On Error Resume Next ' This clears the error
Me.r = Empty
Me.w = Empty
If en <> 0 and en <> 21 Then del m_TmpDstPath
ErrorCheckInTerminate
If en = 0 and not m_bFinished Then NotCallFinish
On Error GoTo 0 : If en <> 0 Then Err.Raise en,,ed
End Sub
End Class
'********************************************************************************
' <<< [TextFileCreateFormat] >>>
'********************************************************************************
Dim g_TextFileCreateFormat
Class TextFileCreateFormat
Public m_Prev
Private Sub Class_Initialize() : m_Prev = g_TextFileCreateFormat : End Sub
Public Sub Set_( Format ) : g_TextFileCreateFormat = Format : End Sub
Private Sub Class_Terminate : g_TextFileCreateFormat = m_Prev : End Sub
End Class
'********************************************************************************
' <<< [TextFileConvertFormat] >>>
'********************************************************************************
Dim g_TextFileConvertFormat
Class TextFileConvertFormat
Public m_Prev
Private Sub Class_Initialize() : m_Prev = g_TextFileConvertFormat : End Sub
Public Sub Set_( Format ) : g_TextFileConvertFormat = Format : End Sub
Private Sub Class_Terminate : g_TextFileConvertFormat = m_Prev : End Sub
End Class
'-------------------------------------------------------------------------
' ### <<<< [ArrayClass] Class >>>>
'-------------------------------------------------------------------------
Class ArrayClass
Public m_Array
Private Sub Class_Initialize
ReDim m_Array( -1 )
End Sub
Public Default Property Get Item( i )
If IsObject( m_Array(i) ) Then Set Item = m_Array(i) Else Item = m_Array(i)
End Property
Public Property Let Item( i, value )
m_Array(i) = value
End Property
Public Sub ToEmpty()
ReDim m_Array( -1 )
End Sub
Public Sub ReDim_( UBoundValue )
ReDim Preserve m_Array( UBoundValue )
End Sub
Public Sub Add( elem )
Push elem
End Sub
Public Sub Push( elem )
ReDim Preserve m_Array( UBound(m_Array) + 1 )
If IsObject( elem ) Then
Set m_Array( UBound(m_Array) ) = elem
Else
m_Array( UBound(m_Array) ) = elem
End If
End Sub
Public Function Pop()
If IsObject( m_Array( UBound(m_Array) ) ) Then
Set Pop = m_Array( UBound(m_Array) )
Else
Pop = m_Array( UBound(m_Array) )
End If
ReDim Preserve m_Array( UBound(m_Array) - 1 )
End Function
Public Property Get Count()
Count = UBound(m_Array) + 1
End Property
Public Property Get UBound_()
UBound_ = UBound(m_Array)
End Property
Public Sub Echo()
WScript.Echo Value
End Sub
Public Property Get Value()
Dim s, i, e
s = "count = " & Count
For Each i In m_Array
If IsObject( i ) Then
s = s + vbCRLF + "Class " & TypeName( i )
On Error Resume Next
s = s + vbCRLF + i.Value
e = Err.Number
On Error GoTo 0
If e <> 0 And e <> 438 Then Err.Raise e
Else
s = s + vbCRLF + "each = " & i
End If
Next
Value = s
End Property
Public Sub Copy( SrcArr )
If IsArray( SrcArr ) Then
m_Array = SrcArr
ElseIf TypeName( SrcArr ) = "ArrayClass" Then
m_Array = SrcArr.m_Array
Else
Err.Raise 1
End If
End Sub
Public Sub AddElems( SrcArr )
If IsArray( SrcArr ) Then
AddArrElem m_Array, SrcArr
ElseIf TypeName( SrcArr ) = "ArrayClass" Then
AddArrElem m_Array, SrcArr.m_Array
Else
Me.Add SrcArr
End If
End Sub
End Class
'-------------------------------------------------------------------------
' ### <<<< [ArrayDictionary] Class >>>>
'-------------------------------------------------------------------------
Class ArrayDictionary
Public m_Dic
Private Sub Class_Initialize
Set m_Dic = CreateObject("Scripting.Dictionary")
End Sub
Public Sub ToEmpty
m_Dic.RemoveAll
End Sub
Public Sub Add( key, item )
Dim dic_item
If m_Dic.Exists( key ) Then
m_Dic.Item( key ).Add item
Else
Set dic_item = New ArrayClass : ErrCheck
dic_item.Add item
m_Dic.Add key, dic_item
End If
End Sub
Public Function Count
Dim i
Count = 0
For Each i in m_Dic.Items()
Count = Count + i.Count
Next
End Function
Public Sub Echo
Dim i, n
WScript.Echo "--- ArrayDictionary ------------------------------"
WScript.Echo "key count = " & m_Dic.Count
WScript.Echo "item count = " & Count
For Each i in m_Dic.Keys()
WScript.Echo "key=""" & i & """"
m_Dic.Item(i).Echo
Next
WScript.Echo ""
End Sub
End Class
'-------------------------------------------------------------------------
' ### <<<< [StringStream] Class >>>>
'-------------------------------------------------------------------------
Class StringStream
Public m_Str
Public m_INextLine
Private m_RaedLine, m_WriteLine, m_bPrevIsWrite
Public Property Get Line()
If m_bPrevIsWrite Then Line = m_WriteLine Else Line = m_ReadLine
End Property
Public Sub SetString( Str )
m_Str = Str
m_INextLine = 1
m_RaedLine = 1
m_WriteLine = 1
End Sub
Public Function ReadLine()
Dim i
i = InStr( m_INextLine, m_Str, vbCRLF )
If i > 0 Then
ReadLine = Mid( m_Str, m_INextLine, i - m_INextLine )
m_INextLine = i + 2
Else
ReadLine = Mid( m_Str, m_INextLine )
m_Str = Empty
m_INextLine = Empty
End If
m_RaedLine = m_RaedLine + 1
End Function
Public Function ReadAll()
ReadAll = m_Str
m_Str = Empty
End Function
Public Property Get AtEndOfStream : AtEndOfStream = IsEmpty( m_Str ) : End Property
Public Sub Write( Str ) : m_Str = m_Str + Str : End Sub
Public Sub WriteLine( LineStr ) : m_Str = m_Str + LineStr + vbCRLF : m_WriteLine = m_WriteLine + 1 : End Sub
End Class
'-------------------------------------------------------------------------
' ### <<<< [StrMatchKey] Class >>>>
'-------------------------------------------------------------------------
Class StrMatchKey
Public Property Let Keyword( s )
m_Keyword = s
m_LeftCount = InStr( s, "*" ) - 1
m_LeftStr = Left( s, m_LeftCount )
m_RightCount = Len( s ) - m_LeftCount - 1
m_RightStr = Right( s, m_RightCount )
If InStr( m_LeftCount + 2, s, "*" ) > 0 Then _
Raise 1,"* を複数指定することはできません"
End Property
Public Property Get Keyword()
Keyword = m_Keyword
End Property
Public Function IsMatch( TestStr )
'// m_Keyword must be low case
If LCase( Right( TestStr, m_RightCount ) ) = m_RightStr Then
If m_LeftCount = 0 Then IsMatch = True : Exit Function
If LCase( Left( TestStr, m_LeftCount ) ) = m_LeftStr Then
IsMatch = True
End If
End If
End Function
Public Function IsMatchULCase( TestStr )
If Right( TestStr, m_RightCount ) = m_RightStr Then
If m_LeftCount = 0 Then IsMatchULCase = True : Exit Function
If Left( TestStr, m_LeftCount ) = m_LeftStr Then
IsMatchULCase = True
End If
End If
End Function
Public m_Keyword
Public m_LeftCount
Public m_RightCount
Public m_LeftStr
Public m_RightStr
End Class
'********************************************************************************
' <<< [LenK] >>>
'********************************************************************************
Function LenK( Str )
Dim c, a, i, n_zen
i = 1 : n_zen = 0
Do
c = Mid( Str, i, 1 )
If c = "" Then LenK = i - 1 + n_zen : Exit Function
a = Asc( c )
If a >= 256 or a < 0 Then n_zen = n_zen + 1
i = i + 1
Loop
End Function
'********************************************************************************
' <<< [DateAddStr] >>>
'********************************************************************************
Function DateAddStr( BaseDate, Plus )
Dim i, i2, c, flag, num, unit, i_over
DateAddStr = BaseDate
i=1
i_over = Len( Plus ) + 1
'//=== Skip spaces
While Mid( Plus, i, 1 ) = " " : i=i+1 : WEnd
'//=== Get flag
flag = +1
c = Mid( Plus, i, 1 )
If c = "+" Then
i=i+1
ElseIf c = "-" Then
flag = -1 : i=i+1
End If
Do
'//=== Skip spaces
While Mid( Plus, i, 1 ) = " " : i=i+1 : WEnd
If i = i_over Then Exit Do
'//=== Get number
c = Mid( Plus, i, 1 )
i2 = i
While (c >= "0" and c <= "9") or c="-" or c="+" : i2=i2+1 : c = Mid( Plus, i2, 1 ) : WEnd
num = CInt( Mid( Plus, i, i2 - i ) )
i = i2
'//=== Skip spaces
While Mid( Plus, i, 1 ) = " " : i=i+1 : WEnd
'//=== Get unit
c = Mid( Plus, i, 1 )
i2 = i
While (c >= "a" and c <= "z") or (c >= "A" and c <= "Z") : i2=i2+1 : c = Mid( Plus, i2, 1 ) : WEnd
Select Case LCase( Mid( Plus, i, i2 - i ) )
Case "year", "years" : unit = "yyyy"
Case "month", "months" : unit = "m"
Case "day", "days" : unit = "d"
Case "hour", "hours" : unit = "h"
Case "minute","minutes","min": unit = "n"
Case "second","seconds","sec": unit = "s"
Case Else Err.Raise 1,,"単位がおかしい"
End Select
i = i2
'//=== Add Date
DateAddStr = DateAdd( unit, flag * num, DateAddStr )
Loop
End Function
'*-------------------------------------------------------------------------*
'* ### <<<< System (safe part) >>>>
'*-------------------------------------------------------------------------*
'********************************************************************************
' <<< [RegRead] >>>
'********************************************************************************
Function RegRead( Path )
Dim e
If TryStart(e) Then On Error Resume Next
RegRead = g_sh.RegRead( Path )
If TryEnd Then On Error GoTo 0
If e.num = E_PathNotFound or e.num = E_WIN32_FILE_NOT_FOUND Then
e.Clear
End If
If e.num <> 0 Then e.Raise
End Function
'********************************************************************************
' <<< [RegEnumKey] >>>
'********************************************************************************
Sub RegEnumKey( ByVal Path, out_Keys, Opt )
ReDim out_Keys(0)
Dim keys, key, i, u
If IsEmpty( Opt ) Then RegEnumKey_sub Path, out_Keys : Exit Sub
i = 0 : u = 0
out_Keys(0) = Path
Do
RegEnumKey_sub out_Keys(i), keys '// get keys
If not IsNull( keys ) Then
For Each key In keys
u=u+1
ReDim Preserve out_Keys( u + 1 )
out_Keys(u) = out_Keys(i) + "\" + key
Next
End If
i=i+1
If i > u Then Exit Do
Loop
End Sub
Sub RegEnumKey_sub( ByVal Path, out_Keys )
Dim reg, i, root_key
i = InStr( Path, "\" )
Select Case Left( Path, i - 1 )
Case "HKEY_CLASSES_ROOT" : root_key = &h80000000
Case "HKEY_CURRENT_USER" : root_key = &h80000001
Case "HKEY_LOCAL_MACHINE" : root_key = &h80000002
Case "HKEY_USERS" : root_key = &h80000003
Case "HKEY_PERFORMANCE_DATA":root_key= &h80000004
Case "HKEY_CURRENT_CONFIG": root_key = &h80000005
Case "HKEY_DYN_DATA" : root_key = &h80000006
Case Else : Err.Raise &h80070002
End Select
Path = Mid( Path, i + 1 )
If IsEmpty( g_reg ) Then _
Set g_reg = GetObject("winmgmts:{impersonationLevel=impersonate}!root/default:StdRegProv")
g_reg.EnumKey root_key, Path, out_Keys
If IsNull( out_Keys ) Then ReDim out_Keys(-1)
End Sub
'********************************************************************************
' <<< [RegEnumValues] >>>
'********************************************************************************
Class RegValueName
Public Name
Public Type_
End Class
Sub RegEnumValues( ByVal Path, out_Values )
Dim reg, i, root_key, names, types
i = InStr( Path, "\" )
Select Case Left( Path, i - 1 )
Case "HKEY_CLASSES_ROOT" : root_key = &h80000000
Case "HKEY_CURRENT_USER" : root_key = &h80000001
Case "HKEY_LOCAL_MACHINE" : root_key = &h80000002
Case "HKEY_USERS" : root_key = &h80000003
Case "HKEY_PERFORMANCE_DATA":root_key= &h80000004
Case "HKEY_CURRENT_CONFIG": root_key = &h80000005
Case "HKEY_DYN_DATA" : root_key = &h80000006
Case Else : Err.Raise &h80070002
End Select
Path = Mid( Path, i + 1 )
If IsEmpty( g_reg ) Then _
Set g_reg = GetObject("winmgmts:{impersonationLevel=impersonate}!root/default:StdRegProv")
g_reg.EnumValues root_key, Path, names, types
ReDim out_Values( UBound( names ) )
For i=0 To UBound( names )
Set out_Values(i) = new RegValueName : ErrCheck
out_Values(i).Name = names(i)
Select Case types(i)
Case 1 : out_Values(i).Type_ = "REG_SZ"
Case 2 : out_Values(i).Type_ = "REG_EXPAND_SZ"
Case 3 : out_Values(i).Type_ = "REG_BINARY"
Case 4 : out_Values(i).Type_ = "REG_DWORD"
Case 7 : out_Values(i).Type_ = "REG_MULTI_SZ"
End Select
Next
End Sub
'********************************************************************************
' <<< [RegExists] >>>
'********************************************************************************
Function RegExists( Path )
Dim en,ed
Const E_PathNotFound = &h80070002
On Error Resume Next
g_sh.RegRead Path
en = Err.Number : ed = Err.Description : On Error GoTo 0
If en = E_PathNotFound Then RegExists = False : Exit Function
If en <> 0 Then Err.Raise en,,ed
RegExists = True
End Function
'*-------------------------------------------------------------------------*
'* ### <<<< Error, Err2 >>>>
'*-------------------------------------------------------------------------*
'********************************************************************************
' <<< [Finish] >>>
'********************************************************************************
Sub Finish
WScript.Quit 9
End Sub
'********************************************************************************
' <<< [Error] >>>
'********************************************************************************
Sub Error
Err.Raise 1,,""
End Sub
'********************************************************************************
' <<< [Err2] >>>
'********************************************************************************
Class Err2
Public Number ' Err.Number
Public num ' Err.Number
Public Description ' Err.Description (Error Message)
Public desc ' Err.Description (Error Message)
Public Source ' Err.Source
Public ErrID ' count of (num <> 0) in each first Copy after Clear
Public RaiseID ' count of (num <> 0) in Copy
Public BreakErrID ' as integer
Public BreakRaiseID ' as integer
Private Sub Class_Initialize
num = 0 : Description = "" : ErrID = 0 : RaiseID = 0
End Sub
Public Sub OnSuccessFinish
If Err.Number = 0 and Me.num <> 0 Then
echo ""
Dim b_dbg : b_dbg = not IsDefined( "Setting_getCanExceptionDebugger" )
If not b_dbg Then b_dbg = Setting_getCanExceptionDebugger()
If Me.ErrID >= 2 or b_dbg Then
echo "Run debugger with writing following code in main function." + vbCRLF + _
"g_Err2.BreakErrID = " & Me.ErrID & " [or] " & Me.ErrID & ".5"
End If
On Error Resume Next
Err.Raise Me.num, Me.Source, Me.desc
End If
End Sub
Public Sub OnErrorFinish
If Me.num <> 0 Then
echo "Run debugger with writing following code in main function." + vbCRLF + _
"g_Err2.BreakErrID = " & Me.ErrID & " [or] " & Me.ErrID & ".5"
End If
End Sub
Public Sub Copy( err )
Me.Number = err.Number
Me.num = err.Number
Me.Description = err.Description
Me.desc = err.Description
Me.Source = err.Source
If Me.num <> 0 Then Me.RaiseID = Me.RaiseID + 1 : If Me.RaiseID = 1 Then Me.ErrID = Me.ErrID + 1
End Sub
Public Function Value
Value = GetErrStr( num, Description )
End Function
Public Sub OverRaise( e_num, e_desc )
num = e_num
Description = e_desc
Raise
End Sub
Public Sub Raise
If num = 0 Then
Err.Raise 1 '// Look at caller function using watch window of debugger.
Else
Err.Raise num, Source, Description '// Re-raise previous Error again.
'// Write g_Err2.BreakErrID = (ErrID) or (ErrID)+0.5 at the first of main function.
'// [sample] g_Err2.BreakErrID = 1
End If
End Sub
Public Sub Clear
num = 0 : Description = "" : RaiseID = 0
End Sub
End Class
'********************************************************************************
' <<< [Raise] >>>
'********************************************************************************
Sub Raise( ErrNum, Description )
g_Err2.num = ErrNum
g_Err2.Source = "ERROR"
g_Err2.Description = Description
g_Err2.RaiseID = g_Err2.RaiseID + 1 : If g_Err2.RaiseID = 1 Then g_Err2.ErrID = g_Err2.ErrID + 1
If g_debug Then
echo "Run debugger with writing following code in main function."
echo "g_Err2.BreakErrID = " & g_Err2.ErrID & " [or] " & g_Err2.ErrID & ".5"
End If
Err.raise g_Err2.num, g_Err2.Source, g_Err2.Description
End Sub
'********************************************************************************
' <<< [SetErrBreak] >>>
'********************************************************************************
Sub SetErrBreak( ErrID, RaiseID )
g_Err2.BreakErrID = ErrID
g_Err2.BreakRaiseID = RaiseID
End Sub
'********************************************************************************
' <<< [NestPos] >>>
'********************************************************************************
Class NestPos
Public m_HereArr()
Private Sub Class_Initialize ' コンストラクタ
Redim m_HereArr(0)
m_HereArr(0) = 0
End Sub
Public Function GetPos( arr )
Dim u, i
u = UBound( m_HereArr )
Redim Preserve arr(u-1)
For i=0 To u-1
arr(i) = m_HereArr(i)
Next
End Function
Public Sub OnBlockStart
Dim u
u = UBound( m_HereArr )
m_HereArr(u) = m_HereArr(u) + 1
Redim Preserve m_HereArr(u+1)
m_HereArr(u+1) = 0
End Sub
Public Sub OnBlockEnd
Redim Preserve m_HereArr( UBound( m_HereArr ) - 1 )
End Sub
End Class
'********************************************************************************
' <<< [NotCallFinish] >>>
'********************************************************************************
Sub NotCallFinish()
echo "[ERROR] not call Finish"
Stop
If g_b_cscript_exe Then pause
WScript.Quit 1
End Sub
'********************************************************************************
' <<< [ErrorCheckInTerminate] >>>
'********************************************************************************
Sub ErrorCheckInTerminate()
If Err.Number <> 0 Then
echo GetErrStr( Err.Number, Err.Description + " in Class_Terminate" )
Stop
If g_b_cscript_exe Then pause
End If
End Sub
'********************************************************************************
' <<< [TryStart] >>>
'********************************************************************************
Function TryStart( e )
Set e = g_Err2
If e.num <> 0 Then Stop '// g_Err2.Clear されていません
If IsEmpty( e.BreakErrID ) Then
TryStart = True
Else
If e.ErrID = e.BreakErrID - 1 Then
TryStart = False
Else
TryStart = True
End If
End If
End Function
'********************************************************************************
' <<< [Trying] >>>
'********************************************************************************
Function Trying
Trying = (Err.Number=0)
If not Trying Then If g_Err2.ErrID = g_Err2.BreakErrID - 1.5 Then g_Err2.BreakErrID = Empty :_
Stop '// Look at caller function by call stack window
End Function
'********************************************************************************
' <<< [TryEnd] >>>
'********************************************************************************
Function TryEnd
' Do not have parameters.
' Because "If TryEnd(e) Then On Error Goto 0" cannot get error, if e is not Dim.
If Err.Number <> 0 Then
g_Err2.Copy Err
If g_Err2.ErrID = g_Err2.BreakErrID Then
TryEnd = False
Else
TryEnd = True
End If
If g_Err2.ErrID = g_Err2.BreakErrID - 0.5 Then g_Err2.BreakErrID = Empty :_
Stop '// Look at caller function by call stack window
Else
TryEnd = True
End If
End Function
'********************************************************************************
' <<< [ErrCheck] >>>
'********************************************************************************
Sub ErrCheck()
If Err.Number <> 0 Then g_Err2.Copy Err : g_Err2.Raise
End Sub
'********************************************************************************
' <<< [chk_exist_in_lib] >>>
' comment
' - If there is not path in vbslib folder, raise error of E_FileNotExist.
'********************************************************************************
Sub chk_exist_in_lib( ByVal path )
If not exist( g_vbslib_ver_folder + path ) Then Err.Raise E_FileNotExist,, _
"Not found """ + g_vbslib_ver_folder + path + """"
End Sub
'-------------------------------------------------------------------------
' ### <<<< [SkipSection] Class >>>>
'-------------------------------------------------------------------------
Class SkipSection
Public m_CurrentSecNum
Public m_SkipToSecNum
End Class
Dim g_SkipSection
Dim g_bSkipSectionSupport
Sub SkipToSection( Num )
If IsEmpty( Num ) Then
g_SkipSection = Empty
Else
Set g_SkipSection = new SkipSection
g_SkipSection.m_SkipToSecNum = Num
End If
End Sub
Function NotSkipSection()
g_bSkipSectionSupport = True
If IsEmpty( g_SkipSection ) Then NotSkipSection = True : Exit Function
Dim m : Set m = g_SkipSection
m.m_CurrentSecNum = m.m_CurrentSecNum + 1
If m.m_CurrentSecNum < m.m_SkipToSecNum Then NotSkipSection = False : Exit Function
echo ""
NotSkipSection = True
End Function
'-------------------------------------------------------------------------
' ### <<<< [FinObj] Class >>>>
'-------------------------------------------------------------------------
Class FinObj
Public m_Vars ' as Dictionay
Public m_FinallyFunc
Private Sub Class_Initialize
Set m_Vars = CreateObject("Scripting.Dictionary")
End Sub
Public Sub SetFunc( FuncName )
Set m_FinallyFunc = GetRef( FuncName )
End Sub
Public Sub SetVar( Name, Var )
If IsObject( Var ) Then Set m_Vars.Item( Name ) = Var _
Else m_Vars.Item( Name ) = Var
End Sub
Private Sub Class_Terminate()
If not IsEmpty( m_FinallyFunc ) Then
Dim en, ed : en = Err.Number : ed = Err.Description
m_FinallyFunc m_Vars
Err.Raise en,,ed
End If
End Sub
End Class