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