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