_src/Test/tools/vbslib/vbslib300/vbslib.vbs

   1 Option Explicit \r
   2 \r
   3 ' vbslib  ver3.00  Sep.22, 2009\r
   4 ' Copyright (c) 2008-2009, T's-Neko at Sage Plaisir 21 (Japan)\r
   5 ' All rights reserved. Based on 3-clause BSD license.\r
   6 \r
   7 Dim  g_SrcPath\r
   8 Dim  g_vbslib_main_Path\r
   9      g_vbslib_main_Path = g_SrcPath\r
  10 \r
  11 \r
  12  \r
  13 '********************************************************************************\r
  14 '  <<< Global variables >>> \r
  15 '********************************************************************************\r
  16 \r
  17 Dim  g_WritablePathes\r
  18 Dim  g_Err2, g_EchoObj\r
  19 Dim  g_AppKey\r
  20 Dim  g_Test\r
  21 Dim  g_CUI\r
  22 Dim  g_ChildHead\r
  23 Dim  g_CurrentWritables\r
  24 Dim  g_FileSystemRetryMSec\r
  25 Dim  g_Player  '// as Vbslib_Player\r
  26 \r
  27 Function  InitializeModule\r
  28   ReDim  g_WritablePathes(-1)\r
  29   Set g_CurrentWritables = new CurrentWritables : ErrCheck\r
  30   Set g_EchoObj = new EchoObj : ErrCheck\r
  31   Set g_Err2 = new Err2 : ErrCheck\r
  32   Set g_CUI = new CUI : ErrCheck\r
  33   g_FileSystemRetryMSec = 10*1000\r
  34 End Function\r
  35 Dim  g_InitializeModule\r
  36 Set  g_InitializeModule = GetRef( "InitializeModule" )\r
  37 \r
  38 Function  FinalizeModule( ThisPath, Reason )\r
  39   If Reason = 0 Then\r
  40     g_Err2.OnSuccessFinish\r
  41   Else\r
  42     g_Err2.OnErrorFinish\r
  43   End If\r
  44   echo_flush\r
  45 End Function\r
  46 Dim g_FinalizeModule: Set g_FinalizeModule = GetRef( "FinalizeModule" )\r
  47 Dim g_FinalizeLevel:      g_FinalizeLevel  = 100  ' If smaller, called early\r
  48 \r
  49 \r
  50 Const  F_File      = 1\r
  51 Const  F_Folder    = 2\r
  52 Const  F_SubFolder = 4\r
  53 \r
  54 Const  g_PauseMsg = "\91±\8ds\82·\82é\82É\82Í Enter \83L\81[\82ð\89\9f\82µ\82Ä\82\82¾\82³\82¢ . . . "\r
  55 Const  g_PauseMsgStone = 24\r
  56 \r
  57 \r
  58  \r
  59 '********************************************************************************\r
  60 '  <<< Error Code >>> \r
  61 '********************************************************************************\r
  62 \r
  63 Dim E_Others            : E_Others            = 1\r
  64 \r
  65 Dim E_AssertFail        : E_AssertFail        = &h80041001\r
  66 Dim E_TestFail          : E_TestFail          = &h80041003\r
  67 Dim E_BuildFail         : E_BuildFail         = &h80041004\r
  68 Dim E_OutOfWritable     : E_OutOfWritable     = &h80041005\r
  69 Dim E_NotFoundSymbol    : E_NotFoundSymbol    = &h80041006\r
  70 Dim E_ProgRetNotZero    : E_ProgRetNotZero    = &h80041007\r
  71 Dim E_Unexpected        : E_Unexpected        = &h80041008\r
  72 \r
  73 Dim E_WIN32_FILE_NOT_FOUND: E_WIN32_FILE_NOT_FOUND = &h80070002\r
  74 Dim E_WIN32_DIRECTORY     : E_WIN32_DIRECTORY      = &h8007010B\r
  75 \r
  76 Dim E_ProgTerminated    : E_ProgTerminated    = &hC0000005\r
  77 \r
  78 Dim E_FileNotExist      : E_FileNotExist      = 53\r
  79 Dim E_EndOfFile         : E_EndOfFile         = 62\r
  80 Dim E_WriteAccessDenied : E_WriteAccessDenied = 70\r
  81 Dim E_PathNotFound      : E_PathNotFound      = 76\r
  82 Dim E_AlreadyExist      : E_AlreadyExist      = 58\r
  83 \r
  84 \r
  85  \r
  86 '********************************************************************************\r
  87 '  <<< File Object >>> \r
  88 '********************************************************************************\r
  89 \r
  90 Const ReadOnly  = 1\r
  91 \r
  92 \r
  93  \r
  94 '*-------------------------------------------------------------------------*\r
  95 '* ### <<<< Debugging >>>> \r
  96 '*-------------------------------------------------------------------------*\r
  97 \r
  98 \r
  99  \r
 100 '********************************************************************************\r
 101 '  <<< [g_count_up] >>> \r
 102 '********************************************************************************\r
 103 Redim  g_count(-1)\r
 104 \r
 105 Function  g_count_up( i )\r
 106   If i > UBound( g_count ) Then  Redim Preserve  g_count(i)\r
 107   g_count_up = g_count(i) + 1\r
 108   g_count(i) = g_count_up\r
 109 End Function\r
 110 \r
 111 \r
 112  \r
 113 '********************************************************************************\r
 114 '  <<< [SetTestMode] >>> \r
 115 '********************************************************************************\r
 116 Dim  F_NotRandom : F_NotRandom = 1\r
 117 Dim  g_TestModeFlags\r
 118 \r
 119 Sub  SetTestMode( Flags )\r
 120   g_TestModeFlags = Flags\r
 121 End Sub\r
 122 \r
 123 \r
 124  \r
 125 '*-------------------------------------------------------------------------*\r
 126 '* ### <<<< User Interface >>>> \r
 127 '*-------------------------------------------------------------------------*\r
 128 \r
 129 \r
 130  \r
 131 '********************************************************************************\r
 132 '  <<< [EchoObj] Class >>> \r
 133 '********************************************************************************\r
 134 Class  EchoObj\r
 135   Public  m_bEchoOff\r
 136   Public  m_bDisableEchoOff\r
 137   Public  m_Buf\r
 138   Public  m_BufN\r
 139 End Class\r
 140 '// g_EchoObj\r
 141 \r
 142  \r
 143 '********************************************************************************\r
 144 '  <<< [echo] >>> \r
 145 '********************************************************************************\r
 146 Function  echo( ByVal msg )\r
 147   If g_EchoObj.m_bEchoOff Then  Exit Function\r
 148 \r
 149   If not IsEmpty( msg ) Then\r
 150     msg = GetEchoString( msg )\r
 151 \r
 152     If g_CommandPrompt = 0 Then\r
 153       If IsEmpty( g_EchoObj.m_Buf ) Then\r
 154         g_EchoObj.m_Buf = msg\r
 155       Else\r
 156         g_EchoObj.m_Buf = g_EchoObj.m_Buf & vbCRLF & msg\r
 157       End If\r
 158       g_EchoObj.m_BufN = g_EchoObj.m_BufN + 1\r
 159       If g_EchoObj.m_BufN >= 20 Then  echo_flush\r
 160     Else\r
 161       WScript.Echo  msg\r
 162     End If\r
 163 \r
 164     If not IsEmpty( g_Test ) Then  g_Test.WriteLogLine  msg\r
 165   End If\r
 166   echo = msg\r
 167 End Function\r
 168 \r
 169 \r
 170  \r
 171 '********************************************************************************\r
 172 '  <<< [GetEchoString] >>> \r
 173 '********************************************************************************\r
 174 Function  GetEchoString( ByVal msg )\r
 175   If IsObject( msg ) Then  msg = msg.Value\r
 176 \r
 177   If IsNull( msg ) Then\r
 178     msg = "(null)"\r
 179   ElseIf VarType( msg ) = vbBoolean Then\r
 180     If msg Then  msg = "True" _\r
 181     Else         msg = "False"\r
 182   ElseIf IsArray( msg ) Then\r
 183     Dim a : Set a = new ArrayClass : ErrCheck\r
 184     a.Copy  msg\r
 185     msg = GetEchoString( a )\r
 186   End If\r
 187 \r
 188   GetEchoString = msg\r
 189 End Function\r
 190 \r
 191 \r
 192  \r
 193 '********************************************************************************\r
 194 '  <<< [echo_flush] >>> \r
 195 '********************************************************************************\r
 196 Sub  echo_flush()\r
 197   If g_CommandPrompt = 0 and g_EchoObj.m_BufN > 0 Then\r
 198     If MsgBox( g_EchoObj.m_Buf, vbOKCancel, WScript.ScriptName ) = vbCancel Then\r
 199       WScript.Quit  1\r
 200     End If\r
 201     g_EchoObj.m_Buf = Empty\r
 202     g_EchoObj.m_BufN = 0\r
 203   End If\r
 204 End Sub\r
 205 \r
 206 \r
 207 \r
 208  \r
 209 '********************************************************************************\r
 210 '  <<< [EchoOff] >>> \r
 211 '********************************************************************************\r
 212 Class  EchoOff\r
 213   Public  m_Prev\r
 214 \r
 215   Private Sub Class_Initialize\r
 216     m_Prev = g_EchoObj.m_bEchoOff\r
 217     g_EchoObj.m_bEchoOff = not g_EchoObj.m_bDisableEchoOff\r
 218   End Sub\r
 219 \r
 220   Private Sub Class_Terminate\r
 221     g_EchoObj.m_bEchoOff = m_Prev\r
 222   End Sub\r
 223 End Class\r
 224 \r
 225 \r
 226  \r
 227 '********************************************************************************\r
 228 '  <<< [DisableEchoOff] >>> \r
 229 '********************************************************************************\r
 230 Sub  DisableEchoOff\r
 231   g_EchoObj.m_bDisableEchoOff = True\r
 232 End Sub\r
 233 \r
 234 \r
 235  \r
 236 '********************************************************************************\r
 237 '  <<< [echo_r] >>> \r
 238 ' return: output message\r
 239 '********************************************************************************\r
 240 Function  echo_r( ByVal msg, redirect_path )\r
 241   Dim  f\r
 242   Const  ForAppending = 8\r
 243 \r
 244   If IsObject( msg ) Then  msg = msg.Value\r
 245 \r
 246   If g_debug Then  WScript.Echo  msg\r
 247 \r
 248   If IsEmpty( redirect_path ) Then\r
 249   ElseIf redirect_path = "" Then\r
 250     If Not g_debug Then  WScript.Echo  msg\r
 251   Else\r
 252     Set f = g_fs.OpenTextFile( redirect_path, ForAppending, True, False )\r
 253     f.WriteLine  msg\r
 254   End If\r
 255 \r
 256   echo_r = msg\r
 257 End Function\r
 258 \r
 259 \r
 260  \r
 261 '********************************************************************************\r
 262 '  <<< old I/F [echo_c] >>> \r
 263 '********************************************************************************\r
 264 Function  echo_c( ByVal msg )\r
 265   If g_cut_old Then  Stop\r
 266   echo_c = echo( msg )\r
 267 End Function\r
 268 \r
 269 \r
 270  \r
 271 '********************************************************************************\r
 272 '  <<< [type_] >>> \r
 273 '********************************************************************************\r
 274 Sub  type_( path )\r
 275   Dim  f\r
 276 \r
 277   Set f = g_fs.OpenTextFile( path )\r
 278 \r
 279   Do Until f.AtEndOfStream\r
 280     echo f.ReadLine\r
 281   Loop\r
 282 End Sub\r
 283 \r
 284 \r
 285  \r
 286 '********************************************************************************\r
 287 '  <<< [pause] >>> \r
 288 '********************************************************************************\r
 289 Sub  pause()\r
 290   If g_CommandPrompt = 0 Then\r
 291     echo  "\91±\8ds\82·\82é\82É\82Í Enter \83L\81[\82ð\89\9f\82µ\82Ä\82\82¾\82³\82¢ . . ."\r
 292     echo_flush\r
 293   Else\r
 294     g_CUI.input_sub  g_PauseMsg, False\r
 295   End If\r
 296 End Sub\r
 297 \r
 298 \r
 299  \r
 300 '********************************************************************************\r
 301 '  <<< [pause2] >>> \r
 302 '********************************************************************************\r
 303 Sub  pause2()\r
 304   If WScript.Arguments.Named("wscript")=1 Then input g_PauseMsg\r
 305 End Sub\r
 306 \r
 307 \r
 308  \r
 309 '********************************************************************************\r
 310 '  <<< [input] >>> \r
 311 '********************************************************************************\r
 312 Function  input( ByVal msg )\r
 313 \r
 314   input = g_CUI.input( msg )\r
 315 \r
 316 End Function\r
 317 \r
 318 \r
 319  \r
 320 '********************************************************************************\r
 321 '  <<< [set_input] >>> \r
 322 '********************************************************************************\r
 323 Sub  set_input( Keys )\r
 324 \r
 325   g_CUI.m_Auto_Keys = Keys\r
 326 \r
 327 End Sub\r
 328 \r
 329 \r
 330  \r
 331 '********************************************************************************\r
 332 '  <<< [InputPath] >>> \r
 333 '********************************************************************************\r
 334 Const  F_ChkFileExists   = 1\r
 335 Const  F_ChkFolderExists = 2\r
 336 Const  F_AllowEnterOnly  = 4\r
 337 \r
 338 Function  InputPath( Prompt, Flags )\r
 339   Dim  path\r
 340 \r
 341   Do\r
 342     path = input( Prompt )\r
 343     path = Trim( path )\r
 344 \r
 345     If path = "" and ( Flags and F_AllowEnterOnly ) Then  Exit Do\r
 346 \r
 347     If Left( path, 1 ) = """" and Right( path, 1 ) = """" Then _\r
 348       path = Mid( path, 2, Len( path ) - 2 )\r
 349 \r
 350     If Flags = 0 Then  Exit Do\r
 351     If Flags and F_ChkFileExists Then\r
 352       If g_fs.FileExists( path ) Then  Exit Do\r
 353     End If\r
 354     If Flags and F_ChkFolderExists Then\r
 355       If g_fs.FolderExists( path ) Then  Exit Do\r
 356     End If\r
 357     echo "not found"\r
 358   Loop\r
 359   InputPath = path\r
 360 End Function\r
 361 \r
 362  \r
 363 '********************************************************************************\r
 364 '  <<< [SendKeys] Send keyboard code stroke to OS >>> \r
 365 '********************************************************************************\r
 366 Sub  SendKeys( ByVal window_title, ByVal keycords, ByVal late_time )\r
 367   WScript.Sleep late_time\r
 368   If window_title <> "" Then  g_sh.AppActivate( window_title )\r
 369   WScript.Sleep 100\r
 370   g_sh.SendKeys keycords\r
 371 End Sub\r
 372 \r
 373 \r
 374  \r
 375 '*-------------------------------------------------------------------------*\r
 376 '* ### <<<< [CUI] Class >>>> \r
 377 '*-------------------------------------------------------------------------*\r
 378 \r
 379 Class  CUI\r
 380 \r
 381   Public  m_Auto_InputFunc    ' as string of auto input function name\r
 382   Public  m_Auto_Src          ' as string of path\r
 383   Public  m_Auto_Keys         ' as string of auto input keys\r
 384   Public  m_Auto_KeyEnter     ' as string of the character of replacing to enter key\r
 385   Public  m_Auto_DebugCount   ' as integer\r
 386 \r
 387 \r
 388  \r
 389 '********************************************************************************\r
 390 '  <<< [CUI::Class_Initialize] >>> \r
 391 '********************************************************************************\r
 392 Private Sub Class_Initialize\r
 393   Me.m_Auto_Keys = ""\r
 394   Me.m_Auto_KeyEnter = "."\r
 395   Me.m_Auto_DebugCount = Empty\r
 396 End Sub\r
 397 \r
 398 \r
 399  \r
 400 '********************************************************************************\r
 401 '  <<< [CUI::input] >>> \r
 402 '********************************************************************************\r
 403 Public Function  input( ByVal msg )\r
 404   input = input_sub( msg, not IsEmpty( WScript.Arguments.Named.Item("GUI_input") ) )\r
 405 End Function\r
 406 \r
 407 Public Function  input_sub( ByVal msg, bGUI_input )\r
 408   Dim e\r
 409   Dim InputFunc\r
 410 \r
 411   If not IsEmpty( g_EchoObj.m_Buf ) Then  msg = g_EchoObj.m_Buf + vbCRLF + msg\r
 412   g_EchoObj.m_Buf = Empty\r
 413   g_EchoObj.m_BufN = 0\r
 414 \r
 415   If msg = g_PauseMsg and Not IsEmpty( m_Auto_Keys ) And  m_Auto_Keys <> "" Then\r
 416     '// Owner process does not wait in EchoStream\r
 417     Wscript.StdOut.Write  Left( g_PauseMsg, g_PauseMsgStone )+"*"+Chr(8)+_\r
 418                           Mid(  g_PauseMsg, g_PauseMsgStone+1 )\r
 419   Else\r
 420     Wscript.StdOut.Write  msg\r
 421   End If\r
 422 \r
 423   On Error Resume Next\r
 424 \r
 425   If Not IsEmpty( m_Auto_Keys ) And  m_Auto_Keys <> "" Then\r
 426     If Not IsEmpty( m_Auto_KeyEnter ) Then\r
 427       e = InStr( m_Auto_Keys, m_Auto_KeyEnter )\r
 428       If e = 0 Then\r
 429         input_sub = m_Auto_Keys\r
 430         m_Auto_Keys = Empty\r
 431       Else\r
 432         input_sub = Left( m_Auto_Keys, e - 1 )\r
 433         m_Auto_Keys = Mid( m_Auto_Keys, e + 1 )\r
 434       End If\r
 435     Else\r
 436       input_sub = m_Auto_Keys\r
 437       m_Auto_Keys = Empty\r
 438     End If\r
 439 \r
 440     If IsEmpty( m_Auto_DebugCount ) Then\r
 441       Wscript.StdOut.WriteLine  input_sub\r
 442     ElseIf  m_Auto_DebugCount > 1 Then\r
 443       Wscript.StdOut.WriteLine  input_sub\r
 444       m_Auto_DebugCount = m_Auto_DebugCount - 1\r
 445     Else\r
 446       Wscript.StdOut.Write  input_sub\r
 447       If bGUI_input Then\r
 448         input_sub = InputBox( msg, WScript.ScriptName, "" )\r
 449         Wscript.StdOut.WriteLine  input_sub\r
 450       Else\r
 451         input_sub = Wscript.StdIn.ReadLine\r
 452       End If\r
 453       Wscript.StdOut.WriteLine ""\r
 454     End If\r
 455 \r
 456   ElseIf IsEmpty( m_Auto_InputFunc ) Then\r
 457     If bGUI_input Then\r
 458       input_sub = InputBox( msg, WScript.ScriptName, "" )\r
 459       Wscript.StdOut.WriteLine  input_sub\r
 460     Else\r
 461       input_sub = Wscript.StdIn.ReadLine\r
 462     End If\r
 463   Else\r
 464     If IsEmpty( m_Auto_Src ) Then\r
 465       Set InputFunc = GetRef( m_Auto_InputFunc )\r
 466       If Err.Number = 5 Then Wscript.StdOut.WriteLine vbCR+vbLF+"Not found function of """+_\r
 467                              m_Auto_InputFunc +"""": Err.Clear\r
 468       If Not IsEmpty( InputFunc ) Then  input_sub = InputFunc( msg )\r
 469     Else\r
 470       input_sub = call_vbs_t( m_Auto_Src, m_Auto_InputFunc, msg )\r
 471       If Err.Number = 5 Then Wscript.StdOut.WriteLine vbCR+vbLF+"Not found function of """+_\r
 472             m_Auto_InputFunc +""" in """+m_Auto_Src+"""" : Err.Clear\r
 473       If IsEmpty( input_sub ) Then  Wscript.StdOut.Write  msg : input_sub = Wscript.StdIn.ReadLine\r
 474     End If\r
 475   End If\r
 476 \r
 477   e = Err.Number : Err.Clear : On Error GoTo 0\r
 478   If e <> 0 Then\r
 479     If e <> 62 Then Err.Raise e  '62= End Of File (StdIn, ^C)\r
 480     WScript.Quit 1\r
 481   End If\r
 482 \r
 483 End Function\r
 484 \r
 485 \r
 486  \r
 487 '********************************************************************************\r
 488 '  <<< [CUI::SetAutoKeysFromMainArg] >>> \r
 489 '********************************************************************************\r
 490 Public Sub  SetAutoKeysFromMainArg\r
 491   If not IsEmpty( Me.m_Auto_Keys ) and Me.m_Auto_Keys = "" Then\r
 492     Me.m_Auto_Keys = WScript.Arguments.Named.Item("set_input")\r
 493     Me.m_Auto_DebugCount = WScript.Arguments.Named.Item("set_input_debug")\r
 494   End If\r
 495 End Sub\r
 496 \r
 497 \r
 498  \r
 499 End Class \r
 500 \r
 501 \r
 502  \r
 503 '*-------------------------------------------------------------------------*\r
 504 '* ### <<<< File >>>> \r
 505 '*-------------------------------------------------------------------------*\r
 506 \r
 507 \r
 508  \r
 509 '********************************************************************************\r
 510 '  <<< [AppKeyClass] >>> \r
 511 '********************************************************************************\r
 512 Const  F_AskIfWarn = 0\r
 513 Const  F_ErrIfWarn = 1\r
 514 Const  F_IgnoreIfWarn = 2\r
 515 Const  F_BreakIfWarn = 3\r
 516 \r
 517 Class  AppKeyClass\r
 518   Private  m_Key\r
 519   Private  m_bAppKey\r
 520   Private  m_WritableMode  ' as Flags\r
 521   Private  m_NewWritables()\r
 522   Public   m_BreakByFName  ' as string\r
 523 \r
 524   Private Sub Class_Initialize()\r
 525     m_WritableMode = F_AskIfWarn\r
 526     ReDim  m_NewWritables(-1)\r
 527   End Sub\r
 528 \r
 529   Public Function  SetKey( Key )\r
 530     If not IsEmpty( m_Key ) Then  Err.Raise 1,,"Double Key"\r
 531     Set m_Key = Key\r
 532     Key.SetKey_sub  Me\r
 533     Set SetKey = Key\r
 534   End Function\r
 535   Public Sub  SetKey_sub( Key )\r
 536     If not IsEmpty( m_Key ) Then  Err.Raise 1,,"Double Key"\r
 537     m_bAppKey = ( Key Is g_AppKey )\r
 538     Set m_Key = Key\r
 539   End Sub\r
 540 \r
 541   Public Function  IsSame( Key )\r
 542     IsSame = ( m_Key Is Key ) and Key.IsSame_sub( Me )\r
 543   End Function\r
 544   Public Function  IsSame_sub( Key )\r
 545     IsSame_sub = ( m_Key Is Key )\r
 546   End Function\r
 547 \r
 548   Public Sub  CheckGlobalAppKey()\r
 549     If not m_bAppKey Then _\r
 550       MsgBox "[ERROR] This is not AppKey from main2"\r
 551     If not IsSame( g_AppKey ) Then _\r
 552       MsgBox "[ERROR] g_AppKey was overrided by unknown"\r
 553   End Sub\r
 554   Private Sub  Class_Terminate()\r
 555     If m_bAppKey Then  CheckGlobalAppKey\r
 556   End Sub\r
 557 \r
 558  \r
 559 '********************************************************************************\r
 560 '  <<< [AppKeyClass::NewWritable] >>> \r
 561 '********************************************************************************\r
 562 Public Function  NewWritable( Pathes )\r
 563   Me.CheckGlobalAppKey\r
 564   Dim  m : Set m = new Writables : ErrCheck\r
 565   m.SetPathes  Me, Pathes\r
 566   Set  NewWritable = m\r
 567 End Function\r
 568 \r
 569  \r
 570 '********************************************************************************\r
 571 '  <<< [AppKeyClass::SetWritableMode] >>> \r
 572 '********************************************************************************\r
 573 Public Sub  SetWritableMode( Flags )\r
 574   If g_AppKey Is Me Then\r
 575     If Flags = F_IgnoreIfWarn Then\r
 576       Err.Raise  1\r
 577     Else\r
 578       m_Key.SetWritableMode( Flags )\r
 579       Exit Sub\r
 580     End If\r
 581   End If\r
 582 \r
 583   Select Case  Flags\r
 584     Case  F_AskIfWarn : echo  ">SetWritableMode  F_AskIfWarn"\r
 585     Case  F_ErrIfWarn : echo  ">SetWritableMode  F_ErrIfWarn"\r
 586     Case  F_IgnoreIfWarn:echo ">SetWritableMode  F_IgnoreIfWarn"\r
 587     Case  F_BreakIfWarn :echo ">SetWritableMode  F_BreakIfWarn"\r
 588     Case Else : Err.Raise  1\r
 589   End Select\r
 590 \r
 591   m_WritableMode = Flags\r
 592 End Sub\r
 593 \r
 594 Public Function  GetWritableMode()\r
 595   If g_AppKey Is Me Then\r
 596     GetWritableMode = m_Key.GetWritableMode()\r
 597   Else\r
 598     GetWritableMode = m_WritableMode\r
 599   End If\r
 600 End Function\r
 601 \r
 602  \r
 603 '********************************************************************************\r
 604 '  <<< [AppKeyClass::AddNewWritableFolder] >>> \r
 605 '********************************************************************************\r
 606 Public Sub  AddNewWritableFolder( Path )\r
 607   If g_AppKey Is Me Then  m_Key.AddNewWritableFolder( Path ) : Exit Sub\r
 608 \r
 609   Dim  abs_path, passed_path, out\r
 610 \r
 611   '// Stop at debug\r
 612   If g_debug_or_test Then\r
 613     If StrComp( g_AppKey.m_BreakByFName, g_fs.GetFileName( Path ), vbTextCompare ) = 0 Then\r
 614       echo_r  "Break by """ + g_AppKey.m_BreakByFName + """", ""\r
 615       Stop\r
 616     End If\r
 617   End If\r
 618 \r
 619 \r
 620   '// If the folder in writable folder, Do nothing\r
 621   abs_path = g_CurrentWritables.CheckWritable( Path )\r
 622   If IsEmpty( abs_path ) Then  Exit Sub\r
 623 \r
 624 \r
 625   '// If it is not able to add new writable, raise warning.\r
 626   If not IsEmpty( g_CurrentWritables.CheckAddNewWritable( abs_path, out ) ) Then _\r
 627     CheckWritable abs_path : Exit Sub\r
 628   passed_path = out\r
 629 \r
 630 \r
 631   '// Add to m_NewWritables\r
 632   '// (sample) writable="C:\A\*", passed="C:\A", abs="C:\A\B" ... new="C:\A\B\"\r
 633   '// (sample) writable="C:\A\*", passed="C:\A", abs="C:\A\B\a.txt" ... new="C:\A\B\"\r
 634   '// (sample) writable="C:\A\*", passed="C:\A", abs="C:\A\B\C\a.txt" ... new="C:\A\B\"\r
 635   '// (sample) writable="C:\*", passed="C:", abs="C:\A\B\C\a.txt" ... new="C:\A\"\r
 636 \r
 637   ReDim Preserve  m_NewWritables( UBound( m_NewWritables ) + 1 )\r
 638 \r
 639   Dim  i : i = InStr( Len(passed_path)+2, abs_path, "\" )\r
 640   If i = 0 Then\r
 641     m_NewWritables( UBound( m_NewWritables ) ) = abs_path + "\"\r
 642   Else\r
 643     m_NewWritables( UBound( m_NewWritables ) ) = Left( abs_path, i )\r
 644   End If\r
 645 \r
 646 End Sub\r
 647 \r
 648 \r
 649  \r
 650 '********************************************************************************\r
 651 '  <<< [AppKeyClass::CheckNewWritable] >>> \r
 652 '********************************************************************************\r
 653 Public Function  CheckNewWritable( AbsPath )\r
 654   If g_AppKey Is Me Then  CheckNewWritable = m_Key.CheckNewWritable( AbsPath ) : Exit Function\r
 655 \r
 656   Dim  writable\r
 657 \r
 658   For Each writable  In m_NewWritables\r
 659     If StrComp( writable, Left( AbsPath, Len( writable ) ), 1 ) = 0 Then  Exit Function\r
 660   Next\r
 661   CheckNewWritable = AbsPath\r
 662 End Function\r
 663 \r
 664  \r
 665 '********************************************************************************\r
 666 '  <<< [AppKeyClass::Ask] >>> \r
 667 '********************************************************************************\r
 668 Public Sub  Ask( CheckPath )\r
 669   If g_AppKey Is Me Then  m_Key.Ask( CheckPath ) : Exit Sub\r
 670 \r
 671   Dim  msg2 : msg2 = "" : If exist( CheckPath ) Then  msg2 = "Cannot overwrite, "\r
 672 \r
 673   Dim  writable\r
 674   For Each writable  In g_CurrentWritables.CurrentPathes\r
 675     If Right( writable, 3 ) = "\*\" Then\r
 676       If Left( writable, Len(writable) - 2 ) = Left( CheckPath, Len( writable ) - 2 ) or _\r
 677          Left( writable, Len(writable) - 3 ) = CheckPath Then\r
 678         If g_fs.FileExists( CheckPath ) Then\r
 679           msg2 = "Cannot overwrite NOT NEW file, "\r
 680         Else\r
 681           msg2 = "Cannot overwrite NOT NEW folder, "\r
 682         End If\r
 683       End If\r
 684     End If\r
 685   Next\r
 686 \r
 687   If m_WritableMode <> F_ErrIfWarn Then\r
 688     echo_r  "<WARNING msg='" +msg2+ "Out of Writable, see the help of SetWritableMode.'" +_\r
 689       " path='" & CheckPath & "'/>", ""\r
 690   End If\r
 691 \r
 692   If m_WritableMode = F_AskIfWarn Then\r
 693     Dim  s\r
 694     Do\r
 695       echo_flush\r
 696       If g_CommandPrompt = 0 Then\r
 697         s = InputBox( "\92¼\91O\82Ì\83_\83C\83A\83\8d\83O\83E\83B\83\93\83h\83E\82É\95\\8e¦\82µ\82½\83p\83X\82É\83t\83@\83C\83\8b\82ð\8fo\97Í\82µ\82Ü\82·\81B" & vbCRLF & _\r
 698             "(Y) \82Í\82¢\81B\83t\83@\83C\83\8b\8fo\97Í\82ð\8b\96\89Â\82µ\82Ü\82·" & vbCRLF & "(A) \88È\8cã\81A\82·\82×\82Ä\82Í\82¢" & vbCRLF & _\r
 699             "(N) \82¢\82¢\82¦\81B\83v\83\8d\83O\83\89\83\80\82ð\8fI\97¹\82µ\82Ü\82·" & vbCRLF & "(R) \83p\83X\82ð\82à\82¤\88ê\93x\95\\8e¦\82µ\82Ü\82·", _\r
 700             "[WARNING] " +msg2+ "Out of Writable", "Y" )\r
 701       Else\r
 702         s = InputBox( "\83R\83}\83\93\83h\83v\83\8d\83\93\83v\83g\82É\95\\8e¦\82µ\82½\83p\83X\82É\83t\83@\83C\83\8b\82ð\8fo\97Í\82µ\82Ü\82·\81B" & vbCRLF & _\r
 703             "(Y) \82Í\82¢\81B\83t\83@\83C\83\8b\8fo\97Í\82ð\8b\96\89Â\82µ\82Ü\82·" & vbCRLF & "(A) \88È\8cã\81A\82·\82×\82Ä\82Í\82¢" & vbCRLF & _\r
 704             "(N) \82¢\82¢\82¦\81B\83v\83\8d\83O\83\89\83\80\82ð\8fI\97¹\82µ\82Ü\82·" & vbCRLF & "(R) \83p\83X\82ð\82à\82¤\88ê\93x\95\\8e¦\82µ\82Ü\82·", _\r
 705             "[WARNING] " +msg2+ "Out of Writable", "Y" )\r
 706       End If\r
 707 \r
 708       If s="Y" or s="y" Then\r
 709         Exit Do\r
 710       ElseIf s="A" or s="a" Then\r
 711         SetWritableMode  F_IgnoreIfWarn\r
 712         Exit Do\r
 713       ElseIf s="R" or s="r" Then\r
 714         MsgBox  CheckPath, vbOKOnly, "[WARNING] Out of Writable"\r
 715       Else\r
 716         Err.Raise  E_OutOfWritable,, "Out of Writable """ & CheckPath & """"\r
 717         ' Watch  g_CurrentWritables.CurrentPathes and CheckPath\r
 718       End If\r
 719     Loop\r
 720   End If\r
 721 \r
 722   If m_WritableMode = F_BreakIfWarn Then  Stop  '// Look at caller function using debugger\r
 723   If m_WritableMode = F_BreakIfWarn  or  m_WritableMode = F_ErrIfWarn Then\r
 724     Err.Raise  E_OutOfWritable,, msg2+"Out of Writable """ & CheckPath & """"\r
 725      ' Watch  g_CurrentWritables.CurrentPathes and Path (CheckPath)\r
 726   End If\r
 727 End Sub\r
 728 \r
 729  \r
 730 '********************************************************************************\r
 731 '  <<< [AppKeyClass::InPath] >>> \r
 732 '********************************************************************************\r
 733 Public Function  InPath( ChkPathes, WritablePathes )\r
 734   If IsArray( ChkPathes ) or IsArray( WritablePathes ) Then\r
 735     echo  ">InPath"\r
 736   Else\r
 737     echo  ">InPath  " & ChkPathes & ", " & WritablePathes\r
 738   End If\r
 739   Dim  c, w, b\r
 740 \r
 741   '// ChkPathes To abs path\r
 742   If IsArray( ChkPathes ) Then\r
 743     ReDim  cs( UBound( ChkPathes ) )\r
 744     For i=0 To UBound( cs )\r
 745       cs(i) = g_fs.GetAbsolutePathName( ChkPathes(i) ) + "\"\r
 746     Next\r
 747   Else\r
 748     ReDim cs(0)\r
 749     cs(0) = g_fs.GetAbsolutePathName( ChkPathes ) + "\"\r
 750   End If\r
 751 \r
 752 \r
 753   '// WritablePathes To abs path\r
 754   If IsArray( WritablePathes ) Then\r
 755     ReDim  ws( UBound( WritablePathes ) )\r
 756     For i=0 To UBound( ws )\r
 757       ws(i) = g_fs.GetAbsolutePathName( WritablePathes(i) ) + "\"\r
 758     Next\r
 759   Else\r
 760     ReDim ws(0)\r
 761     ws(0) = g_fs.GetAbsolutePathName( WritablePathes ) + "\"\r
 762   End If\r
 763 \r
 764 \r
 765   '// Compare path\r
 766   For Each c  In cs\r
 767     b = False\r
 768     For Each w  In ws\r
 769       If Left( c, Len(w) ) = w Then  b = True : Exit For\r
 770     Next\r
 771     If not b Then  InPath = False : Exit Function\r
 772   Next\r
 773   InPath = True\r
 774 End Function\r
 775 \r
 776 \r
 777 \r
 778 \r
 779  \r
 780 '********************************************************************************\r
 781 '  <<< [AppKeyClass::BreakByPath] >>> \r
 782 '********************************************************************************\r
 783 Public Function  BreakByPath( Path )\r
 784   If StrComp( m_BreakByFName, g_fs.GetFileName( Path ), vbTextCompare ) = 0 Then\r
 785     echo_r  "Break by """ + g_AppKey.m_BreakByFName + """", ""\r
 786     Stop\r
 787   End If\r
 788 End Function\r
 789 \r
 790 \r
 791 \r
 792  \r
 793 '********************************************************************************\r
 794 '  <<< [AppKeyClass::BreakByWildcard] >>> \r
 795 '********************************************************************************\r
 796 Public Function  BreakByWildcard( Path, Flags )\r
 797   Dim  folder, fnames()\r
 798   Dim  fname\r
 799 \r
 800   ExpandWildcard  Path, Flags, folder, fnames\r
 801   For Each fname in fnames\r
 802     If StrComp( m_BreakByFName, g_fs.GetFileName( fname ), vbTextCompare ) = 0 Then\r
 803       echo_r  "Break by """ + g_AppKey.m_BreakByFName + """", ""\r
 804       Stop\r
 805     End If\r
 806   Next\r
 807 End Function\r
 808 \r
 809 \r
 810  \r
 811 End Class \r
 812  \r
 813 '********************************************************************************\r
 814 '  <<< [Writables] Class >>> \r
 815 '********************************************************************************\r
 816 Class  Writables\r
 817   Private  m_Pathes()\r
 818   Private  m_AppKey\r
 819 \r
 820   Public Sub  SetPathes( AppKey, Pathes )\r
 821     Dim  abs_path\r
 822 \r
 823     If not IsEmpty( m_AppKey ) Then  Err.Raise 1,,"Double key"\r
 824     If not g_AppKey.IsSame( AppKey ) Then  Err.Raise 1,,"Invalied AppKey"\r
 825 \r
 826     If IsArray( Pathes ) Then\r
 827       ReDim  m_Pathes( UBound( Pathes ) + 1 )\r
 828       For i=0 To UBound( Pathes )\r
 829         abs_path = GetAbsPath( Pathes(i), Empty )\r
 830         g_CurrentWritables.AskFileAccess  abs_path\r
 831         m_Pathes(i) = abs_path + "\"\r
 832       Next\r
 833     ElseIf TypeName( Pathes ) = "ArrayClass" Then\r
 834       ReDim  m_Pathes( UBound( Pathes.m_Array ) + 1 )\r
 835       For i=0 To UBound( Pathes.m_Array )\r
 836         abs_path = GetAbsPath( Pathes(i), Empty )\r
 837         g_CurrentWritables.AskFileAccess  abs_path\r
 838         m_Pathes(i) = abs_path + "\"\r
 839       Next\r
 840     Else\r
 841       ReDim  m_Pathes( 1 )\r
 842       abs_path = GetAbsPath( Pathes, Empty )\r
 843       g_CurrentWritables.AskFileAccess  abs_path\r
 844       m_Pathes(0) = abs_path + "\"\r
 845     End If\r
 846 \r
 847     GetObject_g_TempFile\r
 848     m_Pathes( UBound( m_Pathes ) ) = g_TempFile.m_FolderPath\r
 849 \r
 850     Set m_AppKey = AppKey\r
 851   End Sub\r
 852 \r
 853   Public Function  Enable()\r
 854     Dim  st : Set st = new WritablesStack : ErrCheck\r
 855     st.PushPathes  m_AppKey, m_Pathes\r
 856     Set Enable = st\r
 857   End Function\r
 858 End Class\r
 859 \r
 860 \r
 861  \r
 862 '********************************************************************************\r
 863 '  <<< [WritablesStack] Class >>> \r
 864 '********************************************************************************\r
 865 Class  WritablesStack\r
 866   Private  m_AppKey\r
 867   Private  m_Pathes\r
 868 \r
 869   Public Sub  PushPathes( AppKey, Pathes )\r
 870     Set m_Pathes = new ArrayClass : ErrCheck\r
 871     m_Pathes.Copy  Pathes\r
 872     Set  m_AppKey = AppKey\r
 873     g_CurrentWritables.PushPathes  AppKey, Pathes\r
 874   End Sub\r
 875 \r
 876   Private Sub Class_Terminate()\r
 877     g_CurrentWritables.PopPathes  m_AppKey, m_Pathes\r
 878   End Sub\r
 879 End Class\r
 880 \r
 881 \r
 882  \r
 883 '********************************************************************************\r
 884 '  <<< [CurrentWritables] Class >>> \r
 885 '********************************************************************************\r
 886 Class  CurrentWritables\r
 887   Private  m_PathesStack ' as ArrayClass of ArrayClass\r
 888 \r
 889   Private  m_ProgramFiles\r
 890   Private  m_windir\r
 891   Private  m_APPDATA\r
 892   Private  m_LOCALAPPDATA\r
 893 \r
 894   Public Property Get  CurrentPathes\r
 895     If m_PathesStack.Count > 0 Then\r
 896       CurrentPathes = m_PathesStack.m_Array( m_PathesStack.Count-1 ).m_Array\r
 897     Else\r
 898       CurrentPathes = m_PathesStack.m_Array\r
 899     End If\r
 900   End Property\r
 901   Public Property Get  PathesStack : Set PathesStack = m_PathesStack : End Property\r
 902 \r
 903 \r
 904   Private Sub Class_Initialize()\r
 905     Set  m_PathesStack = new ArrayClass : ErrCheck\r
 906 \r
 907     m_ProgramFiles = g_sh.ExpandEnvironmentStrings( "%ProgramFiles%" )\r
 908     m_windir       = g_sh.ExpandEnvironmentStrings( "%windir%" )\r
 909     m_APPDATA      = g_sh.ExpandEnvironmentStrings( "%APPDATA%" )\r
 910     m_LOCALAPPDATA = g_sh.ExpandEnvironmentStrings( "%LOCALAPPDATA%" )\r
 911 \r
 912     If m_ProgramFiles = "%ProgramFiles%" Then  m_ProgramFiles = Empty\r
 913     If m_windir       = "%windir%"       Then  m_windir       = Empty\r
 914     If m_APPDATA      = "%APPDATA%"      Then  m_APPDATA      = Empty\r
 915     If m_LOCALAPPDATA = "%LOCALAPPDATA%" Then  m_LOCALAPPDATA = Empty\r
 916   End Sub\r
 917 \r
 918 \r
 919   Public Sub  PushPathes( AppKey, Pathes )\r
 920     Dim  i\r
 921     If not g_AppKey.IsSame( AppKey ) Then  Err.Raise 1,,"Invalied AppKey"\r
 922     Dim  new_pathes : Set new_pathes = new ArrayClass : ErrCheck\r
 923     new_pathes.Copy  Pathes\r
 924     m_PathesStack.Push  new_pathes\r
 925   End Sub\r
 926 \r
 927 \r
 928   Public Sub  PopPathes( AppKey, Pathes )\r
 929     Dim  i,j\r
 930 \r
 931     If not g_AppKey.IsSame( AppKey ) Then  Err.Raise 1,,"Invalied AppKey"\r
 932 \r
 933     For i=m_PathesStack.Count-1 To 0 Step -1\r
 934       If Pathes.Count = m_PathesStack.m_Array(i).Count Then\r
 935         For j=0 To Pathes.Count-1\r
 936           If Pathes.m_Array(j) <> m_PathesStack.m_Array(i).m_Array(j) Then  Exit For\r
 937         Next\r
 938         If j = Pathes.Count Then  Exit For  '// If same all Pathes\r
 939       End If\r
 940     Next\r
 941     If i = -1 Then  Err.Raise 1\r
 942 \r
 943     For i=i To m_PathesStack.Count-2\r
 944       Set m_PathesStack.m_Array(i) = m_PathesStack.m_Array(i+1)\r
 945     Next\r
 946     m_PathesStack.Pop\r
 947   End Sub\r
 948 \r
 949 \r
 950   Public Function  CheckWritable( Path )\r
 951     Dim abs_path, writable, s\r
 952     abs_path = g_fs.GetAbsolutePathName( Path )\r
 953     If Right( Path, 2 ) = "\." Then  abs_path = abs_path + "\."\r
 954 \r
 955     For Each writable  In Me.CurrentPathes\r
 956       If StrComp( writable, Left( abs_path, Len( writable ) ), 1 ) = 0 Then  Exit Function\r
 957     Next\r
 958 \r
 959     s = abs_path + "\"\r
 960     For Each writable  In Me.CurrentPathes\r
 961       If StrComp( writable, s, 1 ) = 0 Then  Exit Function\r
 962     Next\r
 963 \r
 964     abs_path = g_AppKey.CheckNewWritable( abs_path )\r
 965     If IsEmpty( abs_path ) Then  Exit Function\r
 966 \r
 967     If Right( abs_path, 2 ) = "\." Then  abs_path = Left( abs_path, Len( abs_path ) - 2 )\r
 968     CheckWritable = abs_path\r
 969   End Function\r
 970 \r
 971 \r
 972   Public Function  CheckAddNewWritable( Path, out_PassedPath )\r
 973     Dim abs_path, writable\r
 974     abs_path = g_fs.GetAbsolutePathName( Path )\r
 975     If Right( Path, 2 ) = "\." Then  abs_path = abs_path + "\."\r
 976 \r
 977     If not exist( Path ) Then\r
 978      '// If the folder already exists, do not writable\r
 979 \r
 980       For Each writable  In Me.CurrentPathes\r
 981         If Right( writable, 3 ) = "\*\" Then\r
 982           If Left( writable, Len(writable) - 2 ) = Left( abs_path, Len( writable ) - 2 ) or _\r
 983              Left( writable, Len(writable) - 3 ) = abs_path Then\r
 984             out_PassedPath = Left( writable, Len(writable) - 3 )\r
 985             Exit Function\r
 986           End If\r
 987         End If\r
 988       Next\r
 989     End If\r
 990 \r
 991     If Right( abs_path, 2 ) = "\." Then  abs_path = Left( abs_path, Len( abs_path ) - 2 )\r
 992     CheckAddNewWritable = abs_path\r
 993   End Function\r
 994 \r
 995 \r
 996   Public Sub  AskFileAccess( AbsPath )\r
 997     If not IsEmpty( m_ProgramFiles ) Then _\r
 998       If Left( AbsPath, Len( m_ProgramFiles ) ) = m_ProgramFiles or _\r
 999          Left( m_ProgramFiles, Len( AbsPath ) ) = AbsPath Then _\r
1000         g_AppKey.Ask  AbsPath\r
1001 \r
1002     If not IsEmpty( m_windir ) Then _\r
1003       If Left( AbsPath, Len( m_windir ) ) = m_windir or _\r
1004          Left( m_windir, Len( AbsPath ) ) = AbsPath Then _\r
1005         g_AppKey.Ask  AbsPath\r
1006 \r
1007     If not IsEmpty( m_APPDATA ) Then _\r
1008       If Left( AbsPath, Len( m_APPDATA ) ) = m_APPDATA or _\r
1009          Left( m_APPDATA, Len( AbsPath ) ) = AbsPath Then _\r
1010         g_AppKey.Ask  AbsPath\r
1011 \r
1012     If not IsEmpty( m_LOCALAPPDATA ) Then _\r
1013       If Left( AbsPath, Len( m_LOCALAPPDATA ) ) = m_LOCALAPPDATA or _\r
1014          Left( m_LOCALAPPDATA, Len( AbsPath ) ) = AbsPath Then _\r
1015         g_AppKey.Ask  AbsPath\r
1016   End Sub\r
1017 \r
1018 End Class\r
1019 \r
1020 \r
1021  \r
1022 '********************************************************************************\r
1023 '  <<< [SetWritableMode] >>> \r
1024 '********************************************************************************\r
1025 Sub  SetWritableMode( Flags )\r
1026   g_AppKey.SetWritableMode  Flags\r
1027 End Sub\r
1028 \r
1029  \r
1030 '********************************************************************************\r
1031 '  <<< [CheckWritable] Check not to modify out of working folder >>> \r
1032 ' comment\r
1033 '  - If path is out of workfolder, raise error of E_OutOfWritable.\r
1034 '  - This function is overritable, because other APIs calling this and g_CurrentWritables\r
1035 '    can overrite.\r
1036 '********************************************************************************\r
1037 Sub  CheckWritable( Path )\r
1038   Dim  abs_path\r
1039 \r
1040   abs_path = g_CurrentWritables.CheckWritable( Path )\r
1041   If IsEmpty( abs_path ) Then  Exit Sub\r
1042   g_AppKey.Ask  abs_path\r
1043 End Sub\r
1044 \r
1045 \r
1046  \r
1047 '********************************************************************************\r
1048 '  <<< [set_workfolder] old function >>> \r
1049 '********************************************************************************\r
1050 Sub  set_workfolder( ByVal dir )\r
1051   If g_cut_old Then  Stop\r
1052 End Sub\r
1053 \r
1054 \r
1055 Class  WorkFolderStack\r
1056   Private Sub Class_Initialize()\r
1057     If g_cut_old Then  Stop\r
1058   End Sub\r
1059   Public Sub  set_( x ) : End Sub\r
1060 End Class\r
1061  \r
1062 '********************************************************************************\r
1063 '  <<< [SetBreakByFName] >>> \r
1064 '********************************************************************************\r
1065 Sub  SetBreakByFName( FName )\r
1066   g_AppKey.m_BreakByFName = FName\r
1067 End Sub\r
1068 \r
1069  \r
1070 '********************************************************************************\r
1071 '  <<< [cd] change current directory >>> \r
1072 ' sample\r
1073 '   cd "sub"\r
1074 '********************************************************************************\r
1075 Sub  cd( ByVal dir )\r
1076   echo  ">cd  """ & dir & """"\r
1077 \r
1078   Dim en,ed\r
1079 \r
1080   On Error Resume Next\r
1081     g_sh.CurrentDirectory = dir\r
1082   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1083   If en = E_WIN32_FILE_NOT_FOUND or en = E_WIN32_DIRECTORY Then _\r
1084     Err.Raise en,, "\83t\83H\83\8b\83_\82Å\82Í\82 \82è\82Ü\82¹\82ñ : " & dir\r
1085   If en <> 0 Then  Err.Raise en,,ed\r
1086 \r
1087 End Sub\r
1088 \r
1089 \r
1090  \r
1091 '********************************************************************************\r
1092 '  <<< [CurDirStack] >>> \r
1093 '********************************************************************************\r
1094 Class  CurDirStack\r
1095 \r
1096   Public  m_Prev\r
1097 \r
1098   Private Sub Class_Initialize\r
1099     m_Prev = g_sh.CurrentDirectory\r
1100   End Sub\r
1101 \r
1102   Private Sub Class_Terminate\r
1103     g_sh.CurrentDirectory = m_Prev\r
1104   End Sub\r
1105 End Class\r
1106 \r
1107 \r
1108  \r
1109 '********************************************************************************\r
1110 '  <<< [pushd] push and change current directory >>> \r
1111 ' sample\r
1112 '   pushd "sub"\r
1113 '********************************************************************************\r
1114 Dim  g_pushd_stack()\r
1115 Dim  g_pushd_stack_n\r
1116 \r
1117 Sub  pushd( ByVal dir )\r
1118   echo  ">pushd  " & dir\r
1119   Dim  sh\r
1120 \r
1121   g_pushd_stack_n = g_pushd_stack_n + 1\r
1122   Redim Preserve  g_pushd_stack( g_pushd_stack_n )\r
1123 \r
1124   Set sh = WScript.CreateObject("WScript.Shell")\r
1125   g_pushd_stack( g_pushd_stack_n ) = sh.CurrentDirectory\r
1126   sh.CurrentDirectory = dir\r
1127 \r
1128 End Sub\r
1129 \r
1130 \r
1131  \r
1132 '********************************************************************************\r
1133 '  <<< [popd] pop current directory >>> \r
1134 '********************************************************************************\r
1135 Sub  popd\r
1136   echo  ">popd"\r
1137   Dim  sh\r
1138 \r
1139   If g_pushd_stack_n < 1 Then Exit Sub\r
1140 \r
1141   Set sh = WScript.CreateObject("WScript.Shell")\r
1142   sh.CurrentDirectory = g_pushd_stack( g_pushd_stack_n )\r
1143 \r
1144   g_pushd_stack_n = g_pushd_stack_n - 1\r
1145 \r
1146 End Sub\r
1147 \r
1148 \r
1149  \r
1150 '********************************************************************************\r
1151 '  <<< [copy] >>> \r
1152 ' argument\r
1153 '  - src : source file or folder path or wild card\r
1154 '  - dst : destination folder path or renaming file path\r
1155 ' comment\r
1156 '  - reference: vbslib.svg#copy\r
1157 '********************************************************************************\r
1158 Sub  copy( ByVal src, ByVal dst )\r
1159   Dim en,ed\r
1160 \r
1161   ' If src had Wild card\r
1162   If IsWildcard( src ) Then\r
1163 \r
1164     Dim  fo\r
1165 \r
1166     echo  ">copy  """ & src & """, """ & dst & """"\r
1167     If Not g_fs.FolderExists( dst ) Then  Set en=new EchoOff : mkdir dst : en=Empty\r
1168     If Not g_fs.FolderExists( GetParentAbsPath( src ) ) Then _\r
1169       Err.Raise  E_PathNotFound,,"\83p\83X\82ª\8c©\82Â\82©\82è\82Ü\82¹\82ñ\81B"\r
1170 \r
1171     g_AppKey.AddNewWritableFolder  dst + "\."  '// "\." is for able to make writable folder\r
1172     If g_debug_or_test Then  g_AppKey.BreakByWildcard  src, F_File\r
1173 \r
1174     On Error Resume Next\r
1175       g_fs.CopyFile  src, dst, True\r
1176     en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1177     If en = E_FileNotExist Then  en = 0\r
1178     If en <> 0 Then  Err.Raise en,,ed\r
1179 \r
1180     Dim  i_retry  '// 1\89ñ\96Ú\82É E_WriteAccessDenied \82É\82È\82é\82±\82Æ\82ª\82½\82Ü\82É\82 \82é\82½\82ß\r
1181     For  i_retry = 1  To  2\r
1182       On Error Resume Next\r
1183         g_fs.CopyFolder  src, dst, True\r
1184       en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1185       If en = E_PathNotFound Then  en = 0\r
1186       If i_retry >= 2  and  en <> E_WriteAccessDenied Then\r
1187         If en <> 0 Then  Err.Raise en,,ed\r
1188       End If\r
1189       If en = 0 Then  Exit For\r
1190 \r
1191       echo_r  "<WARNING msg='" & ed & "' msg2='\8dÄ\8e\8e\8ds\82µ\82Ä\82¢\82Ü\82·'/>", ""\r
1192       Sleep  g_FileSystemRetryMSec\r
1193     Next\r
1194 \r
1195   ' If src is file\r
1196   ElseIf g_fs.FileExists( src ) Then\r
1197 \r
1198     Dim  dst_fo\r
1199 \r
1200     If g_fs.FolderExists( dst ) Then\r
1201       dst = g_fs.BuildPath( dst, g_fs.GetFileName( src ) )\r
1202     Else\r
1203       dst_fo = GetParentAbsPath( dst )\r
1204       If dst_fo <> "" And Not g_fs.FolderExists( dst_fo ) Then _\r
1205         Set en=new EchoOff : mkdir  dst_fo : en=Empty\r
1206     End If\r
1207 \r
1208     echo  ">copy  """ & src & """, """ & dst & """"\r
1209     If  not g_fs.FileExists( dst ) Then\r
1210       g_AppKey.AddNewWritableFolder  dst + "\."  '// "\." is for able to make writable folder\r
1211     Else\r
1212       g_AppKey.AddNewWritableFolder  dst\r
1213     End If\r
1214 \r
1215     On Error Resume Next\r
1216       g_fs.CopyFile  src, dst, True\r
1217     en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1218     If en = 70 Then  ed = ed + " : " + dst\r
1219     If en <> 0 Then  Err.Raise en,,ed\r
1220 \r
1221 \r
1222   ' If src is folder\r
1223   ElseIf g_fs.FolderExists( src ) Then\r
1224 \r
1225     If Not g_fs.FolderExists( dst ) Then  Set en=new EchoOff : mkdir dst : en=Empty\r
1226 \r
1227     echo  ">copy  """ & src & """, """ & dst & """"\r
1228     g_AppKey.AddNewWritableFolder  dst\r
1229     If g_debug_or_test Then  g_AppKey.BreakByWildcard  src+"\*", F_File or F_SubFolder\r
1230 \r
1231     g_fs.CopyFolder src, g_fs.BuildPath( dst, g_fs.GetFileName( src ) ), True\r
1232 \r
1233 \r
1234   ' not found\r
1235   Else\r
1236     echo  ">copy  """ & src & """, """ & dst & """"\r
1237     g_AppKey.AddNewWritableFolder  dst + "\."  '// "\." is for able to make writable folder\r
1238     g_fs.CopyFile  src, dst, True  ' Error occurs\r
1239 \r
1240   End If\r
1241 End Sub\r
1242 \r
1243 \r
1244  \r
1245 '********************************************************************************\r
1246 '  <<< [move] >>> \r
1247 '********************************************************************************\r
1248 Sub  move( ByVal src, ByVal dst )\r
1249 \r
1250   ' If src had Wild card\r
1251   If IsWildcard( src ) Then\r
1252 \r
1253     Dim  fo,en,ed\r
1254 \r
1255     If Not g_fs.FolderExists( dst ) Then  mkdir dst\r
1256     echo  ">move  """ & src & """, """ & dst & """"\r
1257     If Not g_fs.FolderExists( g_fs.GetParentFolderName( src ) ) Then _\r
1258       Err.Raise  E_PathNotFound,,"\83p\83X\82ª\8c©\82Â\82©\82è\82Ü\82¹\82ñ\81B"\r
1259 \r
1260     g_AppKey.AddNewWritableFolder  dst + "\."  '// "\." is for able to make writable folder\r
1261     If g_debug_or_test Then  g_AppKey.BreakByWildcard  src, F_File\r
1262 \r
1263     On Error Resume Next\r
1264       g_fs.MoveFile  src, dst\r
1265       g_fs.MoveFolder  src, dst\r
1266     en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1267     If en = E_PathNotFound Then  en = 0\r
1268     If en = E_FileNotExist Then  en = 0\r
1269     If en <> 0 Then  Err.Raise en,,ed\r
1270 \r
1271 \r
1272   ' If src is file\r
1273   ElseIf g_fs.FileExists( src ) Then\r
1274 \r
1275     Dim  dst_fo\r
1276 \r
1277     If g_fs.FolderExists( dst ) Then\r
1278       dst = g_fs.BuildPath( dst, g_fs.GetFileName( src ) )\r
1279     Else\r
1280       dst_fo = g_fs.GetParentFolderName( dst )\r
1281       If Not g_fs.FolderExists( dst_fo ) Then  mkdir  dst_fo\r
1282     End If\r
1283 \r
1284     echo  ">move  """ & src & """, """ & dst & """"\r
1285     If IsWildcard( src ) or not g_fs.FileExists( dst ) Then\r
1286       g_AppKey.AddNewWritableFolder  dst + "\."  '// "\." is for able to make writable folder\r
1287     Else\r
1288       g_AppKey.AddNewWritableFolder  dst\r
1289     End If\r
1290 \r
1291     g_fs.MoveFile  src, dst\r
1292 \r
1293 \r
1294   ' If src is folder\r
1295   ElseIf g_fs.FolderExists( src ) Then\r
1296 \r
1297     If Not g_fs.FolderExists( dst ) Then  mkdir  dst\r
1298 \r
1299     echo  ">move  """ & src & """, """ & dst & """"\r
1300     g_AppKey.AddNewWritableFolder  dst\r
1301     If g_debug_or_test Then  g_AppKey.BreakByWildcard  src+"\*", F_File or F_SubFolder\r
1302 \r
1303     g_fs.MoveFolder src, g_fs.BuildPath( dst, g_fs.GetFileName( src ) )\r
1304 \r
1305 \r
1306   ' not found\r
1307   Else\r
1308     echo  ">move  """ & src & """, """ & dst & """"\r
1309     g_AppKey.AddNewWritableFolder  dst + "\."  '// "\." is for able to make writable folder\r
1310     g_fs.MoveFile  src, dst  ' Error occurs\r
1311 \r
1312   End If\r
1313 End Sub\r
1314 \r
1315 \r
1316  \r
1317 '********************************************************************************\r
1318 '  <<< [ren] >>> \r
1319 '********************************************************************************\r
1320 Sub  ren( src, dst )\r
1321  echo  ">ren  """ & src & """, """ & dst & """"\r
1322   Dim  f\r
1323 \r
1324   If g_fs.FileExists( src ) Then\r
1325     g_AppKey.AddNewWritableFolder  src\r
1326     Set f = g_fs.GetFile( src )\r
1327     f.Name = g_fs.GetFileName( dst )\r
1328   Else\r
1329     g_AppKey.AddNewWritableFolder  src + "\."  '// "\." is for able to make writable folder\r
1330     Set f = g_fs.GetFolder( src )\r
1331     f.Name = g_fs.GetFileName( dst )\r
1332   End If\r
1333 End Sub\r
1334 \r
1335 \r
1336  \r
1337 '********************************************************************************\r
1338 '  <<< [SafeFileUpdate] >>> \r
1339 '********************************************************************************\r
1340 Sub  SafeFileUpdate( FromTmpFilePath, ToUpdateFilePath )\r
1341   echo  ">SafeFileUpdate  """ & FromTmpFilePath & """, """ & ToUpdateFilePath & """"\r
1342   Dim en,ed,en2,ed2,i,path\r
1343 \r
1344   For i=1 To 999\r
1345     path = g_fs.GetParentFolderName( ToUpdateFilePath ) + "\" + _\r
1346            g_fs.GetBaseName( ToUpdateFilePath ) + "." & i & "." + g_fs.GetExtensionName( ToUpdateFilePath )\r
1347     If not exist( path ) Then  Exit For\r
1348   Next\r
1349   If exist( path ) Then  Err.Raise E_Other,,"\83o\83b\83N\83A\83b\83v\82Ì\83t\83@\83C\83\8b\96¼\82ª\8dì\82ê\82Ü\82¹\82ñ\81B\81F" + ToUpdateFilePath\r
1350 \r
1351   On Error Resume Next\r
1352     g_fs.CopyFile  ToUpdateFilePath, path, False\r
1353   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1354   If en <> 0 Then  Err.Raise en,,"\83o\83b\83N\83A\83b\83v\83R\83s\81[\82É\8e¸\94s\82µ\82Ü\82µ\82½\81B"+vbCR+vbLF+_\r
1355      "\83o\83b\83N\83A\83b\83v\8c³\81F"+ToUpdateFilePath+vbCR+vbLF+ "\83o\83b\83N\83A\83b\83v\90æ\81F"+path+vbCR+vbLF+ ed\r
1356 \r
1357   del_to_trashbox  path\r
1358 \r
1359   On Error Resume Next\r
1360     g_fs.CopyFile  FromTmpFilePath, ToUpdateFilePath, True\r
1361   en2 = Err.Number : ed2 = Err.Description : On Error GoTo 0\r
1362 \r
1363   On Error Resume Next\r
1364     g_fs.DeleteFile  FromTmpFilePath\r
1365   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1366 \r
1367   If en2 <> 0 Then  Err.Raise en2,,"\8fã\8f\91\82«\83R\83s\81[\82É\8e¸\94s\82µ\82Ü\82µ\82½\81B\83S\83~\94 \82É\93ü\82ê\82½\8c³\82Ì\83t\83@\83C\83\8b\82ð\95\9c\8a\88\82³\82¹\82Ä\82\82¾\82³\82¢\81B"+vbCR+vbLF+_\r
1368      "\83R\83s\81[\8c³\81F"+FromTmpFilePath+vbCR+vbLF+ "\83R\83s\81[\90æ\81F"+ToUpdateFilePath+vbCR+vbLF+ ed2\r
1369 \r
1370   If en <> 0 Then  WScript.Echo "\8dX\90V\82Í\90¬\8c÷\82µ\82Ü\82µ\82½\82ª\81A\88ê\8e\9e\83t\83@\83C\83\8b\82Ì\8dí\8f\9c\82É\8e¸\94s\82µ\82Ü\82µ\82½\81B"+vbCR+vbLF+_\r
1371      "\88ê\8e\9e\83t\83@\83C\83\8b\81F"+FromTmpFilePath+vbCR+vbLF+ "\8dX\90V\8dÏ\82Ý\83t\83@\83C\83\8b\81F"+ToUpdateFilePath+vbCR+vbLF+ ed\r
1372 \r
1373 End Sub\r
1374 \r
1375 \r
1376  \r
1377 '********************************************************************************\r
1378 '  <<< [del] >>> \r
1379 '********************************************************************************\r
1380 Sub  del( ByVal path )\r
1381   echo  ">del  """ & path & """"\r
1382   Dim  ec : Set ec = new EchoOff\r
1383 \r
1384   ' If path had Wild card\r
1385   If IsWildCard( path ) Then\r
1386     Dim  folder, fname, fnames()\r
1387 \r
1388     ExpandWildcard  path, F_File, folder, fnames\r
1389     For Each fname in fnames\r
1390       del  g_fs.BuildPath( folder, fname )\r
1391     Next\r
1392 \r
1393     ExpandWildcard  path, F_Folder, folder, fnames\r
1394     For Each fname in fnames\r
1395       del  g_fs.BuildPath( folder, fname )\r
1396     Next\r
1397 \r
1398   ' If path was file or folder path\r
1399   Else\r
1400 \r
1401     If g_fs.FileExists( path ) Then\r
1402       g_AppKey.AddNewWritableFolder  path\r
1403       g_fs.DeleteFile  path\r
1404     ElseIf g_fs.FolderExists( path ) Then\r
1405       rmdir  path\r
1406     End If\r
1407   End If\r
1408 \r
1409 End Sub\r
1410 \r
1411 \r
1412  \r
1413 '********************************************************************************\r
1414 '  <<< [del_subfolder] >>> \r
1415 '********************************************************************************\r
1416 Sub  del_subfolder( ByVal path )\r
1417   echo  ">del_subfolder  """ & path & """"\r
1418   Dim  folder, fname, fnames()\r
1419 \r
1420   ExpandWildcard  path, F_File Or F_SubFolder, folder, fnames\r
1421   For Each fname in fnames\r
1422     del  g_fs.BuildPath( folder, fname )\r
1423   Next\r
1424 \r
1425   ExpandWildcard  path, F_Folder Or F_SubFolder, folder, fnames\r
1426   For Each fname in fnames\r
1427     del  g_fs.BuildPath( folder, fname )\r
1428   Next\r
1429 End Sub\r
1430 \r
1431 \r
1432  \r
1433 '********************************************************************************\r
1434 '  <<< [del_to_trashbox] >>> \r
1435 '********************************************************************************\r
1436 Sub  del_to_trashbox( ByVal path )\r
1437   echo  ">del_to_trashbox  """ & path & """"\r
1438   Dim en,ed\r
1439   Dim  sh_ap, TrashBox, folder, item, fname\r
1440   Set  sh_ap = CreateObject("Shell.Application")\r
1441   Const  ssfBITBUCKET = 10\r
1442 \r
1443   g_AppKey.AddNewWritableFolder  path + "\."  '// "\." is for able to make writable folder\r
1444 \r
1445 \r
1446   '//=== Check deletable by rename for Windows XP\r
1447   On Error Resume Next\r
1448     ren  path, g_fs.GetFileName( path ) + "_deleting"\r
1449   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1450   If en = 70 Then  Err.Raise 17,,"\83S\83~\94 \82Ö\88Ú\93®\82Å\82«\82Ü\82¹\82ñ : " + path\r
1451   If en = 76 Then  Exit Sub  ' not found path\r
1452   If en <> 0 Then  Err.Raise en,,ed\r
1453   On Error Resume Next\r
1454     ren  path + "_deleting", g_fs.GetFileName( path )\r
1455   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1456   If en <> 0 and en <> E_OutOfWritable Then  Err.Raise en,,ed\r
1457 \r
1458 \r
1459   '//=== move to trashbox\r
1460   path = g_fs.GetAbsolutePathName( path )\r
1461   fname = g_fs.GetFileName( path )\r
1462   Set  folder = sh_ap.NameSpace( g_fs.GetParentFolderName( path ) )\r
1463   If folder is Nothing Then  Exit Sub\r
1464   Set  item = folder.Items.Item( fname )\r
1465   If item is Nothing Then  Exit Sub\r
1466 \r
1467   Set  TrashBox = sh_ap.NameSpace( ssfBITBUCKET )\r
1468   TrashBox.MoveHere  item\r
1469 \r
1470 \r
1471   '//=== for Windows Vista\r
1472   ' If exist( path ) Then  Err.Raise 17,,"\83S\83~\94 \82Ö\88Ú\93®\82Å\82«\82Ü\82¹\82ñ : " + path\r
1473 \r
1474 \r
1475   '//=== for Windows XP\r
1476   Do\r
1477     WScript.Sleep 300\r
1478     Set  item = folder.Items.Item( fname )\r
1479     If item is Nothing Then Exit Do\r
1480     item = Empty\r
1481   Loop\r
1482 End Sub\r
1483 \r
1484 \r
1485  \r
1486 '********************************************************************************\r
1487 '  <<< [del_confirmed] >>> \r
1488 '********************************************************************************\r
1489 Function  del_confirmed( Path )\r
1490   echo  ">del_confirmed  """ & Path & """"\r
1491   If exist( Path ) Then\r
1492     Dim  r : r = input( "\8dí\8f\9c\82µ\82Ä\82æ\82ë\82µ\82¢\82Å\82·\82©\81H : " + Path + " (Y/N)" )\r
1493     del_confirmed = ( r="Y" or r="y" )\r
1494     If del_confirmed Then  del  Path\r
1495   Else\r
1496     del_confirmed = True\r
1497   End If\r
1498 End Function\r
1499 \r
1500 \r
1501  \r
1502 '********************************************************************************\r
1503 '  <<< [mkdir] >>> \r
1504 '********************************************************************************\r
1505 Function  mkdir( ByVal Path )\r
1506   echo  ">mkdir  """ & Path & """"\r
1507   Dim  i, n, names(), fo2\r
1508 \r
1509   g_AppKey.AddNewWritableFolder  Path + "\."\r
1510 \r
1511   If g_fs.FolderExists( Path ) Then  mkdir = 0 : Exit Function\r
1512 \r
1513   n = 0\r
1514   fo2 = g_fs.GetAbsolutePathName( Path )\r
1515   Do\r
1516     If g_fs.FolderExists( fo2 ) Then Exit Do\r
1517 \r
1518     n = n + 1\r
1519     Redim Preserve  names(n)\r
1520     names(n) = g_fs.GetFileName( fo2 )\r
1521     fo2 = g_fs.GetParentFolderName( fo2 )\r
1522   Loop\r
1523 \r
1524   mkdir = n\r
1525 \r
1526   For n=n To 1 Step -1\r
1527     fo2 = g_fs.BuildPath( fo2, names(n) )\r
1528     g_fs.CreateFolder  fo2\r
1529   Next\r
1530 \r
1531 End Function\r
1532 \r
1533 \r
1534  \r
1535 '********************************************************************************\r
1536 '  <<< [mkdir_for] >>> \r
1537 '********************************************************************************\r
1538 Sub  mkdir_for( Path )\r
1539   Dim  s\r
1540 \r
1541   s = g_fs.GetParentFolderName( Path )\r
1542   If s = "" Then  Exit Sub\r
1543   mkdir  s\r
1544 End Sub\r
1545 \r
1546 \r
1547  \r
1548 '********************************************************************************\r
1549 '  <<< [rmdir] >>> \r
1550 '********************************************************************************\r
1551 Sub  rmdir( ByVal Path )\r
1552   echo  ">rmdir  """ & Path & """"\r
1553   Dim  path2, iFolder, nFolder, fo, subf, f, file\r
1554 \r
1555   If Not g_fs.FolderExists( Path ) Then Exit Sub\r
1556   g_AppKey.AddNewWritableFolder  Path + "\."  '// "\." is for able to make writable folder\r
1557 \r
1558 \r
1559   ' Cut last \\r
1560   path2 = Path\r
1561   If Right( path2, 1 ) = "\" Then  path2 = Left( path2, Len( path2 ) - 1 )\r
1562 \r
1563   nFolder = 1\r
1564   ReDim folderPathes(nFolder)\r
1565   folderPathes(nFolder) = path2\r
1566 \r
1567   ' Enum sub folders\r
1568   iFolder = 1\r
1569   While iFolder <= nFolder\r
1570     Set fo = g_fs.GetFolder( folderPathes(iFolder) )\r
1571     For Each subf in fo.SubFolders\r
1572       nFolder = nFolder + 1\r
1573       ReDim Preserve folderPathes(nFolder)\r
1574       folderPathes(nFolder) = subf.Path\r
1575     Next\r
1576     iFolder = iFolder + 1\r
1577   WEnd\r
1578 \r
1579   ' Remove read only attribute of all files in sub folders\r
1580   For iFolder = 1 To nFolder\r
1581     Set fo = g_fs.GetFolder( folderPathes(iFolder) )\r
1582     For Each f in fo.Files\r
1583       Set file = g_fs.GetFile( f.Path )\r
1584       If g_debug_or_test Then  g_AppKey.BreakByPath( f.Path )\r
1585       file.Attributes = file.Attributes And Not ReadOnly\r
1586     Next\r
1587   Next\r
1588 \r
1589   ' Delete folders\r
1590   Dim en,ed\r
1591   Dim  i_retry  '// 1\89ñ\96Ú\82É E_WriteAccessDenied \82É\82È\82é\82±\82Æ\82ª\82½\82Ü\82É\82 \82é\82½\82ß\r
1592   For  i_retry = 1  To  2\r
1593     On Error Resume Next\r
1594       g_fs.DeleteFolder( Path )\r
1595     en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1596     If i_retry >= 2  and  en <> E_WriteAccessDenied Then\r
1597       If en = E_WriteAccessDenied Then ed = "Denied to delete the folder: "+ Path\r
1598       If en <> 0 Then  Err.Raise en,,ed\r
1599     End If\r
1600     If en = 0 Then  Exit For\r
1601 \r
1602     echo_r  "<WARNING msg='" & ed & "' msg2='\8dÄ\8e\8e\8ds\82µ\82Ä\82¢\82Ü\82·'/>", ""\r
1603     Sleep  g_FileSystemRetryMSec\r
1604   Next\r
1605 End Sub\r
1606 \r
1607 \r
1608  \r
1609 '********************************************************************************\r
1610 '  <<< [exist] >>> \r
1611 '********************************************************************************\r
1612 Function  exist( ByVal path )\r
1613   If IsWildcard( path ) Then\r
1614     Dim  folder, fnames()\r
1615     ExpandWildcard  path, F_File or F_Folder, folder, fnames\r
1616     exist = UBound( fnames ) <> -1\r
1617   Else\r
1618     exist = ( g_fs.FileExists( path ) = True ) Or ( g_fs.FolderExists( path ) = True )\r
1619   End If\r
1620 End Function\r
1621 \r
1622 \r
1623  \r
1624 '********************************************************************************\r
1625 '  <<< [fc] file compare as binary >>> \r
1626 ' argument\r
1627 '  - return : True=same, False=different\r
1628 '********************************************************************************\r
1629 Function  fc( path_a, path_b )\r
1630   fc = fc_r( path_a, path_b, "" )\r
1631 End Function\r
1632 \r
1633 \r
1634  \r
1635 '********************************************************************************\r
1636 '  <<< [fc_r] file compare as binary >>> \r
1637 ' argument\r
1638 '  - return : True=same, False=different\r
1639 '********************************************************************************\r
1640 Function  fc_r( path_a, path_b, redirect_path )\r
1641   Dim  opt : Set opt = new fc_option : ErrCheck\r
1642 \r
1643   opt.m_RedirectPath = redirect_path\r
1644   fc_r = fc_ex( path_a, path_b, opt )\r
1645 End Function\r
1646 \r
1647  \r
1648 '********************************************************************************\r
1649 '  <<< [fc_ex] file compare as binary >>> \r
1650 '********************************************************************************\r
1651 Function  fc_ex( PathA, PathB, Opt )\r
1652   Dim  cmdline, opt_echo, redirect_path, b_stdout\r
1653   Dim  s, b\r
1654 \r
1655 \r
1656   '//=== set cmdline from Opt.m_IniPath\r
1657   cmdline = """" + g_vbslib_ver_folder + "feq.exe"""\r
1658   If not IsEmpty( Opt ) Then\r
1659     If not IsEmpty( Opt.m_IniPath ) Then\r
1660       cmdline = cmdline + " /ini:""" + Opt.m_IniPath + """"\r
1661       opt_echo = " /ini:" + g_fs.GetFileName( Opt.m_IniPath )\r
1662     End If\r
1663   End If\r
1664   cmdline = cmdline + " """ + PathA + """ """ + PathB + """"\r
1665 \r
1666 \r
1667   '//=== set redirect_path from Opt.m_RedirectPath\r
1668   If not IsEmpty( Opt ) Then\r
1669     redirect_path = Opt.m_RedirectPath\r
1670     b_stdout = Opt.m_bStdOut\r
1671   End If\r
1672 \r
1673 \r
1674   '//=== echo\r
1675   b = True : If Not IsEmpty( Opt ) Then  b = (Opt.m_RedirectPath = "")\r
1676   If b Then '// IsEmpty or\r
1677     echo  ">fc " + opt_echo + " """ + PathA + """ """ + PathB + """"\r
1678   Else\r
1679     Dim f : Set f = g_fs.OpenTextFile( redirect_path, 8, True, False )\r
1680     f.WriteLine  ">fc " + opt_echo + " """ + PathA + """ """ + PathB + """"\r
1681     f = Empty\r
1682   End If\r
1683 \r
1684 \r
1685   '//=== Exec\r
1686   Dim  ex\r
1687   chk_exist_in_lib  "feq.exe"\r
1688   Set  ex = g_sh.Exec( cmdline )\r
1689   If not IsEmpty( redirect_path ) Then  redirect_path = g_sh.ExpandEnvironmentStrings( redirect_path )\r
1690   fc_ex = ( WaitForFinishAndRedirect( ex, redirect_path ) = 0 )\r
1691 End Function\r
1692 \r
1693 \r
1694  \r
1695 '********************************************************************************\r
1696 '  <<< [fc_option] >>> \r
1697 '********************************************************************************\r
1698 Class  fc_option\r
1699   Public  m_IniPath\r
1700   Public  m_RedirectPath\r
1701   Public  m_bStdOut\r
1702 End Class\r
1703 \r
1704 \r
1705  \r
1706 '********************************************************************************\r
1707 '  <<< [find] find lines including keyword >>> \r
1708 '********************************************************************************\r
1709 Function  find( ByVal keyword, ByVal path )\r
1710   Dim  f, line, ret\r
1711   Set  f = g_fs.OpenTextFile( path )\r
1712 \r
1713   ret = ""\r
1714   Do Until f.AtEndOfStream\r
1715     line = f.ReadLine\r
1716     If InStr( line, keyword ) > 0 Then  ret = ret + line\r
1717   Loop\r
1718 \r
1719   f.Close\r
1720 \r
1721   find = ret\r
1722 End Function\r
1723 \r
1724 \r
1725  \r
1726 '********************************************************************************\r
1727 '  <<< [find_c] find lines count including keyword >>> \r
1728 '********************************************************************************\r
1729 Function  find_c( ByVal keyword, ByVal path )\r
1730   Dim  f, line, ret\r
1731   Set  f = g_fs.OpenTextFile( path )\r
1732 \r
1733   ret = 0\r
1734   Do Until f.AtEndOfStream\r
1735     line = f.ReadLine\r
1736     If InStr( line, keyword ) > 0 Then  ret = ret + 1\r
1737   Loop\r
1738 \r
1739   f.Close\r
1740 \r
1741   find_c = ret\r
1742 End Function\r
1743 \r
1744 \r
1745  \r
1746 '********************************************************************************\r
1747 '  <<< [grep] >>> \r
1748 '********************************************************************************\r
1749 Sub  grep( Keyword, FolderPath, OutFName, Opt )\r
1750   Dim  ds_:Set ds_= New CurDirStack : ErrCheck\r
1751   del  "_grep_out.txt"\r
1752   cd  FolderPath\r
1753   del  "_grep_out.txt"\r
1754   RunProg  "cmd /C for /R %i in (*) do find """ + Keyword + """ ""%i"" >> _grep_out.txt", ""\r
1755   ds_= Empty\r
1756   move   FolderPath + "\_grep_out.txt", "."\r
1757   If OutFName <> "_grep_out.txt" Then  ren "_grep_out.txt", OutFName\r
1758 End Sub\r
1759 \r
1760 \r
1761  \r
1762 '********************************************************************************\r
1763 '  <<< [sort] >>> \r
1764 '********************************************************************************\r
1765 Sub  sort( InPath, OutPath )\r
1766   RunProg  "cmd /C sort """ + InPath + """ /o """ + OutPath + """", ""\r
1767 End Sub\r
1768 \r
1769 \r
1770  \r
1771 '********************************************************************************\r
1772 '  <<< [CreateFile] Create 1 line text file >>> \r
1773 '********************************************************************************\r
1774 Function  CreateFile( ByVal Path, ByVal Text )\r
1775   Dim  t, folder\r
1776 \r
1777   t = InStr( Text, vbCRLF )\r
1778   If t = 0 Then  t = Text+""""  Else  t = Left( Text, t-1 ) + """+vbCRLF+..."\r
1779   echo  ">CreateFile  """ & Path & """, """ & t\r
1780 \r
1781   If IsWildcard( Path ) Then  Path = GetTempPath( Path ) : echo  "Create  """ & Path & """"\r
1782 \r
1783   Dim  ec : Set ec = new EchoOff : ErrCheck\r
1784 \r
1785   g_AppKey.AddNewWritableFolder  Path\r
1786 \r
1787   Path = g_fs.GetAbsolutePathName( Path )\r
1788   folder = g_fs.GetParentFolderName( Path )\r
1789   mkdir  folder\r
1790 \r
1791   Set t = g_fs.CreateTextFile( Path, True, (g_TextFileCreateFormat = F_Unicode) )\r
1792   t.Write  Text\r
1793   t.Close\r
1794 \r
1795   CreateFile = Path\r
1796 End Function\r
1797 \r
1798 \r
1799  \r
1800 '********************************************************************************\r
1801 '  <<< [ReadFile] >>> \r
1802 '********************************************************************************\r
1803 Function  ReadFile( Path )\r
1804   Dim  f, en, ed\r
1805 \r
1806   ReadFile = ""\r
1807 \r
1808   On Error Resume Next\r
1809     Set f = g_fs.OpenTextFile( Path, 1, False, -2 )\r
1810   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1811   If en = E_FileNotExist  Then  Exit Function\r
1812   If en <> 0 Then  Err.Raise en,,ed\r
1813 \r
1814   ReadFile = ReadAll( f )\r
1815 End Function\r
1816 \r
1817 \r
1818  \r
1819 '********************************************************************************\r
1820 '  <<< [type_] >>> \r
1821 '********************************************************************************\r
1822 Sub  type_( Path )\r
1823   echo  ">type_  """ & Path & """"\r
1824   echo  ReadFile( Path )\r
1825 End Sub\r
1826 \r
1827 \r
1828  \r
1829 '********************************************************************************\r
1830 '  <<< [OpenForRead] >>> \r
1831 '********************************************************************************\r
1832 Function  OpenForRead( Path )\r
1833   echo  ">OpenForRead  """ & Path & """"\r
1834   Dim  en, ed\r
1835 \r
1836   On Error Resume Next\r
1837     Set OpenForRead = g_fs.OpenTextFile( Path,,,-2 )\r
1838   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1839   If en = E_FileNotExist or en = E_PathNotFound Then  Err.raise  en,,ed+" : "+Path\r
1840   If en <> 0 Then  Err.Raise en,,ed\r
1841 End Function\r
1842 \r
1843 \r
1844  \r
1845 '********************************************************************************\r
1846 '  <<< [OpenForWrite] >>> \r
1847 '********************************************************************************\r
1848 Const  F_Shift_JIS = &h1000\r
1849 Const  F_Unicode   = 2\r
1850 Const  F_Append    = 4\r
1851 \r
1852 Function  OpenForWrite( ByVal Path, Flags )\r
1853   echo  ">OpenForWrite  """ & Path & """"\r
1854   Dim  en, ed\r
1855   Dim  bUnicode : bUnicode = ((Flags and F_Unicode) = F_Unicode)\r
1856   Dim  bAppend  : bAppend  = ((Flags and F_Append)  = F_Append)\r
1857   If ( Flags and (F_Shift_JIS or F_Unicode) ) = 0 Then _\r
1858     bUnicode = (g_TextFileCreateFormat = F_Unicode)\r
1859 \r
1860   If IsWildcard( Path ) Then  Path = GetTempPath( Path ) : echo  "Create  """ & Path & """"\r
1861 \r
1862   g_AppKey.AddNewWritableFolder  Path\r
1863 \r
1864   On Error Resume Next\r
1865     If bAppend Then\r
1866       Set OpenForWrite = g_fs.OpenTextFile( Path, 8, True, -2 )\r
1867     Else\r
1868       Set OpenForWrite = g_fs.CreateTextFile( Path, True,  bUnicode )\r
1869     End If\r
1870   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1871 \r
1872   If en = E_PathNotFound Then\r
1873     Dim  fo : fo = g_fs.GetParentFolderName( Path )\r
1874     If not g_fs.FolderExists( fo ) Then\r
1875       mkdir  fo\r
1876       On Error Resume Next\r
1877         Set OpenForWrite = g_fs.CreateTextFile( Path, True, bUnicode )\r
1878       en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1879     End If\r
1880   End If\r
1881   If en <> 0 Then  Err.Raise en,,ed\r
1882 End Function\r
1883 \r
1884 \r
1885  \r
1886 '********************************************************************************\r
1887 '  <<< [GetTempPath] >>> \r
1888 '********************************************************************************\r
1889 Class  TempFileClass\r
1890   Public  m_FolderPath\r
1891   Public  m_LimitDate\r
1892 End Class\r
1893 \r
1894 Dim  g_TempFile\r
1895 \r
1896 \r
1897 Function  GetTempPath( Param )\r
1898   Dim  param_abs, path, t, i, fo, f\r
1899 \r
1900   GetObject_g_TempFile\r
1901 \r
1902   '//=== Delete old files\r
1903   g_AppKey.AddNewWritableFolder  g_TempFile.m_FolderPath + "\."\r
1904   If not g_fs.FolderExists( g_TempFile.m_FolderPath ) Then _\r
1905     mkdir  g_TempFile.m_FolderPath\r
1906 \r
1907   Set fo = g_fs.GetFolder( g_TempFile.m_FolderPath )\r
1908   For Each f in fo.Files\r
1909     If f.DateLastModified < g_TempFile.m_LimitDate Then\r
1910       g_fs.DeleteFile  f.Path\r
1911     End If\r
1912   Next\r
1913   For Each f in fo.SubFolders\r
1914     If f.DateLastModified < g_TempFile.m_LimitDate Then\r
1915       g_fs.DeleteFolder  f.Path\r
1916     End If\r
1917   Next\r
1918 \r
1919 \r
1920   '//=== path : Make unique path\r
1921   t = Now()\r
1922   param_abs = GetAbsPath( Param, g_TempFile.m_FolderPath +"\"+ _\r
1923     Right( "0" & (Year(t) mod 100), 2 ) & _\r
1924     Right( "0" & Month(t), 2 )  &  Right( "0" & Day(t), 2 ) )\r
1925 \r
1926   t = Right( "0" & (Year(t) mod 100), 2 ) & _\r
1927     Right( "0" & Month(t), 2 )  &  Right( "0" & Day(t), 2 ) & "_" & _\r
1928     Right( "0" & Hour(t), 2 )  &  Right( "0" & Minute(t), 2 ) & "_"\r
1929   i = 1\r
1930   Do\r
1931     path = Replace( param_abs, "*", t & i )\r
1932     If not exist( path ) Then  Exit Do\r
1933     i = i + 1\r
1934     If InStr( param_abs, "*" ) = 0 Then Exit Do\r
1935   Loop\r
1936   GetTempPath = path\r
1937 End Function\r
1938 \r
1939 \r
1940  \r
1941 '********************************************************************************\r
1942 '  <<< [GetObject_g_TempFile] >>> \r
1943 '********************************************************************************\r
1944 Sub  GetObject_g_TempFile()\r
1945   If IsEmpty( g_TempFile ) Then\r
1946     Set g_TempFile = new TempFileClass : ErrCheck\r
1947     If IsDefined( "Setting_getTemp" ) Then\r
1948       Dim  out1, out2\r
1949       Setting_getTemp  out1, out2\r
1950       g_TempFile.m_FolderPath = out1\r
1951       g_TempFile.m_LimitDate = out2\r
1952     End If\r
1953 \r
1954     If IsEmpty( g_TempFile.m_FolderPath ) Then _\r
1955       g_TempFile.m_FolderPath = env( "%Temp%\Report" )\r
1956     If IsEmpty( g_TempFile.m_LimitDate ) Then _\r
1957       g_TempFile.m_LimitDate = DateAdd( "d", -2, Now() )\r
1958 \r
1959     If InStr( g_TempFile.m_FolderPath, "Temp" ) = 0 Then\r
1960       echo  "Not found ""Temp"" in temporary folder path in %Temp% or Setting_getTemp."\r
1961       echo  "Is this temporary folder path to delete? : " + g_TempFile.m_FolderPath\r
1962       echo  "\82±\82ê\82Í\8dí\8f\9c\82µ\82Ä\82à\82æ\82¢\88ê\8e\9e\83t\83H\83\8b\83_\82Ì\83p\83X\82Å\82·\82©\81H : " + g_TempFile.m_FolderPath\r
1963       pause\r
1964     End If\r
1965   End If\r
1966 End Sub\r
1967 \r
1968  \r
1969 '********************************************************************************\r
1970 '  <<< [ReadAll] >>> \r
1971 '********************************************************************************\r
1972 Function  ReadAll( FileStream )\r
1973   Dim  en, ed\r
1974 \r
1975   ReadAll = ""\r
1976   On Error Resume Next\r
1977     ReadAll = FileStream.ReadAll\r
1978   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
1979   If en = E_EndOfFile Then  en = 0\r
1980   If en <> 0 Then  Err.Raise en,,ed\r
1981 End Function\r
1982 \r
1983 \r
1984  \r
1985 '********************************************************************************\r
1986 '  <<< [Txt2BinTxt] >>> \r
1987 '********************************************************************************\r
1988 Sub  Txt2BinTxt( SrcPath, DstPath )\r
1989   Dim  r\r
1990   Dim  txt2bintxt_exe : txt2bintxt_exe = g_vbslib_ver_folder + "txt2bintxt.exe"\r
1991 \r
1992   If not g_fs.FileExists( txt2bintxt_exe ) Then _\r
1993     Err.Raise  1,, "not found txt2bintxt.exe in vbslib folder"\r
1994 \r
1995   r = RunProg( """"+txt2bintxt_exe+""" """+SrcPath+""" """+DstPath+"""", Empty )\r
1996   If r<>0 Then  Err.Raise  1,, "error 0x" & Hex(r) & " in txt2bintxt.exe"\r
1997 End Sub\r
1998 \r
1999 \r
2000  \r
2001 '********************************************************************************\r
2002 '  <<< [WriteVBSLibHeader] >>> \r
2003 '********************************************************************************\r
2004 Sub  WriteVBSLibHeader( OutFileStream, Opt )\r
2005   Dim  f, line\r
2006 \r
2007   Set f = g_fs.OpenTextFile( WScript.ScriptFullName )\r
2008   Do Until f.AtEndOfStream\r
2009 \r
2010     line = f.ReadLine\r
2011 \r
2012     If InStr( line, "g_CommandPrompt =" ) > 0 and not IsEmpty( Opt ) Then\r
2013       If not IsEmpty( Opt.m_OverCommandPrompt ) Then\r
2014         line = "  g_CommandPrompt = " & Opt.m_OverCommandPrompt\r
2015       End If\r
2016     End If\r
2017     If InStr( line, "main()" ) > 0 Then Exit Do\r
2018     If InStr( line, "main2(" ) > 0 Then Exit Do\r
2019 \r
2020     OutFileStream.WriteLine  line\r
2021   Loop\r
2022 End Sub\r
2023 \r
2024 \r
2025 Class  WriteVBSLibHeader_Option\r
2026   Public  m_OverCommandPrompt\r
2027 End Class\r
2028 \r
2029 \r
2030  \r
2031 '********************************************************************************\r
2032 '  <<< [GetAbsPath] >>> \r
2033 '********************************************************************************\r
2034 Function  GetAbsPath( StepPath, ByVal BasePath )\r
2035   Dim  i, ii, i3, sep_ch, path\r
2036   Dim  i_root\r
2037 \r
2038   If IsEmpty( BasePath ) Then  BasePath = g_sh.CurrentDirectory\r
2039   If IsAbsPath( StepPath ) Then  BasePath = Empty\r
2040 \r
2041 \r
2042   '//=== sep_ch = separetor "\" or "/"\r
2043   If IsEmpty( BasePath ) Then\r
2044     i  = InStr( StepPath, "\" )\r
2045     ii = InStr( StepPath, "/" )\r
2046   Else\r
2047     i  = InStr( BasePath, "\" )\r
2048     ii = InStr( BasePath, "/" )\r
2049   End If\r
2050   If i > 0 Then\r
2051     If ii > 0 Then\r
2052       If i > ii Then  sep_ch = "/"  Else  sep_ch = "\"\r
2053     Else\r
2054       sep_ch = "\"\r
2055     End If\r
2056   Else\r
2057    If ii > 0 Then  sep_ch = "/"  Else  sep_ch = "\"\r
2058   End If\r
2059   '(debug point) watch "sep_ch"\r
2060 \r
2061 \r
2062   '//=== Joint and Replace to sep_ch\r
2063   If Right( BasePath, 1 ) = sep_ch  or  IsEmpty( BasePath ) Then\r
2064     path = BasePath + StepPath\r
2065   Else\r
2066     path = BasePath + sep_ch + StepPath\r
2067   End If\r
2068   If sep_ch = "\" Then\r
2069     path = Replace( path, "/", "\" )\r
2070   Else\r
2071     path = Replace( path, "\", "/" )\r
2072   End If\r
2073   '(debug point) watch "path"\r
2074 \r
2075 \r
2076   '//=== Get i_root\r
2077   i_root = InStr( path, sep_ch )\r
2078   If Mid( path, i_root+1, 1 ) = sep_ch Then\r
2079     i = InStr( i_root+2, path, sep_ch )\r
2080     If i > 0 Then\r
2081       i_root = i\r
2082     Else\r
2083       path = path + sep_ch\r
2084       i_root = Len( path ) + 1\r
2085     End If\r
2086   End If\r
2087 \r
2088 \r
2089   '//=== Cut \.\\r
2090   Do\r
2091     i = InStr( path, sep_ch+"."+sep_ch )\r
2092     If i = 0 Then Exit Do\r
2093     path = Left( path, i ) + Mid( path, i+3 )\r
2094   Loop\r
2095   If Right( path, 2 ) = sep_ch+"." Then  path = Left( path, Len(path)-2 )\r
2096 \r
2097 \r
2098   '//=== Cut xxx\..\\r
2099   Do\r
2100     i = InStr( path, sep_ch+".."+sep_ch )\r
2101     If i = 0 Then Exit Do\r
2102     i3 = 0\r
2103     Do\r
2104       ii = InStr( i3+1, path, sep_ch )\r
2105       If ii = 0 Then Exit Do\r
2106       If ii = i Then\r
2107         If i = i_root Then\r
2108           path = Left( path, i ) + Mid( path, i+4 ) '// Cut "\..\"\r
2109         Else\r
2110           path = Left( path, i3 ) + Mid( path, i+4 ) '// Cut xxx\..\\r
2111         End If\r
2112         Exit Do\r
2113       End If\r
2114       i3 = ii\r
2115     Loop\r
2116   Loop\r
2117 \r
2118 \r
2119   '//=== Cut xxx\..\r
2120   If Right( path, 3 ) = sep_ch+".." Then\r
2121     i = Len( path ) - 2\r
2122     If i = i_root Then\r
2123       path = Left( path, i )\r
2124     Else\r
2125       i = InStrRev( path, sep_ch, i-1 )\r
2126       If i = i_root Then\r
2127         path = Left( path, i )\r
2128       Else\r
2129         path = Left( path, i-1 )\r
2130       End If\r
2131     End If\r
2132   End If\r
2133 \r
2134 \r
2135   If Right( path, 1 ) = ":" Then  path = path + sep_ch\r
2136 \r
2137 \r
2138   '(debug point) watch "path"\r
2139 \r
2140   GetAbsPath = path\r
2141 End Function\r
2142 \r
2143 \r
2144  \r
2145 '********************************************************************************\r
2146 '  <<< [GetStepPath] >>> \r
2147 ' - AbsPath, BasePath, (return) as string\r
2148 '********************************************************************************\r
2149 Function  GetStepPath( AbsPath, BasePath )\r
2150   Dim  AbsPathU, BasePathU, path, sep_ch, i, ii\r
2151 \r
2152   AbsPathU = UCase(AbsPath)\r
2153   If IsEmpty( BasePath ) Then\r
2154     BasePathU = UCase(g_sh.CurrentDirectory)\r
2155   Else\r
2156     BasePathU = UCase(BasePath)\r
2157   End If\r
2158 \r
2159 \r
2160   '// sep_ch = separetor "\" or "/"\r
2161   i  = InStr( AbsPath, "\" )\r
2162   ii = InStr( AbsPath, "/" )\r
2163   If i > 0 Then\r
2164     If ii > 0 Then\r
2165       If i > ii Then  sep_ch = "/"  Else  sep_ch = "\"\r
2166     Else\r
2167       sep_ch = "\"\r
2168     End If\r
2169   Else\r
2170    If ii > 0 Then  sep_ch = "/"  Else  sep_ch = "\"\r
2171   End If\r
2172   '(debug point) watch "sep_ch"\r
2173 \r
2174 \r
2175   '// path = common parent folder path. The last character is not sep_ch\r
2176   path = BasePathU\r
2177   If Right( BasePathU, 1 ) = sep_ch Then  path = Left( BasePathU, Len(BasePathU)-1 )\r
2178   Do\r
2179     If path = Left( AbsPathU, Len(path) ) Then  Exit Do\r
2180     path = g_fs.GetParentFolderName( path )\r
2181   Loop\r
2182   If path = "" Then  GetStepPath = AbsPath : Exit Function\r
2183   If Right( path, 1 ) = sep_ch Then  path = Left( path, Len(path)-1 )\r
2184   '(debug point) watch "path"\r
2185 \r
2186 \r
2187   '// GetStepPath = step path without ..\\r
2188   GetStepPath = Mid( AbsPath, Len(path) + 2 )\r
2189   '(debug point) watch "GetStepPath"\r
2190 \r
2191 \r
2192   '// GetStepPath: Add "..\"\r
2193   path = Mid( BasePath, Len(path) + 2 )\r
2194   Do\r
2195     If path = "" Then Exit Do\r
2196     path = g_fs.GetParentFolderName( path )\r
2197     GetStepPath = ".." + sep_ch + GetStepPath\r
2198   Loop\r
2199   '(debug point) watch "GetStepPath"\r
2200 \r
2201 \r
2202   If GetStepPath = "" Then  GetStepPath = "."\r
2203 End Function\r
2204 \r
2205 \r
2206  \r
2207 '********************************************************************************\r
2208 '  <<< [GetParentAbsPath] >>> \r
2209 '********************************************************************************\r
2210 Function  GetParentAbsPath( Path )\r
2211   GetParentAbsPath = g_fs.GetParentFolderName( g_fs.GetAbsolutePathName( Path ) )\r
2212 End Function\r
2213 \r
2214 \r
2215  \r
2216 '********************************************************************************\r
2217 '  <<< [IsAbsPath] >>> \r
2218 '********************************************************************************\r
2219 Function  IsAbsPath( Path )\r
2220   Dim  bs : bs = InStr( Path, "\" )\r
2221   Dim  sl : sl = InStr( Path, "/" )\r
2222   Dim  co : co = InStr( Path, ":" )\r
2223 \r
2224   IsAbsPath = ( co > 0  and ( bs = co+1  or  sl = co+1 ) )\r
2225 End Function\r
2226 \r
2227  \r
2228 '********************************************************************************\r
2229 '  <<< [FindParent] >>> \r
2230 '********************************************************************************\r
2231 Function  FindParent( TargetStepPath, StartFolderPath )\r
2232   Dim  base : base = GetAbsPath( StartFolderPath, Empty )\r
2233   Dim  path\r
2234 \r
2235   Do\r
2236     path = base + "\" + TargetStepPath\r
2237     If g_fs.FileExists( path ) or g_fs.FolderExists( path ) Then  Exit Do\r
2238     base = g_fs.GetParentFolderName( base )\r
2239     If base = "" Then  Raise  E_PathNotFound, _\r
2240        "<ERROR msg='No FindParent' target='" + TargetStepPath + "'/>"\r
2241   Loop\r
2242   FindParent = path\r
2243 End Function\r
2244 \r
2245 \r
2246 \r
2247  \r
2248 '********************************************************************************\r
2249 '  <<< [GetTagJumpPath] >>> \r
2250 '********************************************************************************\r
2251 Function  GetTagJumpPath( PathAndLine )\r
2252   Dim  i : i = InStrRev( PathAndLine, "(" )\r
2253   If i > 0 Then\r
2254     GetTagJumpPath = Left( PathAndLine, i-1 )\r
2255   Else\r
2256     GetTagJumpPath = PathAndLine\r
2257   End If\r
2258 End Function\r
2259 \r
2260  \r
2261 '********************************************************************************\r
2262 '  <<< [IsWildcard] >>> \r
2263 '********************************************************************************\r
2264 Function  IsWildcard( ByVal path )\r
2265   IsWildcard = InStr( path, "?" ) <> 0 Or InStr( path, "*" ) <> 0\r
2266 End Function\r
2267 \r
2268 \r
2269  \r
2270 '********************************************************************************\r
2271 '  <<< [ExpandWildcard] >>> \r
2272 '********************************************************************************\r
2273 Sub  ExpandWildcard( ByVal wildcard_path, flags, folder, fnames )\r
2274   Dim  s, re\r
2275 \r
2276   folder = g_fs.GetParentFolderName( g_fs.GetAbsolutePathName( wildcard_path ) )\r
2277 \r
2278   Set re = CreateObject("VBScript.RegExp")\r
2279   re.Global = True\r
2280   s = g_fs.GetFileName( wildcard_path )\r
2281   re.Pattern = "\\" :  s = re.Replace( s, "\\" )\r
2282   re.Pattern = "\." :  s = re.Replace( s, "\." )\r
2283   re.Pattern = "\$" :  s = re.Replace( s, "\$" )\r
2284   re.Pattern = "\^" :  s = re.Replace( s, "\^" )\r
2285   re.Pattern = "\{" :  s = re.Replace( s, "\{" )\r
2286   re.Pattern = "\}" :  s = re.Replace( s, "\}" )\r
2287   re.Pattern = "\[" :  s = re.Replace( s, "\[" )\r
2288   re.Pattern = "\]" :  s = re.Replace( s, "\]" )\r
2289   re.Pattern = "\(" :  s = re.Replace( s, "\(" )\r
2290   re.Pattern = "\)" :  s = re.Replace( s, "\)" )\r
2291   re.Pattern = "\|" :  s = re.Replace( s, "\|" )\r
2292   re.Pattern = "\+" :  s = re.Replace( s, "\+" )\r
2293   re.Pattern = "\*" :  s = re.Replace( s, ".*" )\r
2294   re.Pattern = "\?" :  s = re.Replace( s, "." )\r
2295 \r
2296   re.Pattern = "^" + s\r
2297   If Left( re.Pattern, 3 ) = "^.*" Then  re.Pattern = Mid( re.Pattern, 4 )\r
2298   re.Global = False\r
2299   re.IgnoreCase = True\r
2300   ReDim  fnames( -1 )\r
2301 \r
2302   ExpandWildcard_sub  re, flags, folder, "", fnames\r
2303 End Sub\r
2304 \r
2305 \r
2306 Sub  ExpandWildcard_sub( re, flags, folder, step_folder, fnames )\r
2307   Dim  fo, f\r
2308 \r
2309   If not g_fs.FolderExists( folder ) Then\r
2310     Raise  E_PathNotFound, "<ERROR msg='Not found folder' jp='\83t\83H\83\8b\83_\82ª\8c©\82Â\82©\82è\82Ü\82¹\82ñ' " +_\r
2311       "path='"+ folder +"'/>"\r
2312   End If\r
2313 \r
2314   Set fo = g_fs.GetFolder( folder )\r
2315   If flags And F_File Then\r
2316     For Each f in fo.Files\r
2317       If re.Test( f.Name )  Then\r
2318         ReDim Preserve  fnames( UBound(fnames) + 1 )\r
2319         fnames( UBound(fnames) ) = step_folder + f.Name\r
2320       End If\r
2321     Next\r
2322   End If\r
2323   If flags And F_Folder Then\r
2324     For Each f in fo.SubFolders\r
2325       If re.Test( f.Name )  Then\r
2326         ReDim Preserve  fnames( UBound(fnames) + 1 )\r
2327         fnames( UBound(fnames) ) = step_folder + f.Name\r
2328       End If\r
2329     Next\r
2330   End If\r
2331 \r
2332   If flags And F_SubFolder Then\r
2333     For Each f in fo.SubFolders\r
2334       ExpandWildcard_sub  re, flags, f.Path, step_folder + f.Name + "\", fnames\r
2335     Next\r
2336   End If\r
2337 End Sub\r
2338 \r
2339 \r
2340  \r
2341 '********************************************************************************\r
2342 '  <<< [GetSubFolders] >>> \r
2343 ' argument\r
2344 '  - folders : (out) array of folder pathes\r
2345 '  - path : base folder path\r
2346 '********************************************************************************\r
2347 Sub  GetSubFolders( folders, ByVal path )\r
2348   ReDim  folders(-1)\r
2349   EnumSubFolders  folders, g_fs.GetFolder( path )\r
2350 End Sub\r
2351 \r
2352 Sub  EnumSubFolders( folders, fo )\r
2353   Dim  subfo\r
2354 \r
2355   ReDim Preserve  folders( UBound(folders) + 1 )\r
2356   folders( UBound(folders) ) = fo.Path\r
2357 \r
2358   For Each subfo in fo.SubFolders\r
2359     EnumSubFolders  folders, subfo\r
2360   Next\r
2361 End Sub\r
2362 \r
2363 \r
2364  \r
2365 '********************************************************************************\r
2366 '  <<< [EnumFolderObject] >>> \r
2367 '(argument)\r
2368 '  out_Folders as Folder\r
2369 '  FolderPath as string\r
2370 '(sample)\r
2371 '  For Each fo  In folders\r
2372 '    For Each f  In fo.Files\r
2373 '      n = f.DateLastModified\r
2374 '    Next\r
2375 '  Next\r
2376 '********************************************************************************\r
2377 Sub  EnumFolderObject( FolderPath, out_Folders )\r
2378   Dim  i_set, i_get, n, f\r
2379 \r
2380   ReDim  out_Folders(0)\r
2381   Set out_Folders(0) = g_fs.GetFolder( FolderPath )\r
2382   i_set = 1 : i_get = 0\r
2383 \r
2384   While  i_get <= UBound( out_Folders )\r
2385     n = out_Folders( i_get ).SubFolders.Count\r
2386     ReDim Preserve  out_Folders( UBound( out_Folders ) + n )\r
2387     For Each f  In  out_Folders( i_get ).SubFolders\r
2388       Set out_Folders( i_set ) = f\r
2389       i_set = i_set + 1\r
2390     Next\r
2391     i_get = i_get + 1\r
2392   WEnd\r
2393 End Sub\r
2394 \r
2395 \r
2396  \r
2397 '********************************************************************************\r
2398 '  <<< [RemoveWildcard] >>> \r
2399 '********************************************************************************\r
2400 Sub  RemoveWildcard( WildCard, fnames )\r
2401   Dim  s, path, fname, i, n, wc, wc_len\r
2402 \r
2403 \r
2404   '//=== check by with wildcard\r
2405   If Left( WildCard, 1 ) = "*" Then\r
2406     wc = LCase( Mid( WildCard, 2 ) ) : wc_len = Len( wc )\r
2407     n = UBound( fnames )\r
2408     For i = 0 To  n\r
2409       path = fnames(i)\r
2410       Do\r
2411         fname = g_fs.GetFileName( path )\r
2412         If LCase( Right( fname, wc_len ) ) = wc Then  fnames(i) = Empty : Exit Do\r
2413         path = g_fs.GetParentFolderName( path )\r
2414         If path = "" Then Exit Do\r
2415       Loop\r
2416     Next\r
2417 \r
2418 \r
2419   '//=== check by no wildcard\r
2420   Else\r
2421     wc = LCase( WildCard )\r
2422     n = UBound( fnames )\r
2423     For i = 0 To n\r
2424       path = fnames(i)\r
2425       Do\r
2426         fname = g_fs.GetFileName( path )\r
2427         If LCase( fname ) = wc Then  fnames(i) = Empty : Exit Do\r
2428         path = g_fs.GetParentFolderName( path )\r
2429         If path = "" Then Exit Do\r
2430       Loop\r
2431     Next\r
2432   End If\r
2433 \r
2434 \r
2435   '//=== shrink the array\r
2436   n = 0\r
2437   For i = 0 To UBound( fnames )\r
2438     If not IsEmpty( fnames(i) ) Then  fnames(n) = fnames(i) : n = n + 1\r
2439   Next\r
2440   Redim Preserve  fnames( n - 1 )\r
2441 End Sub\r
2442 \r
2443 \r
2444  \r
2445 '********************************************************************************\r
2446 '  <<< [MeltCSV] >>> \r
2447 '********************************************************************************\r
2448 Function  MeltCSV( Line, in_out_Start )\r
2449   Dim  s, i, c\r
2450 \r
2451   i = in_out_Start\r
2452 \r
2453   If i=0 Then Exit Function\r
2454 \r
2455 \r
2456   '//=== Skip space character\r
2457   Do\r
2458     c = Mid( Line, i, 1 )\r
2459     If c<>" " and c<>vbTab Then Exit Do\r
2460     i = i + 1\r
2461   Loop\r
2462 \r
2463   Select Case  c\r
2464 \r
2465    '//=== If enclosed by " "\r
2466    Case """"\r
2467     Do\r
2468       i = i + 1\r
2469       c = Mid( Line, i, 1 )\r
2470       If c = "" Then Exit Do\r
2471       If c = """" Then\r
2472         i = i + 1\r
2473         c = Mid( Line, i, 1 )\r
2474         If c = """" Then  s = s + c  Else  Exit Do\r
2475       Else\r
2476         s = s + c\r
2477       End If\r
2478     Loop\r
2479 \r
2480     MeltCSV = s\r
2481 \r
2482     Do\r
2483       If c = "" Then  in_out_Start = 0 : Exit Function\r
2484       If c = "," Then  in_out_Start = i+1 : Exit Function\r
2485       i = i + 1\r
2486       c = Mid( Line, i, 1 )\r
2487     Loop\r
2488 \r
2489 \r
2490    '//=== If no value\r
2491    Case ","\r
2492     in_out_Start = i+1 : Exit Function\r
2493    Case ""\r
2494     in_out_Start = 0 : Exit Function\r
2495 \r
2496 \r
2497    '//=== If NOT enclosed by " "\r
2498    Case Else\r
2499     Do\r
2500       If c = "" or c = "," Then Exit Do\r
2501       s = s + c\r
2502       i = i + 1\r
2503       c = Mid( Line, i, 1 )\r
2504     Loop\r
2505 \r
2506     MeltCSV = Trim( s )\r
2507 \r
2508     If c = "" Then  in_out_Start = 0 : Exit Function\r
2509     If c = "," Then  in_out_Start = i+1 : Exit Function\r
2510   End Select\r
2511 End Function\r
2512 \r
2513 \r
2514  \r
2515 '********************************************************************************\r
2516 '  <<< [CSVText] >>> \r
2517 '********************************************************************************\r
2518 Function  CSVText( s )\r
2519   If InStr( s, """" ) = 0 and  InStr( s, "," ) = 0 and  InStr( s, vbCRLF ) = 0 and _\r
2520      Left( s, 1 ) <> " " and  Right( s, 1 ) <> " " Then  CSVText = s : Exit Function\r
2521   CSVText = """" + Replace( s, """", """""" ) + """"\r
2522 End Function\r
2523  \r
2524 '********************************************************************************\r
2525 '  <<< [XmlAttr] >>> \r
2526 '********************************************************************************\r
2527 Function  XmlAttr( ByVal s )\r
2528   s = Replace( s, "<", "&lt;" )\r
2529   s = Replace( s, """", "&quot;" )\r
2530   '// s = Replace( s, "'", "&apos;" )\r
2531   XmlAttr = Replace( s, "&", "&amp;" )\r
2532 End Function\r
2533  \r
2534 '********************************************************************************\r
2535 '  <<< [XmlText] >>> \r
2536 '********************************************************************************\r
2537 Function  XmlText( ByVal s )\r
2538   s = Replace( s, "<", "&lt;" )\r
2539   s = Replace( s, ">", "&gt;" )\r
2540   XmlText = Replace( s, "&", "&amp;" )\r
2541 End Function\r
2542  \r
2543 '********************************************************************************\r
2544 '  <<< [LoadXML] >>> \r
2545 '********************************************************************************\r
2546 Const  F_NoRoot = 1\r
2547 Const  F_Str = &h8000\r
2548 \r
2549 Function  LoadXML( PathOrStr, Opt )\r
2550   Dim  xml, r, t, i, c\r
2551   Const  start_tag = "<Dummy_Root_>"\r
2552   Const  end_tag = "</Dummy_Root_>"\r
2553 \r
2554   If Opt and F_Str Then\r
2555     i=1 : Do : c = Mid( PathOrStr, i, 1 ) : If c<>" " and c<>vbTab Then Exit Do\r
2556     i=i+1 : Loop\r
2557     If (Opt and F_NoRoot) or c<>"<" Then\r
2558       t = start_tag + PathOrStr + end_tag\r
2559     Else\r
2560       t = PathOrStr\r
2561     End If\r
2562   Else\r
2563     t = ReadFile( PathOrStr )\r
2564     i=1 : Do : c = Mid( t, i, 1 ) : If c<>" " and c<>vbTab Then Exit Do\r
2565     i=i+1 : Loop\r
2566     If (Opt and F_NoRoot) or c<>"<" Then\r
2567       t = start_tag + t + end_tag\r
2568     End If\r
2569   End If\r
2570 \r
2571   Set xml = CreateObject("MSXML2.DOMDocument")\r
2572   r = xml.loadXML( t )\r
2573   If not r Then\r
2574     t = start_tag + t + end_tag\r
2575     r = xml.loadXML( t )\r
2576   End If\r
2577   If not r Then  Raise 1,"""" + PathOrStr + """ \82ª Unicode \82Å\82È\82¢\82©\81A\90³\82µ\82¢ XML \8c`\8e®\82É\82È\82Á\82Ä\82¢\82Ü\82¹\82ñ"\r
2578   Set LoadXML = xml.lastChild  '// If firstChild, <?xml> may be got.\r
2579 End Function\r
2580 \r
2581 \r
2582 'Function LoadXML( Path, Opt )\r
2583 '  Dim xml, r\r
2584 '\r
2585 '  If not g_fs.FileExists( Path ) Then Err.Raise 53,,"""" + Path + """ \82ª\8c©\82Â\82©\82è\82Ü\82¹\82ñ"\r
2586 '  Set xml = WScript.CreateObject("MSXML2.DOMDocument")\r
2587 '  r = xml.load( Path )\r
2588 '  If r=0 Then Err.Raise 53,,"""" + Path + """ \82ª Unicode \82Å\82È\82¢\82©\81A\90³\82µ\82¢ XML \8c`\8e®\82Å\82Í\82 \82è\82Ü\82¹\82ñ"\r
2589 '  Set LoadXML = xml.firstChild\r
2590 'End Function\r
2591 \r
2592 \r
2593  \r
2594 '*-------------------------------------------------------------------------*\r
2595 '* ### <<<< Function call and include >>>> \r
2596 '*-------------------------------------------------------------------------*\r
2597 \r
2598 \r
2599  \r
2600 '********************************************************************************\r
2601 '  <<< [call_vbs] >>> \r
2602 '********************************************************************************\r
2603 Function  call_vbs( path, func, param )\r
2604   echo  ">call_vbs  """ & path & """, " & func\r
2605   If g_debug Then\r
2606     call_vbs = call_vbs_d( path, func, param )\r
2607   Else\r
2608     call_vbs = call_vbs_t( path, func, param )\r
2609   End If\r
2610 End Function\r
2611 \r
2612 \r
2613  \r
2614 '*-------------------------------------------------------------------------*\r
2615 '* ### <<<< Support of vbsool >>>> \r
2616 '*-------------------------------------------------------------------------*\r
2617 \r
2618 \r
2619  \r
2620 '********************************************************************************\r
2621 '  <<< [ObjToXML] >>> \r
2622 '********************************************************************************\r
2623 Function  ObjToXML( TagName, Objs, Opt )\r
2624   Dim  o\r
2625   Dim  out\r
2626 \r
2627   If not IsEmpty( TagName ) Then  out = "<" + TagName + ">" + vbCRLF\r
2628   If IsArray( Objs ) Then\r
2629     For Each o In Objs : If not IsEmpty(o) Then  ObjToXML1  o, out\r
2630     Next\r
2631   ElseIf TypeName( Objs ) = "ArrayClass" Then\r
2632     For Each o In Objs.m_Array : ObjToXML1  o, out : Next\r
2633   ElseIf IsObject( Objs ) Then\r
2634     ObjToXML1  Objs, out\r
2635   End If\r
2636   If not IsEmpty( TagName ) Then  out = out + "</" + TagName + ">" + vbCRLF\r
2637   ObjToXML = Left( out, Len( out ) - 2 )\r
2638 End Function\r
2639 \r
2640 \r
2641 Sub  ObjToXML1( Obj, Out )\r
2642   Dim en,ed\r
2643 \r
2644   Out = Out + "<" + TypeName( Obj )\r
2645 \r
2646   On Error Resume Next\r
2647     ed = Obj.Name\r
2648   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
2649   If en = 0 Then  Out = Out + " Name=""" & XmlAttr( Obj.Name ) & """"\r
2650   If en = 438 Then  en = 0\r
2651   If en <> 0 Then  Err.Raise en,,ed\r
2652 \r
2653   On Error Resume Next\r
2654     ed = Obj.DefinePath\r
2655   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
2656   If en = 0 Then  Out = Out + " DefinePath=""" & XmlAttr( Obj.DefinePath ) & """"\r
2657   If en = 438 Then  en = 0\r
2658   If en <> 0 Then  Err.Raise en,,ed\r
2659 \r
2660   Out = Out + "/>" + vbCRLF\r
2661 End Sub\r
2662 \r
2663 \r
2664 \r
2665 \r
2666  \r
2667 '********************************************************************************\r
2668 '  <<< [get_Object] >>> \r
2669 '********************************************************************************\r
2670 Function  get_Object( Name )\r
2671   Dim  en,ed\r
2672 \r
2673   On Error Resume Next\r
2674     Dim  get_func : Set  get_func = GetRef( "get_" + Name )\r
2675   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
2676   If en = 5 Then  Err.Raise  en,,ed + " : Not defined 'get_" + Name + "'"\r
2677   If en <> 0 Then  Err.Raise en,,ed\r
2678 \r
2679   Set  get_Object = get_func()\r
2680 End Function\r
2681 \r
2682  \r
2683 '********************************************************************************\r
2684 '  <<< [get_ObjectFromFile] >>> \r
2685 '********************************************************************************\r
2686 Function  get_ObjectFromFile( ModulePath, Name )\r
2687   Dim  f\r
2688 \r
2689   g_SrcPath = g_fs.GetAbsolutePathName( ModulePath )\r
2690   If g_debug Then  echo  ">include """ + g_SrcPath + """"\r
2691   Set f = g_fs.OpenTextFile( g_SrcPath )\r
2692   If g_debug Then\r
2693     ExecuteGlobal  "'// " + g_SrcPath +vbCRLF+ f.ReadAll()\r
2694   Else\r
2695     ExecuteGlobal  f.ReadAll()\r
2696   End If\r
2697 \r
2698   Dim  get_func : Set  get_func = GetRef( "get_" + Name )\r
2699   Set  get_ObjectFromFile = get_func()\r
2700 End Function\r
2701 \r
2702 \r
2703  \r
2704 '********************************************************************************\r
2705 '  <<< [get_NameDelegator] >>> \r
2706 '********************************************************************************\r
2707 Dim  g_NameDic : Set g_NameDic = CreateObject( "Scripting.Dictionary" )\r
2708 \r
2709 Function  get_NameDelegator( Name, TrueName, InterfaceName )\r
2710   If g_NameDic.Exists( Name +"__"+ TrueName ) Then\r
2711     Set get_NameDelegator = g_NameDic.Item( Name +"__"+ TrueName +"_"+ InterfaceName )\r
2712     Exit Function\r
2713   End If\r
2714 \r
2715   Set  get_NameDelegator = new_X( InterfaceName + "_Delegator" ) : With get_NameDelegator\r
2716     .Name = Name\r
2717     .m_Delegate = TrueName  '// if validated was need.\r
2718     If not g_bNeedValidateDelegate Then _\r
2719       Set .m_Delegate = get_Object( TrueName )  '// if validated was not need.\r
2720   End With\r
2721 \r
2722   Set  g_NameDic.Item( Name +"__"+ TrueName +"_"+ InterfaceName ) = get_NameDelegator\r
2723 End Function\r
2724 \r
2725 \r
2726 Const  F_ValidateOnlyDelegate = &h40000000\r
2727 Dim    g_bNeedValidateDelegate\r
2728 \r
2729 \r
2730 Function  NameDelegator_getTrueName( m )\r
2731   If VarType( m.m_Delegate ) = vbString Then\r
2732     NameDelegator_getTrueName = m.m_Delegate\r
2733   Else\r
2734     NameDelegator_getTrueName = m.m_Delegate.TrueName\r
2735   End If\r
2736 End Function\r
2737 \r
2738 \r
2739 Sub  NameDelegator_validate( m, Flags )\r
2740   If VarType( m.m_Delegate ) = vbString Then\r
2741     Set m.m_Delegate = get_Object( m.m_Delegate )\r
2742   End If\r
2743   If ( Flags and F_ValidateOnlyDelegate ) = 0 Then _\r
2744     m.m_Delegate.Validate  Flags\r
2745 End Sub\r
2746 \r
2747 \r
2748 Function  NameDelegator_getXML( m )\r
2749   If VarType( m.m_Delegate ) = vbString Then\r
2750     NameDelegator_getXML = "<" + TypeName( m ) + _\r
2751       " Name='" + m.Name + "' TrueName='" + m.TrueName + "'/>"\r
2752   Else\r
2753     NameDelegator_getXML = "<" + TypeName( m ) + _\r
2754       " Name='" + m.Name + "' TrueName='" + m.TrueName + "'>" +vbCRLF+_\r
2755       m.m_Delegate.xml + vbCRLF + "</" + TypeName( m ) + ">"\r
2756   End If\r
2757 End Function\r
2758 \r
2759 \r
2760  \r
2761 '********************************************************************************\r
2762 '  <<< [new_X] >>> \r
2763 '********************************************************************************\r
2764 Function  new_X( Name )\r
2765   Dim en,ed\r
2766 \r
2767   On Error Resume Next\r
2768     Dim  new_f : Set  new_f = GetRef( "new_" + Name )\r
2769   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
2770   If en = 5 Then  Err.Raise  en,,ed + " : Not defined 'new_" + Name + "'"\r
2771   If en <> 0 Then  Err.Raise en,,ed\r
2772 \r
2773   Set  new_X = new_f()\r
2774 End Function\r
2775 \r
2776 \r
2777  \r
2778 '********************************************************************************\r
2779 '  <<< [include_objs] >>> \r
2780 '********************************************************************************\r
2781 Dim  g_included_paths : Set g_included_paths = CreateObject( "Scripting.Dictionary" )\r
2782 \r
2783 Sub  include_objs( Wildcard, Flags, out_GetObjectFuncs )\r
2784   Dim  ds_:Set ds_= new CurDirStack\r
2785   Dim  folder_path, fname_key_s, folders, fo, f, fi, t, en, ed\r
2786   Dim  fname_key : Set fname_key = new StrMatchKey\r
2787 \r
2788   If g_fs.FolderExists( Wildcard ) Then\r
2789     folder_path = Wildcard : fname_key_s = "*_obj.vbs"\r
2790   Else\r
2791     folder_path = GetParentAbsPath( Wildcard ) : fname_key_s = g_fs.GetFileName( Wildcard )\r
2792   End If\r
2793   fname_key.Keyword = LCase( fname_key_s )\r
2794 \r
2795   ReDim  out_GetObjectFuncs(-1)\r
2796 \r
2797   EnumFolderObject  folder_path, folders  '// [out] folders\r
2798   For Each fo  In folders\r
2799     For Each f  In fo.Files\r
2800       If fname_key.IsMatch( f.Name ) Then\r
2801         g_SrcPath = f.Path\r
2802 \r
2803         If IsEmpty( g_included_paths.Item( g_SrcPath ) ) Then\r
2804 \r
2805           If g_debug Then  echo  ">include """ + f.Path + """"\r
2806 \r
2807           ExecuteGlobal  "Sub  get_StaticObjects(a,b) : End Sub"\r
2808 \r
2809           Set fi = g_fs.OpenTextFile( g_SrcPath )\r
2810           If g_debug Then  t = "'// " + g_SrcPath +vbCRLF+ fi.ReadAll()  Else  t = fi.ReadAll()\r
2811           fi.Close\r
2812           g_sh.CurrentDirectory = fo.Path\r
2813 \r
2814           If not IsEmpty( g_debug_vbs_path ) and _\r
2815                  InStr( g_SrcPath, g_debug_vbs_path ) > 0 Then\r
2816             InvestigateInterpretError2  g_SrcPath, en, ed\r
2817           Else\r
2818             On Error Resume Next\r
2819               ExecuteGlobal  t  '// Interpret  g_SrcPath\r
2820             en = Err.Number : ed = Err.Description : On Error GoTo 0\r
2821             If en <> 0 Then\r
2822               InvestigateInterpretError  g_SrcPath, en, ed\r
2823             End If\r
2824           End If\r
2825 \r
2826           ReDim Preserve  out_GetObjectFuncs( UBound( out_GetObjectFuncs ) + 1 )\r
2827           Set out_GetObjectFuncs( UBound( out_GetObjectFuncs ) ) = GetRef( "get_StaticObjects" )\r
2828 \r
2829           Set  g_included_paths.Item( g_SrcPath ) = out_GetObjectFuncs( UBound( out_GetObjectFuncs ) )\r
2830         Else\r
2831           ReDim Preserve  out_GetObjectFuncs( UBound( out_GetObjectFuncs ) + 1 )\r
2832           Set out_GetObjectFuncs( UBound( out_GetObjectFuncs ) ) = g_included_paths.Item( g_SrcPath )\r
2833         End If\r
2834       End If\r
2835     Next\r
2836   Next\r
2837   g_SrcPath = Empty\r
2838 End Sub\r
2839 \r
2840 \r
2841  \r
2842 '********************************************************************************\r
2843 '  <<< [get_ObjectsFromFile] >>> \r
2844 '********************************************************************************\r
2845 Sub  get_ObjectsFromFile( GetObjectFuncs, InterfaceName, out_Objs )\r
2846   If VarType( GetObjectFuncs ) = vbString Then\r
2847     Dim  create_funcs\r
2848     include_objs  GetObjectFuncs, Empty, create_funcs '// [out] create_funcs\r
2849     get_ObjectsFromFile_sub  create_funcs, InterfaceName, out_Objs\r
2850   Else\r
2851     get_ObjectsFromFile_sub  GetObjectFuncs, InterfaceName, out_Objs\r
2852   End If\r
2853 End Sub\r
2854 \r
2855 Sub  get_ObjectsFromFile_sub( GetObjectFuncs, InterfaceName, out_Objs )\r
2856   Dim  func, objs\r
2857 \r
2858   ReDim  out_Objs(-1)\r
2859   For Each func  In GetObjectFuncs\r
2860     objs = Empty\r
2861     Call  func( InterfaceName, objs ) '// [out] objs\r
2862     AddArrElem  out_Objs, objs\r
2863   Next\r
2864 End Sub\r
2865 \r
2866 \r
2867  \r
2868 '********************************************************************************\r
2869 '  <<< [get_DefineInfoObject] >>> \r
2870 '********************************************************************************\r
2871 Class  DefineInfoClass\r
2872   Public  FullPath\r
2873 End Class\r
2874 \r
2875 Sub  get_DefineInfoObject( in_out_Object, FullPath )\r
2876   If not IsEmpty( in_out_Object ) and  not g_bInvestigateInterpretError Then _\r
2877     Raise 1, "2nd execute(include)"\r
2878   Set in_out_Object = new DefineInfoClass\r
2879   in_out_Object.FullPath = FullPath\r
2880 End Sub\r
2881 \r
2882  \r
2883 '********************************************************************************\r
2884 '  <<< [InvestigateInterpretError] >>> \r
2885 '********************************************************************************\r
2886 Dim  g_debug_vbs_path\r
2887 Dim  g_debug_vbs_err_num\r
2888 Dim  g_bInvestigateInterpretError\r
2889 \r
2890 Sub  InvestigateInterpretError( Path, en, ed )\r
2891   Dim  f, t\r
2892 \r
2893   echo ""\r
2894   echo ">InvestigateInterpretError  """ + Path + """"\r
2895   g_bInvestigateInterpretError = True\r
2896 \r
2897   Set f = g_fs.OpenTextFile( Path ) : t = f.ReadAll() : f.Close\r
2898   Dim  en2, ed2\r
2899   On Error Resume Next\r
2900     ExecuteGlobal  t\r
2901   en2 = Err.Number : ed2 = Err.Description : On Error GoTo 0\r
2902 \r
2903   If en2 = 0 Then\r
2904     Err.Raise  en,,"<ERROR msg='"+ ed +"' include_path="+vbCRLF+"'"+ g_SrcPath +_\r
2905       "'"+vbCRLF+"hint='2\89ñ\96Ú\82Ì ExecuteGlobal \82Å\82Í\83G\83\89\81[\82ª\8fo\82Ü\82¹\82ñ\82Å\82µ\82½\81B"+_\r
2906       "\8e\9f\82Ì\83R\81[\83h\82ð main \8aÖ\90\94\82É\8bL\8fq\82µ\82Ä\8dÄ\8eÀ\8ds\82µ\82Ä\82\82¾\82³\82¢' add_code=" +vbCRLF+_\r
2907       "'g_debug_vbs_path = """ + Path + """'/>"\r
2908   End If\r
2909 \r
2910   echo  GetErrStr( en, ed )\r
2911 \r
2912 \r
2913   '// Try to display error line\r
2914   RunProg  "wscript.exe """ + Path + """", ""\r
2915 \r
2916 \r
2917   '// Error of Duplicate Name\r
2918   If en2 = 1041 Then\r
2919     Err.Raise  en,,"<ERROR msg='"+ ed +"' include_path="+vbCRLF+"'"+ g_SrcPath +_\r
2920       "'"+vbCRLF+"hint='\8e\9f\82Ì\83R\81[\83h\82ð main \8aÖ\90\94\82É\8bL\8fq\82µ\82Ä\8dÄ\8eÀ\8ds\82µ\82Ä\82\82¾\82³\82¢' add_code=" +vbCRLF+_\r
2921       "'g_debug_vbs_path = """ + Path + """ : g_debug_vbs_err_num = 1041'/>"\r
2922   End If\r
2923 \r
2924 \r
2925   '// Try to break at error line ([attention] 2nd execute may different behavior)\r
2926   Set f = g_fs.OpenTextFile( Path ) : t = f.ReadAll() : f.Close\r
2927   ExecuteGlobal  "'// This is 2nd execute(include) from InvestigateInterpretError." +vbCRLF + t\r
2928 \r
2929 \r
2930   '// This is no new hint\r
2931   Err.Raise  en,,"<ERROR msg='"+ ed +"' include_path="+vbCRLF+"'"+ g_SrcPath + "'/>"\r
2932 End Sub\r
2933 \r
2934 \r
2935  \r
2936 '********************************************************************************\r
2937 '  <<< [InvestigateInterpretError2] >>> \r
2938 '********************************************************************************\r
2939 Sub  InvestigateInterpretError2( Path, en, ed )\r
2940   Dim  f, t\r
2941 \r
2942   If g_debug_vbs_err_num = 1041 Then\r
2943     Stop\r
2944     InvestigateDuplicatedNameError  g_SrcPath, en, ed\r
2945     Stop\r
2946   ElseIf g_debug_vbs_err_num = -1041 Then\r
2947     Stop  ' This is 1st include. Next is ...\r
2948     g_debug_vbs_err_num = 1041\r
2949     Set f = g_fs.OpenTextFile( Path ) : t = f.ReadAll() : f.Close\r
2950     ExecuteGlobal  t  '// Interpret  g_SrcPath\r
2951   Else\r
2952     Stop\r
2953     Set f = g_fs.OpenTextFile( Path ) : t = f.ReadAll() : f.Close\r
2954     ExecuteGlobal  t  '// Interpret  g_SrcPath\r
2955   End If\r
2956 End Sub\r
2957 \r
2958  \r
2959 '********************************************************************************\r
2960 '  <<< [InvestigateDuplicatedNameError] >>> \r
2961 '********************************************************************************\r
2962 Sub  InvestigateDuplicatedNameError( Path, en, ed )\r
2963   Dim  f, t, i, j, c\r
2964 \r
2965   Set f = g_fs.OpenTextFile( Path )\r
2966   Do Until f.AtEndOfStream\r
2967     t = f.ReadLine()\r
2968     i = InStr( t, "Class" )\r
2969     If i = 0 Then  i = InStr( t, "Dim" )\r
2970     If i > 0 Then\r
2971       i=i+1\r
2972       Do\r
2973         If Mid(t,i,1)=" " Then Exit Do\r
2974         i=i+1\r
2975       Loop\r
2976       Do\r
2977         If Mid(t,i,1)<>" " Then Exit Do\r
2978         i=i+1\r
2979       Loop\r
2980 \r
2981       j=i\r
2982       Do\r
2983         c = Mid(t,j,1)\r
2984         If not( (c>="A" and c<="Z") or (c>="a" and c<="z") or (c>="0" and c<="9") or c="_" ) Then _\r
2985           Exit Do\r
2986         j=j+1\r
2987       Loop\r
2988       If j > i Then\r
2989         If InStr( t, "Class" ) > 0 Then\r
2990           c = "Class " + Mid( t, i, j-i ) + " : End Class"\r
2991         Else\r
2992           c = "Dim " + Mid( t, i, j-i )\r
2993         End If\r
2994         echo ">ExecuteGlobal  """ + c + """"\r
2995         ExecuteGlobal  c\r
2996       End If\r
2997     End If\r
2998   Loop\r
2999   f.Close\r
3000 \r
3001   Err.Raise  en,,"<ERROR msg='"+ ed +"' include_path="+vbCRLF+"'"+ g_SrcPath +_\r
3002     "'"+vbCRLF+"hint='2\89ñ include \82µ\82Ä\82¢\82é\89Â\94\\90«\82ª\82 \82è\82Ü\82·\81B"+_\r
3003     "\8e\9f\82Ì\83R\81[\83h\82ð main \8aÖ\90\94\82É\8bL\8fq\82µ\82Ä\8dÄ\8eÀ\8ds\82µ\82Ä\82\82¾\82³\82¢' add_code=" +vbCRLF+_\r
3004     "'g_debug_vbs_path = """ + Path + """ : g_debug_vbs_err_num = -1041'/>"\r
3005 End Sub\r
3006 \r
3007 \r
3008  \r
3009 '*-------------------------------------------------------------------------*\r
3010 '* ### <<<< Process >>>> \r
3011 '*-------------------------------------------------------------------------*\r
3012 \r
3013 \r
3014  \r
3015 '********************************************************************************\r
3016 '  <<< [env] Expand environment strings >>> \r
3017 '********************************************************************************\r
3018 Function  env( s )\r
3019   If IsEmpty( s ) Then Exit Function  '// for avoid to s=""\r
3020 \r
3021   Dim  p1, p2, symbol, value\r
3022   Dim  i : i = 1\r
3023   Do\r
3024     p1 = InStr( i, s, "%" )\r
3025     If p1 = 0 Then\r
3026       env = env & Mid( s, i )\r
3027       Exit Function\r
3028     Else\r
3029       env = env & Mid( s, i, p1 - i )\r
3030       p2 = InStr( p1+1, s, "%" )\r
3031       If p2 = p1+1 Then\r
3032         env = env & "%"\r
3033       Else\r
3034         symbol = Mid( s, p1+1, p2-p1-1 )\r
3035         value = GetVar( symbol )\r
3036         If IsEmpty( value ) Then _\r
3037           Err.Raise E_NotFoundSymbol,, "<ERROR msg='not found var symbol' symbol='"+ symbol +"'/>"\r
3038         env = env & value\r
3039       End If\r
3040       i = p2 + 1\r
3041     End If\r
3042   Loop\r
3043 End Function\r
3044 \r
3045 \r
3046  \r
3047 '********************************************************************************\r
3048 '  <<< [start] >>> \r
3049 '********************************************************************************\r
3050 Sub  start( cmdline )\r
3051   echo  ">start  " & cmdline\r
3052   cmdline = g_sh.ExpandEnvironmentStrings( cmdline )\r
3053 \r
3054   Dim en,ed\r
3055 \r
3056   On Error Resume Next\r
3057 \r
3058     g_sh.Run  cmdline,, FALSE\r
3059 \r
3060   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
3061   If en = E_WIN32_FILE_NOT_FOUND Then _\r
3062     Err.Raise en,,"\83t\83@\83C\83\8b\82©\83t\83H\83\8b\83_\82ª\8c©\82Â\82©\82è\82Ü\82¹\82ñ : " + cmdline\r
3063   If en <> 0 Then  Err.Raise en,,ed\r
3064 End Sub\r
3065 \r
3066 \r
3067  \r
3068 '********************************************************************************\r
3069 '  <<< [RunProg] >>> \r
3070 '********************************************************************************\r
3071 Function  RunProg( ByVal cmdline, stdout_stderr_redirect )\r
3072   Dim  dbg_cmd\r
3073 \r
3074   '// Set debug mode\r
3075   If stdout_stderr_redirect = "_debug" Then\r
3076     dbg_cmd = "cmd /K " : stdout_stderr_redirect = ""\r
3077   Else\r
3078     dbg_cmd = ""\r
3079   End If\r
3080 \r
3081 \r
3082   '// Echo command line\r
3083   echo  ">current dir = """ & g_sh.CurrentDirectory & """"\r
3084   If stdout_stderr_redirect = "" Then\r
3085     echo  ">RunProg  " & cmdline\r
3086   Else\r
3087     echo  ">RunProg  " & cmdline+" >> """+stdout_stderr_redirect+""""\r
3088   End If\r
3089 \r
3090 \r
3091   '// env\r
3092   cmdline = g_sh.ExpandEnvironmentStrings( cmdline )\r
3093 \r
3094 \r
3095   '// avoid to stop by StdIn\r
3096   if ( Left( cmdline, 7 ) = "cscript" ) Then _\r
3097     cmdline = cmdline + " /GUI_input:1"\r
3098 \r
3099 \r
3100   '// Create new process\r
3101   Dim  ex\r
3102   Set ex = g_sh.Exec( cmdline )\r
3103   stdout_stderr_redirect = g_sh.ExpandEnvironmentStrings( stdout_stderr_redirect )\r
3104   RunProg = WaitForFinishAndRedirect( ex, stdout_stderr_redirect )\r
3105 \r
3106   echo  ""\r
3107 End Function\r
3108 \r
3109 \r
3110  \r
3111 '********************************************************************************\r
3112 '  <<< [WaitForFinishAndRedirect] >>> \r
3113 'http://itpro.nikkeibp.co.jp/article/COLUMN/20080805/312155/?ST=develop&P=2\r
3114 '********************************************************************************\r
3115 Function  WaitForFinishAndRedirect( ex, path )\r
3116   Dim  f\r
3117   Dim  head\r
3118 \r
3119   If g_debug and IsEmpty( g_ChildHead ) Then  g_ChildHead = ">|"\r
3120 \r
3121   If path <> "" and path <> "nul" Then _\r
3122     Set f = g_fs.OpenTextFile( path, 8, True, False )\r
3123 \r
3124   Do While ex.Status = 0\r
3125     If path = "nul" or IsEmpty( path ) Then\r
3126       Do Until ex.StdOut.AtEndOfStream : ex.StdOut.ReadLine : Loop\r
3127       Do Until ex.StdErr.AtEndOfStream : ex.StdErr.ReadLine : Loop\r
3128     ElseIf path = "" Then\r
3129       EchoStream  ex.StdOut, WScript.StdOut, ex, g_ChildHead\r
3130       EchoStream  ex.StdErr, WScript.StdErr, ex, g_ChildHead\r
3131     Else\r
3132       Do Until ex.StdOut.AtEndOfStream : f.WriteLine ex.StdOut.ReadLine : Loop\r
3133       Do Until ex.StdErr.AtEndOfStream : f.WriteLine ex.StdErr.ReadLine : Loop\r
3134     End If\r
3135   Loop\r
3136 \r
3137   If path = "nul" or IsEmpty( path ) Then\r
3138     Do Until ex.StdOut.AtEndOfStream : ex.StdOut.ReadLine : Loop\r
3139     Do Until ex.StdErr.AtEndOfStream : ex.StdErr.ReadLine : Loop\r
3140   ElseIf path = "" Then\r
3141     EchoStream  ex.StdOut, WScript.StdOut, ex, g_ChildHead\r
3142     EchoStream  ex.StdErr, WScript.StdErr, ex, g_ChildHead\r
3143   Else\r
3144     Do Until ex.StdOut.AtEndOfStream : f.WriteLine ex.StdOut.ReadLine : Loop\r
3145     Do Until ex.StdErr.AtEndOfStream : f.WriteLine ex.StdErr.ReadLine : Loop\r
3146   End If\r
3147   WaitForFinishAndRedirect = ex.ExitCode\r
3148 End Function\r
3149 \r
3150 \r
3151  \r
3152 '********************************************************************************\r
3153 '  <<< [EchoStream] echo supported No vbCRLF >>> \r
3154 '********************************************************************************\r
3155 Dim  g_EchoStreamBuf\r
3156 Sub  EchoStream( StreamIn, StreamOut, ex, Prompt )\r
3157   Dim  c, b, i\r
3158 \r
3159   Do Until StreamIn.AtEndOfStream\r
3160     c = StreamIn.Read(1)\r
3161     If c <> vbCR and c <> vbLF Then\r
3162       If g_EchoStreamBuf = "" Then  StreamOut.Write  Prompt\r
3163       g_EchoStreamBuf = g_EchoStreamBuf + c\r
3164     End If\r
3165 \r
3166     '// pause \82Ì\82Ý\91Î\89\9e\r
3167     If Left( g_EchoStreamBuf, 6 ) = "\91±\8ds\82·\82é\82É\82Í" Then\r
3168       i = 0\r
3169       If g_EchoStreamBuf="\91±\8ds\82·\82é\82É\82Í\89½\82©\83L\81[\82ð\89\9f\82µ\82Ä\82\82¾\82³\82¢ . . . " Then  i = 1\r
3170       If g_EchoStreamBuf=Left(g_PauseMsg,g_PauseMsgStone)+"*"+Chr(8) Then  i = 3\r
3171       If g_EchoStreamBuf=g_PauseMsg Then  i = 2\r
3172       If i > 0 Then\r
3173         StreamOut.Write  c\r
3174         If ex.Status = 0 Then\r
3175           If i < 3 Then\r
3176             WScript.StdIn.ReadLine  '// Waiting Enter from only main process\r
3177             If i = 1 Then\r
3178               ex.StdIn.Write  vbCR\r
3179               StreamIn.ReadLine\r
3180             Else\r
3181               ex.StdIn.Write  vbCRLF\r
3182             End If\r
3183           End If\r
3184         End If\r
3185         If not IsEmpty( g_Test ) Then  g_Test.WriteLogLine  g_EchoStreamBuf\r
3186         g_EchoStreamBuf = ""\r
3187         c = ""\r
3188       End If\r
3189     End If\r
3190 \r
3191     '// echo\r
3192     If c = vbLF Then\r
3193       StreamOut.Write  vbLF\r
3194       If not IsEmpty( g_Test ) Then  g_Test.WriteLogLine  g_EchoStreamBuf\r
3195       g_EchoStreamBuf = ""\r
3196     Else\r
3197       StreamOut.Write  c\r
3198     End If\r
3199   Loop\r
3200 End Sub\r
3201 \r
3202 \r
3203  \r
3204 '********************************************************************************\r
3205 '  <<< [ArgumentExist] >>> \r
3206 '********************************************************************************\r
3207 Function  ArgumentExist( name )\r
3208   Dim  key\r
3209   For Each key in WScript.Arguments.Named\r
3210     If key = name  Then  ArgumentExist = True : Exit Function\r
3211   Next\r
3212   ArgumentExist = False\r
3213 End Function\r
3214 \r
3215 \r
3216  \r
3217 '********************************************************************************\r
3218 '  <<< [GetSearchOpenCmdLine] >>> \r
3219 '********************************************************************************\r
3220 Function  GetSearchOpenCmdLine( PathAndName )\r
3221   Dim  cmd\r
3222   Dim  path,  name\r
3223   Dim  i_sep,  i_sharp,  i_kakko,  name_type,  line_num\r
3224   Const  no_name_type = 0,  line_type = 2,  str_type = 3\r
3225 \r
3226 \r
3227   '//=== Get path and name\r
3228   i_sep   = InStrRev( PathAndName, "\" )\r
3229   i_sharp = InStrRev( PathAndName, "#" )\r
3230   If i_sep >= i_sharp Then  '// NoName = (7,5), (0,0), (7,0)\r
3231     path = PathAndName : name = Empty\r
3232   Else  '// WithName = (5,7), (0,7)\r
3233     path = Left( PathAndName, i_sharp - 1 )\r
3234     name = Mid( PathAndName, i_sharp + 1 )\r
3235   End If\r
3236 \r
3237 \r
3238   '//=== Get line number\r
3239   If IsEmpty( name )  and  Right( PathAndName, 1 ) = ")" Then\r
3240     i_kakko = InStrRev( PathAndName, "(" )\r
3241     line_num = Mid( PathAndName,  i_kakko + 1 )\r
3242     line_num = CInt( Left( line_num, Len( line_num ) - 1 ) )\r
3243        '// not use TagJumpPath\r
3244     path = Left( PathAndName, i_kakko - 1 )\r
3245   End If\r
3246 \r
3247 \r
3248   '//=== Check path\r
3249   path = GetAbsPath( path, Empty )\r
3250   If not g_fs.FileExists( path ) Then _\r
3251     Raise  E_FileNotExist, "<ERROR msg='\83t\83@\83C\83\8b\82ª\8c©\82Â\82©\82è\82Ü\82¹\82ñ' path='"+ path +"'/>"\r
3252 \r
3253 \r
3254   '//=== Get command line template\r
3255   If not IsDefined( "Setting_getEditorCmdLine" ) Then\r
3256     cmd = """C:\Windows\notepad.exe"" ""%1"""\r
3257   Else\r
3258     cmd = Setting_getEditorCmdLine( 3 )\r
3259     name_type = str_type\r
3260     If InStr( cmd, "%2" ) = 0 Then  cmd = Empty\r
3261     If IsEmpty( cmd )  and  ( not IsEmpty( line_num )  or  not IsEmpty( name ) ) Then\r
3262       cmd = Setting_getEditorCmdLine( 2 )\r
3263       name_type = line_type\r
3264     End If\r
3265     If IsEmpty( cmd ) Then\r
3266       cmd = Setting_getEditorCmdLine( 1 )\r
3267       name_type = no_name_type\r
3268     End If\r
3269     If IsEmpty( cmd ) Then\r
3270       cmd = Setting_getEditorCmdLine( 0 )\r
3271       cmd = """" + cmd + """ ""%1"""\r
3272     End If\r
3273     If IsEmpty( cmd ) Then\r
3274       cmd = """C:\Windows\notepad.exe"" ""%1"""\r
3275     End If\r
3276   End If\r
3277 \r
3278 \r
3279   '//=== Replace command line\r
3280   Select Case  name_type\r
3281     Case  str_type  : cmd = Replace( cmd, "%2", name )\r
3282     Case  line_type\r
3283       If IsEmpty( line_num ) Then  line_num = GetLineOfSearchOpen( path, name )\r
3284       cmd = Replace( cmd, "%d", CStr( line_num ) )\r
3285   End Select\r
3286   GetSearchOpenCmdLine = Replace( cmd, "%1", path )\r
3287 End Function\r
3288 \r
3289 \r
3290 Function  GetLineOfSearchOpen( Path, Name )\r
3291   Dim  f, line, i\r
3292 \r
3293   Set f = OpenForRead( Path )\r
3294   i = 1\r
3295   Do Until  f.AtEndOfStream\r
3296     line = f.ReadLine()\r
3297     If InStr( line, Name ) > 0 Then\r
3298       GetLineOfSearchOpen = i\r
3299       Exit Function\r
3300     End If\r
3301     i = i + 1\r
3302   Loop\r
3303   f = Empty\r
3304   GetLineOfSearchOpen = 1\r
3305 End Function\r
3306 \r
3307 \r
3308  \r
3309 '********************************************************************************\r
3310 '  <<< [GetDiffCmdLine] >>> \r
3311 '********************************************************************************\r
3312 Function  GetDiffCmdLine( PathA, PathB )\r
3313   If not IsDefined( "Setting_getDiffCmdLine" ) Then\r
3314     echo  "Diff  """ + PathA + """ """ + PathB + """"\r
3315   Else\r
3316     Dim  cmd\r
3317     cmd = Setting_getDiffCmdLine( 2 )\r
3318     cmd = Replace( cmd, "%1", GetTagJumpPath( PathA ) )\r
3319     cmd = Replace( cmd, "%2", GetTagJumpPath( PathB ) )\r
3320     GetDiffCmdLine = cmd\r
3321   End If\r
3322 End Function\r
3323 \r
3324  \r
3325 '********************************************************************************\r
3326 '  <<< [GetDiffCmdLine3] >>> \r
3327 '********************************************************************************\r
3328 Function  GetDiffCmdLine3( PathA, PathB, PathC )\r
3329   If not IsDefined( "Setting_getDiffCmdLine" ) Then\r
3330     echo  "Diff  """ + PathA + """ """ + PathB + """"\r
3331   Else\r
3332     Dim  cmd\r
3333     cmd = Setting_getDiffCmdLine( 3 )\r
3334     cmd = Replace( cmd, "%1", GetTagJumpPath( PathA ) )\r
3335     cmd = Replace( cmd, "%2", GetTagJumpPath( PathB ) )\r
3336     cmd = Replace( cmd, "%3", GetTagJumpPath( PathC ) )\r
3337     GetDiffCmdLine3 = cmd\r
3338   End If\r
3339 End Function\r
3340 \r
3341  \r
3342 '********************************************************************************\r
3343 '  <<< [GetDiffCmdLineMulti] >>> \r
3344 '********************************************************************************\r
3345 Function  GetDiffCmdLineMulti( Files )\r
3346   Dim  op, cmd, i\r
3347 \r
3348   echo "--------------------------------------------------------"\r
3349   For i=0 To UBound( Files )\r
3350     echo (i+1) & ". " & Files(i)(0)\r
3351   Next\r
3352   op = CInt2( input( "Select number>" ) ) - 1\r
3353   echo "--------------------------------------------------------"\r
3354 \r
3355 \r
3356   Select Case UBound( Files(op)(1) )\r
3357 \r
3358     Case 1:  '// 2 files\r
3359       GetDiffCmdLineMulti = GetDiffCmdLine( _\r
3360         GetAbsPath( Files(op)(1)(0) +"\"+ Files(op)(0), Empty ), _\r
3361         GetAbsPath( Files(op)(1)(1) +"\"+ Files(op)(0), Empty ) )\r
3362 \r
3363     Case 2:  '// 3 files\r
3364       GetDiffCmdLineMulti = GetDiffCmdLine3( _\r
3365         GetAbsPath( Files(op)(1)(0) +"\"+ Files(op)(0), Empty ), _\r
3366         GetAbsPath( Files(op)(1)(1) +"\"+ Files(op)(0), Empty ), _\r
3367         GetAbsPath( Files(op)(1)(2) +"\"+ Files(op)(0), Empty ) )\r
3368 \r
3369     Case Else\r
3370       Error\r
3371   End Select\r
3372 End Function\r
3373 \r
3374 \r
3375 \r
3376  \r
3377 '*-------------------------------------------------------------------------*\r
3378 '* ### <<<< Wait >>>> \r
3379 '*-------------------------------------------------------------------------*\r
3380 \r
3381 \r
3382  \r
3383 '********************************************************************************\r
3384 '  <<< [Sleep] >>> \r
3385 '********************************************************************************\r
3386 Sub  Sleep( ByVal msec )\r
3387   echo  ">Sleep  " & msec\r
3388   WScript.Sleep msec\r
3389 End Sub\r
3390 \r
3391 \r
3392  \r
3393 '********************************************************************************\r
3394 '  <<< [WaitForFile] Wait for make the file >>> \r
3395 '********************************************************************************\r
3396 Function  WaitForFile( Path )\r
3397   echo  ">WaitForFile  " & Path\r
3398   Dim  f,en,ed\r
3399 \r
3400   '//=== Wait for file exists\r
3401   f = 0\r
3402   While g_fs.FileExists( Path ) = False\r
3403     WScript.Sleep 1000\r
3404     f=f+1 : If f=3 Then  WScript.Echo  ">WaitForFile  " & Path & " ..."\r
3405   Wend\r
3406 \r
3407 \r
3408   '//=== Open file supported lock\r
3409   Do\r
3410     On Error Resume Next\r
3411       Set f = g_fs.OpenTextFile( Path )\r
3412     en = Err.Number : ed = Err.Description : On Error GoTo 0\r
3413     If en <> E_WriteAccessDenied Then\r
3414       If en <> 0 Then  Err.Raise en,,ed\r
3415       Exit Do\r
3416     End If\r
3417   Loop\r
3418 \r
3419   '//=== Read file supported lock\r
3420   Do\r
3421     On Error Resume Next\r
3422       WaitForFile = f.ReadLine\r
3423     en = Err.Number : ed = Err.Description : On Error GoTo 0\r
3424     If en <> E_EndOfFile Then\r
3425       If en <> 0 Then  Err.Raise en,,ed\r
3426       Exit Do\r
3427     End If\r
3428   Loop\r
3429 \r
3430   f = Empty\r
3431 \r
3432 \r
3433   '//=== Delete file\r
3434   del  Path\r
3435   While  g_fs.FileExists( Path )\r
3436     WScript.Sleep 200  '// Delete may have delay ?\r
3437   WEnd\r
3438 End Function\r
3439 \r
3440 \r
3441  \r
3442 '*-------------------------------------------------------------------------*\r
3443 '* ### <<<< Sound >>>> \r
3444 '*-------------------------------------------------------------------------*\r
3445 \r
3446 \r
3447  \r
3448 '********************************************************************************\r
3449 '  <<< [Play] >>> \r
3450 '********************************************************************************\r
3451 Sub  Play( Path )\r
3452   Player_validate '// g_Player\r
3453 \r
3454   With g_Player.m_Obj\r
3455     .URL = Path\r
3456     '// .PreviewMode = True  '// Cannot play movie because WSH does not have window.\r
3457     .Controls.Play\r
3458   End With\r
3459 End Sub\r
3460 \r
3461  \r
3462 '********************************************************************************\r
3463 '  <<< [SystemSound] >>> \r
3464 '********************************************************************************\r
3465 Sub  SystemSound( Sound )\r
3466   Const  base = "HKEY_CURRENT_USER\AppEvents\Schemes\Apps\"\r
3467   Const  current = "\.Current\"\r
3468   Const  E_PathNotFound = &h80070002\r
3469 \r
3470   Dim  en,ed, parent, reg_path, file_path\r
3471 \r
3472   For Each parent  In Array( ".Default", "Explorer", "devenv", "dexplore", "sapisvr" )\r
3473     reg_path = base + parent +"\"+ Sound + current\r
3474     On Error Resume Next\r
3475       file_path = env( g_sh.RegRead( reg_path ) )\r
3476     en = Err.Number : ed = Err.Description : On Error GoTo 0\r
3477     If en = 0 Then  Exit For\r
3478     If en <> E_PathNotFound Then  Err.Raise en,,ed\r
3479   Next\r
3480   If file_path <> "" and file_path <> reg_path  Then  Play  file_path\r
3481 End Sub\r
3482 \r
3483  \r
3484 '********************************************************************************\r
3485 '  <<< [WaitForSound] >>> \r
3486 '********************************************************************************\r
3487 Sub  WaitForSound( Timeout_msec )\r
3488   Player_validate '// g_Player\r
3489 \r
3490   Dim  i : i = CInt( Timeout_msec / 250 )\r
3491   If IsEmpty( Timeout_msec ) Then  i=9\r
3492   For i=i To 1 Step -1\r
3493     If g_Player.m_Obj.PlayState = 1 Then Exit For\r
3494     If g_Player.m_Obj.PlayState = 10 Then  Raise E_PathNotFound, _\r
3495       "<ERROR msg='Cannot play the file' path='" + g_Player.m_Obj.URL + "'/>"\r
3496     WScript.Sleep  250\r
3497     If IsEmpty( Timeout_msec ) Then  i=9\r
3498   Next\r
3499   g_Player.m_Obj.Controls.Stop\r
3500 End Sub\r
3501  \r
3502 '********************************************************************************\r
3503 '  <<< [SetVolume] >>> \r
3504 '********************************************************************************\r
3505 Sub  SetVolume( Volume )\r
3506   Player_validate '// g_Player\r
3507   g_Player.m_Obj.Settings.Volume = Volume\r
3508 End Sub\r
3509 \r
3510 \r
3511  \r
3512 '********************************************************************************\r
3513 '  <<< [Player_validate] >>> \r
3514 '********************************************************************************\r
3515 Sub  Player_validate()\r
3516   If IsEmpty( g_Player ) Then  Set g_Player = new Vbslib_Player\r
3517 End Sub\r
3518 \r
3519 Class  Vbslib_Player\r
3520   Public  m_Obj\r
3521 \r
3522   Private Sub  Class_Initialize()\r
3523     Set m_Obj = CreateObject( "WMPlayer.OCX" )\r
3524     m_Obj.Settings.Volume = 100\r
3525   End Sub\r
3526 \r
3527   Private Sub  Class_Terminate()\r
3528     Dim  i\r
3529     For i=1 To 12 '// 12 = 3second for sound effects. Music will stop.\r
3530       If m_Obj.PlayState = 1 or m_Obj.PlayState = 10 Then Exit For\r
3531       WScript.Sleep  250\r
3532     Next\r
3533   End Sub\r
3534 End Class\r
3535 \r
3536 \r
3537 \r
3538  \r
3539 '*-------------------------------------------------------------------------*\r
3540 '* ### <<<< Variable, Array and collection >>>> \r
3541 '*-------------------------------------------------------------------------*\r
3542 \r
3543 \r
3544  \r
3545 '********************************************************************************\r
3546 '  <<< [DicItem] >>> \r
3547 '********************************************************************************\r
3548 Function  DicItem( Dic, Key )\r
3549   If not Dic.Exists( Key ) Then  Exit Function\r
3550   If IsObject( Dic.Item( Key ) ) Then  Set DicItem = Dic.Item( Key )  Else  DicItem = Dic.Item( Key )\r
3551 End Function\r
3552 \r
3553 \r
3554  \r
3555 '********************************************************************************\r
3556 '  <<< [DicToArr] >>> \r
3557 '********************************************************************************\r
3558 Sub  DicToArr( Dic, Arr )\r
3559   Dim  keys : keys = Dic.Keys()\r
3560   Dim  key, i\r
3561 \r
3562   ReDim  Arr( UBound( keys ) )\r
3563   i = 0\r
3564   For Each key in keys\r
3565     Set Arr(i) = new DicElem : ErrCheck\r
3566     Arr(i).m_Key = key\r
3567     If IsObject( Dic.Item(key) ) Then\r
3568       Set Arr(i).m_Item = Dic.Item(key)\r
3569     Else\r
3570       Arr(i).m_Item = Dic.Item(key)\r
3571     End If\r
3572     i=i+1\r
3573   Next\r
3574 End Sub\r
3575 \r
3576 Class  DicElem\r
3577   Public  m_Key\r
3578   Public  m_Item\r
3579 End Class\r
3580 \r
3581  \r
3582 '********************************************************************************\r
3583 '  <<< [DicKeyToArr] >>> \r
3584 '********************************************************************************\r
3585 Sub  DicKeyToArr( Dic, Arr )\r
3586   Dim  keys : keys = Dic.Keys()\r
3587   Dim  key, i\r
3588 \r
3589   ReDim  Arr( UBound( keys ) )\r
3590   i = 0\r
3591   For Each key in keys\r
3592     Arr(i) = key\r
3593     i=i+1\r
3594   Next\r
3595 End Sub\r
3596 \r
3597 \r
3598  \r
3599 '********************************************************************************\r
3600 '  <<< [DicItemToArr] >>> \r
3601 '********************************************************************************\r
3602 Sub  DicItemToArr( Dic, Arr )\r
3603   Dim  keys : keys = Dic.Keys()\r
3604   Dim  key, i\r
3605 \r
3606   ReDim  Arr( UBound( keys ) )\r
3607   i = 0\r
3608   For Each key in keys\r
3609     If IsObject( Dic.Item(key) ) Then\r
3610       Set Arr(i) = Dic.Item(key)\r
3611     Else\r
3612       Arr(i) = dic.Item(key)\r
3613     End If\r
3614     i=i+1\r
3615   Next\r
3616 End Sub\r
3617 \r
3618 \r
3619  \r
3620 '********************************************************************************\r
3621 '  <<< [CopyArr] >>> \r
3622 '********************************************************************************\r
3623 Sub  CopyArr( Dst, Src )\r
3624   If g_cut_old Then Stop  ' Do not Dim a().  Dim a,b : b = Array( 1, 2 ) : a = b\r
3625 \r
3626   If IsArray( Src ) Then\r
3627     Dim  i\r
3628 \r
3629     ReDim  Dst( UBound( Src ) )\r
3630     For i=UBound( Src ) To 0 Step -1\r
3631       If IsObject( Src(i) ) Then  Set Dst(i) = Src(i)  Else  Dst(i) = Src(i)\r
3632     Next\r
3633   Else\r
3634     ReDim  Dst(0)\r
3635     If IsObject( Src ) Then  Set Dst(0) = Src  Else  Dst(0) = Src\r
3636   End If\r
3637 End Sub\r
3638 \r
3639  \r
3640 '********************************************************************************\r
3641 '  <<< [AddArrElem] >>> \r
3642 '********************************************************************************\r
3643 Sub  AddArrElem( Dst, Src )\r
3644   If TypeName( Dst ) = "Dictionary" Then\r
3645     Dim  key, obj\r
3646 \r
3647     If IsArray( Src ) Then\r
3648       For Each obj  In Src : If not IsEmpty( obj ) Then\r
3649         If IsObject( obj ) Then  Set Dst.Item( obj.Name ) = obj  Else  Dst.Item( obj ) = True\r
3650       End If : Next\r
3651     ElseIf TypeName( Src ) = "Dictionary" Then\r
3652       For Each key  In Src.Keys()\r
3653         If IsObject( Src.Item( key ) ) Then\r
3654           Set Dst.Item( key ) = Src.Item( key )\r
3655         Else\r
3656           Dst.Item( key ) = Src.Item( key )\r
3657         End If\r
3658       Next\r
3659     Else\r
3660       If IsObject( Src ) Then  Set Dst.Item( Src.Name ) = Src  Else  Dst.Item( Src.Name ) = True\r
3661     End If\r
3662   Else\r
3663     Dim  i, n\r
3664 \r
3665     n = UBound( Dst ) + 1\r
3666     If IsArray( Src ) Then\r
3667       ReDim Preserve  Dst( n + UBound( Src ) )\r
3668       For i=UBound( Src ) To 0 Step -1\r
3669         If IsObject( Src(i) ) Then  Set Dst(n+i) = Src(i)  Else  Dst(n+i) = Src(i)\r
3670       Next\r
3671     ElseIf not IsEmpty( Src ) Then\r
3672       ReDim Preserve  Dst( n )\r
3673       If IsObject( Src ) Then  Set Dst(n) = Src  Else  Dst(n) = Src\r
3674     End IF\r
3675   End IF\r
3676 End Sub\r
3677 \r
3678 \r
3679  \r
3680 '********************************************************************************\r
3681 '  <<< [IsSameArray] >>> \r
3682 '********************************************************************************\r
3683 Function  IsSameArray( Arr1, Arr2 )\r
3684   Dim  i, low, up\r
3685 \r
3686   If IsEmpty( Arr1 ) <> IsEmpty( Arr2 ) Then  IsSameArray = False : Exit Function\r
3687   If IsEmpty( Arr1 ) Then  IsSameArray = True : Exit Function\r
3688 \r
3689   If IsArray( Arr1 ) Then\r
3690     If IsArray( Arr2 ) Then\r
3691       If UBound( Arr1 ) <> UBound( Arr2 ) Then  IsSameArray = False : Exit Function\r
3692     Else\r
3693       If UBound( Arr1 ) <> UBound( Arr2.m_Array ) Then  IsSameArray = False : Exit Function\r
3694     End If\r
3695     low = LBound( Arr1 ) : up = UBound( Arr1 )\r
3696   Else\r
3697     If IsArray( Arr2 ) Then\r
3698       If UBound( Arr1.m_Array ) <> UBound( Arr2 ) Then  IsSameArray = False : Exit Function\r
3699     Else\r
3700       If UBound( Arr1.m_Array ) <> UBound( Arr2.m_Array ) Then  IsSameArray = False : Exit Function\r
3701     End If\r
3702     low = 0 : up = UBound( Arr1.m_Array )\r
3703   End If\r
3704 \r
3705   For i = low To up\r
3706     If Arr1(i) <> Arr2(i) Then  IsSameArray = False : Exit Function\r
3707   Next\r
3708   IsSameArray = True\r
3709 End Function\r
3710 \r
3711 \r
3712 \r
3713  \r
3714 '********************************************************************************\r
3715 '  <<< [QuickSort_fromDic] >>> \r
3716 'dic as Scripting.Dictionary\r
3717 'out_arr as [out] object array\r
3718 '********************************************************************************\r
3719 Sub  QuickSort_fromDic( dic, out_arr, compare_func, param )\r
3720   Dim    i, i_last, elem\r
3721   i_last = dic.Count - 1\r
3722   Redim  out_arr( i_last )\r
3723 \r
3724   i=0\r
3725   For Each elem  In dic.Items\r
3726     Set out_arr(i) = elem\r
3727     i = i + 1\r
3728   Next\r
3729 \r
3730   QuickSort  out_arr, 0, i_last, compare_func, param\r
3731 End Sub\r
3732 \r
3733 \r
3734 \r
3735  \r
3736 '********************************************************************************\r
3737 '  <<< [QuickSort] >>> \r
3738 '********************************************************************************\r
3739 Sub  QuickSort( arr, i_left, i_right, compare_func, param )\r
3740   Dim  pivot, i_pivot, i_big, i_small, sw\r
3741 \r
3742   If i_left >= i_right Then Exit Sub  ' rule-b'\r
3743 \r
3744   i_pivot = ( i_left + i_right ) \ 2\r
3745   Set pivot = arr( i_pivot )\r
3746 \r
3747 \r
3748   '//== for debug\r
3749   ' Dim  i, sym, value\r
3750   ' echo "QuickSort start ----------------------"\r
3751   ' For i = i_left To i_right\r
3752   '   QuickSort_Debug_getSym  arr, i, sym, value\r
3753   '   If i = i_pivot Then  value = value & " (pivot)"\r
3754   '   echo "(" & i & ") " & sym & " = " & value\r
3755   ' Next\r
3756   ' If i_left = 0 and i_right = 4 Then  Stop\r
3757 \r
3758 \r
3759   i_big = i_left : i_small = i_right\r
3760   Do\r
3761     '// Plus i_big if arr(i_big) is smaller than pivot\r
3762     Do\r
3763       If compare_func( arr(i_big), pivot, param ) >= 0 Then  Exit Do\r
3764       i_big = i_big + 1\r
3765     Loop\r
3766 \r
3767     '// Set i_small on equal or bigger than pivot\r
3768     Do\r
3769       If i_small < i_pivot and i_small < i_big Then\r
3770         If i_big < i_pivot Then\r
3771           i_small = i_pivot : Exit Do\r
3772         ElseIf i_small >= i_left Then\r
3773           Exit Do\r
3774         Else\r
3775           Exit Sub  ' rule-c\r
3776         End If\r
3777       End If\r
3778       If compare_func( arr(i_small), pivot, param ) < 0 Then  Exit Do\r
3779       i_small = i_small - 1\r
3780     Loop\r
3781 \r
3782     '// Swap\r
3783     If i_big < i_small Then  ' rule-a\r
3784       Set sw = arr(i_big) : Set arr(i_big) = arr(i_small) : Set arr(i_small) = sw\r
3785       If i_big   = i_pivot Then  i_pivot = i_small\r
3786       If i_small = i_pivot Then\r
3787         i_big = i_big + 1\r
3788         If i_big >= i_small Then  Exit Do   ' rule-c'\r
3789       End If\r
3790       If i_pivot > i_small Then  i_small = i_pivot\r
3791     Else\r
3792       Exit Do\r
3793     End If\r
3794   Loop\r
3795 \r
3796 \r
3797   '//== for debug\r
3798   ' echo "QuickSort middle ----------------------"\r
3799   ' For i = i_left To i_right\r
3800   '   QuickSort_Debug_getSym  arr, i, sym, value\r
3801   '   If i = i_big-1 Then  value = value & " (i_big-1)"\r
3802   '   If i = i_big   Then  value = value & " (i_big)"\r
3803   '   echo "(" & i & ") " & sym & " = " & value\r
3804   ' Next\r
3805 \r
3806 \r
3807   QuickSort  arr, i_left, i_big-1, compare_func, param  ' rule-b\r
3808   QuickSort  arr, i_big,  i_right, compare_func, param  ' rule-b\r
3809 \r
3810 \r
3811   '//== for debug\r
3812   ' echo "QuickSort end ----------------------"\r
3813   ' For i = i_left To i_right\r
3814   '   QuickSort_Debug_getSym  arr, i, sym, value\r
3815   '   echo "(" & i & ") " & sym & " = " & value\r
3816   ' Next\r
3817 End Sub\r
3818 \r
3819 \r
3820 '//== for debug\r
3821 'Sub  QuickSort_Debug_getSym( Arr, Index, out_Symbol, out_Value )\r
3822 '  out_Symbol = Index\r
3823 '  out_Value  = Arr(Index).id\r
3824 'End Sub\r
3825 \r
3826 \r
3827  \r
3828 '********************************************************************************\r
3829 '  <<< [ShakerSort_fromDic] >>> \r
3830 'dic as Scripting.Dictionary\r
3831 'out_arr as [out] object array\r
3832 '********************************************************************************\r
3833 Sub  ShakerSort_fromDic( dic, out_arr, sign, compare_func, param )\r
3834   Dim    i, i_last, elem\r
3835   i_last = dic.Count - 1\r
3836   Redim  out_arr( i_last )\r
3837 \r
3838   If sign >= 0 Then\r
3839     i=0\r
3840     For Each elem  In dic.Items\r
3841       Set out_arr(i) = elem\r
3842       i = i + 1\r
3843     Next\r
3844   Else\r
3845     i=i_last\r
3846     For Each elem  In dic.Items\r
3847       Set out_arr(i) = elem\r
3848       i = i - 1\r
3849     Next\r
3850   End If\r
3851 \r
3852   ShakerSort  out_arr, 0, i_last, compare_func, param\r
3853 End Sub\r
3854 \r
3855 \r
3856  \r
3857 '********************************************************************************\r
3858 '  <<< [ShakerSort] >>> \r
3859 '********************************************************************************\r
3860 Sub  ShakerSort( arr, ByVal i_left, ByVal i_right, compare_func, param )\r
3861   Dim  i_swap, i, sw\r
3862 \r
3863   Do\r
3864     i_swap = i_left+1\r
3865     For i=i_left+1 To i_right\r
3866       If compare_func( arr(i-1), arr(i), param ) > 0 Then\r
3867         Set sw = arr(i-1) : Set arr(i-1) = arr(i) : Set arr(i) = sw\r
3868         i_swap = i\r
3869       End If\r
3870     Next\r
3871     If i_swap = i_left+1 Then Exit Do\r
3872     i_right = i_swap-1\r
3873 \r
3874     i_swap = i_right-1\r
3875     For i=i_right-1 To i_left Step -1\r
3876       If compare_func( arr(i), arr(i+1), param ) > 0 Then\r
3877         Set sw = arr(i) : Set arr(i) = arr(i+1) : Set arr(i+1) = sw\r
3878         i_swap = i\r
3879       End If\r
3880     Next\r
3881     If i_swap = i_right-1 Then Exit Do\r
3882     i_left = i_swap+1\r
3883   Loop\r
3884 End Sub\r
3885 \r
3886 \r
3887  \r
3888 '********************************************************************************\r
3889 '  <<< [CInt2] >>> \r
3890 ' - no exception\r
3891 '********************************************************************************\r
3892 Function  CInt2( v )\r
3893   Dim  en, ed\r
3894 \r
3895   On Error Resume Next\r
3896     CInt2 = CInt( v )\r
3897   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
3898   If en = 13 Then  '// if sym is not number\r
3899     CInt2 = 0\r
3900   ElseIf en <> 0 Then  Err.Raise en,,ed  End If\r
3901 End Function\r
3902 \r
3903 \r
3904  \r
3905 '********************************************************************************\r
3906 '  <<< [MeltQuot] >>> \r
3907 '********************************************************************************\r
3908 Function  MeltQuot( Line, in_out_Start )\r
3909   Dim  i, j, c\r
3910 \r
3911 \r
3912   '//=== Skip to "\r
3913   i = in_out_Start\r
3914   Do\r
3915     c = Mid( Line, i, 1 )\r
3916     If c = "" Then  in_out_Start = 0 : Exit Function\r
3917     If c = """"  Then Exit Do\r
3918     i = i + 1\r
3919   Loop\r
3920   j = i + 1\r
3921 \r
3922 \r
3923   '//=== Search the end of "\r
3924   i = j\r
3925   Do\r
3926     c = Mid( Line, i, 1 )\r
3927     If c = "" Then  in_out_Start = 0 : Exit Do\r
3928     If c = """"  Then  in_out_Start = i + 1 : Exit Do\r
3929     i = i + 1\r
3930   Loop\r
3931 \r
3932 \r
3933   '//=== Get the string\r
3934   MeltQuot = Mid( Line, j, i - j )\r
3935 \r
3936 End Function\r
3937 \r
3938 \r
3939  \r
3940 '********************************************************************************\r
3941 '  <<< [CreateGuid] >>> \r
3942 '********************************************************************************\r
3943 Dim  g_TypeLib\r
3944 \r
3945 Function  CreateGuid()\r
3946   If g_TestModeFlags and F_NotRandom Then\r
3947     g_TypeLib = g_TypeLib + 1\r
3948     CreateGuid = "00000000-0000-0000-0000-" & Right( "000000000000" & g_TypeLib, 12 )\r
3949   Else\r
3950     If IsEmpty( g_TypeLib ) Then  Set g_TypeLib = CreateObject("Scriptlet.TypeLib")\r
3951     CreateGuid = Mid( g_TypeLib.Guid, 2, 36 )\r
3952   End IF\r
3953 End Function\r
3954 \r
3955 \r
3956  \r
3957 '********************************************************************************\r
3958 '  <<< [ReplaceTextFile] >>> \r
3959 '********************************************************************************\r
3960 Class  ReplaceItem\r
3961   Public  Src\r
3962   Public  Dst\r
3963 End Class\r
3964 \r
3965 Sub  new_ReplaceItem( objs, n )\r
3966   Dim i:ReDim objs(n-1):For i=0 To n-1:Set objs(i)=new ReplaceItem :Next : ErrCheck\r
3967 End Sub\r
3968 \r
3969 Sub  ReplaceTextFile( SrcPath, TmpDstPath, bDstWillBeExist, ReplaceList, Opt )\r
3970   echo  ">ReplaceTextFile  """ & SrcPath & """, """ & TmpDstPath & """, " & bDstWillBeExist\r
3971   Dim rep, item, line\r
3972 \r
3973   Set rep = StartReplace( SrcPath, TmpDstPath, bDstWillBeExist )\r
3974   Do Until rep.r.AtEndOfStream\r
3975     line = rep.r.ReadLine\r
3976     For Each  item  In ReplaceList\r
3977       line = Replace( line, item.Src, item.Dst )\r
3978     Next\r
3979     rep.w.WriteLine  line\r
3980   Loop\r
3981   rep.Finish\r
3982 End Sub\r
3983 \r
3984 \r
3985  \r
3986 '********************************************************************************\r
3987 '  <<< [StartReplace] >>> \r
3988 '********************************************************************************\r
3989 Function  StartReplace( SrcPath, TmpDstPath, bDstWillBeExist )\r
3990   echo  ">StartReplace  """ & SrcPath & """, """ & TmpDstPath & """, " & bDstWillBeExist\r
3991   Dim  ec : Set ec = new EchoOff : ErrCheck\r
3992   Dim  m : Set m = new StartReplaceObj : ErrCheck\r
3993   m.Init1  SrcPath, TmpDstPath, bDstWillBeExist\r
3994   Set StartReplace = m\r
3995 End Function\r
3996 \r
3997 \r
3998  \r
3999 '********************************************************************************\r
4000 '  <<< [StartReplace2] >>> \r
4001 '********************************************************************************\r
4002 Function  StartReplace2( SrcPath, MidPath, Flags, TmpDstPath, bDstWillBeExist )\r
4003   echo  ">StartReplace2  """ & SrcPath & """, """ & MidPath & """, """ & TmpDstPath & """, " & bDstWillBeExist\r
4004   Dim  ec : Set ec = new EchoOff : ErrCheck\r
4005   Dim  m : Set m = new StartReplaceObj : ErrCheck\r
4006   m.Init2  SrcPath, MidPath, Flags, TmpDstPath, bDstWillBeExist\r
4007   Set StartReplace2 = m\r
4008 End Function\r
4009 \r
4010 \r
4011 Dim  F_Txt2BinTxt : F_Txt2BinTxt = 2\r
4012 \r
4013 \r
4014 Class  StartReplaceObj\r
4015   Public  m_SrcPath  ' as string\r
4016   Public  m_TmpDstPath  ' as string\r
4017   Public  m_bDstWillBeExist  ' as boolean\r
4018 \r
4019   Public  m_MidPath  ' as string\r
4020   Public  m_Flags  ' as bitfield\r
4021 \r
4022   Public  r  ' as TextStream of m_SrcPath\r
4023   Public  w  ' as TextStream of m_TmpDstPath\r
4024 \r
4025   Private  m_bFinished\r
4026 \r
4027 \r
4028 Public Sub  Init1( SrcPath, TmpDstPath, bDstWillBeExist )\r
4029   Dim en,ed\r
4030   Dim  ec : Set ec = new EchoOff : ErrCheck\r
4031 \r
4032   m_SrcPath = SrcPath\r
4033   m_TmpDstPath = TmpDstPath\r
4034   m_bDstWillBeExist = bDstWillBeExist\r
4035 \r
4036   mkdir    g_fs.GetParentFolderName( g_fs.GetAbsolutePathName( m_TmpDstPath ) )\r
4037   Set Me.r = OpenTextFile( m_SrcPath )\r
4038 \r
4039   On Error Resume Next\r
4040     Set Me.w = g_fs.CreateTextFile( m_TmpDstPath, bDstWillBeExist, (g_TextFileConvertFormat = F_Unicode) )\r
4041   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
4042   If en = E_AlreadyExist Then  Err.Raise en,, "\8aù\82É\93¯\96¼\82Ì\83t\83@\83C\83\8b\82ª\91¶\8dÝ\82µ\82Ä\82¢\82Ü\82·\81B: " + m_TmpDstPath\r
4043   If en <> 0 Then  Err.Raise en,,ed\r
4044 End Sub\r
4045 \r
4046 \r
4047 Public Sub  Init2( SrcPath, MidPath, Flags, TmpDstPath, bDstWillBeExist )\r
4048   Init1  SrcPath, MidPath, bDstWillBeExist\r
4049   m_MidPath = MidPath\r
4050   m_TmpDstPath = TmpDstPath\r
4051   m_Flags = Flags or 1\r
4052 End Sub\r
4053 \r
4054 \r
4055 Public Sub  Finish()\r
4056   Dim  ec : Set ec = new EchoOff : ErrCheck\r
4057   Me.r = Empty\r
4058   Me.w = Empty\r
4059 \r
4060   If not IsEmpty( m_MidPath ) Then\r
4061     If m_Flags and F_Txt2BinTxt Then\r
4062       Txt2BinTxt  m_MidPath, m_TmpDstPath\r
4063     Else\r
4064       copy  m_MidPath, m_TmpDstPath\r
4065     End If\r
4066     del  m_MidPath\r
4067   End If\r
4068 \r
4069   If not m_bDstWillBeExist Then\r
4070     copy  m_TmpDstPath, m_SrcPath\r
4071     del   m_TmpDstPath\r
4072   End If\r
4073   m_bFinished = True\r
4074 End Sub\r
4075 \r
4076 \r
4077 Public Sub  ExitFinish( Opt )\r
4078   m_bFinished = True\r
4079   Class_Terminate\r
4080   If not IsEmpty( m_MidPath ) Then  del  m_MidPath\r
4081   del  m_TmpDstPath\r
4082 End Sub\r
4083 \r
4084 \r
4085 Private Sub  Class_Terminate()\r
4086   Dim  en,ed : en = Err.Number : ed = Err.Description\r
4087   On Error Resume Next  ' This clears the error\r
4088     Me.r = Empty\r
4089     Me.w = Empty\r
4090     If en <> 0 and en <> 21 Then  del  m_TmpDstPath\r
4091     ErrorCheckInTerminate\r
4092   If en = 0 and not m_bFinished Then  NotCallFinish\r
4093   On Error GoTo 0 : If en <> 0 Then  Err.Raise en,,ed\r
4094 End Sub\r
4095 \r
4096 \r
4097 End Class\r
4098 \r
4099 \r
4100  \r
4101 '********************************************************************************\r
4102 '  <<< [TextFileCreateFormat] >>> \r
4103 '********************************************************************************\r
4104 Dim  g_TextFileCreateFormat\r
4105 Class  TextFileCreateFormat\r
4106   Public  m_Prev\r
4107   Private Sub  Class_Initialize() : m_Prev = g_TextFileCreateFormat : End Sub\r
4108   Public  Sub  Set_( Format ) : g_TextFileCreateFormat = Format : End Sub\r
4109   Private Sub Class_Terminate : g_TextFileCreateFormat = m_Prev : End Sub\r
4110 End Class\r
4111 \r
4112 \r
4113  \r
4114 '********************************************************************************\r
4115 '  <<< [TextFileConvertFormat] >>> \r
4116 '********************************************************************************\r
4117 Dim  g_TextFileConvertFormat\r
4118 Class  TextFileConvertFormat\r
4119   Public  m_Prev\r
4120   Private Sub  Class_Initialize() : m_Prev = g_TextFileConvertFormat : End Sub\r
4121   Public  Sub  Set_( Format ) : g_TextFileConvertFormat = Format : End Sub\r
4122   Private Sub Class_Terminate : g_TextFileConvertFormat = m_Prev : End Sub\r
4123 End Class\r
4124 \r
4125 \r
4126  \r
4127 '-------------------------------------------------------------------------\r
4128 ' ### <<<< [ArrayClass] Class >>>> \r
4129 '-------------------------------------------------------------------------\r
4130 \r
4131 Class  ArrayClass\r
4132   Public  m_Array\r
4133 \r
4134   Private Sub  Class_Initialize\r
4135     ReDim  m_Array( -1 )\r
4136   End Sub\r
4137 \r
4138   Public Default Property Get  Item( i )\r
4139     If IsObject( m_Array(i) ) Then  Set Item = m_Array(i)  Else Item = m_Array(i)\r
4140   End Property\r
4141 \r
4142   Public Property Let  Item( i, value )\r
4143     m_Array(i) = value\r
4144   End Property\r
4145 \r
4146   Public Sub  ToEmpty()\r
4147     ReDim  m_Array( -1 )\r
4148   End Sub\r
4149 \r
4150   Public Sub  ReDim_( UBoundValue )\r
4151     ReDim Preserve  m_Array( UBoundValue )\r
4152   End Sub\r
4153 \r
4154   Public Sub  Add( elem )\r
4155     Push  elem\r
4156   End Sub\r
4157 \r
4158   Public Sub  Push( elem )\r
4159     ReDim Preserve  m_Array( UBound(m_Array) + 1 )\r
4160     If IsObject( elem ) Then\r
4161       Set m_Array( UBound(m_Array) ) = elem\r
4162     Else\r
4163       m_Array( UBound(m_Array) ) = elem\r
4164     End If\r
4165   End Sub\r
4166 \r
4167   Public Function  Pop()\r
4168     If IsObject( m_Array( UBound(m_Array) ) ) Then\r
4169       Set Pop = m_Array( UBound(m_Array) )\r
4170     Else\r
4171       Pop = m_Array( UBound(m_Array) )\r
4172     End If\r
4173     ReDim Preserve  m_Array( UBound(m_Array) - 1 )\r
4174   End Function\r
4175 \r
4176   Public Property Get  Count()\r
4177     Count = UBound(m_Array) + 1\r
4178   End Property\r
4179 \r
4180   Public Property Get  UBound_()\r
4181     UBound_ = UBound(m_Array)\r
4182   End Property\r
4183 \r
4184   Public Sub  Echo()\r
4185     WScript.Echo  Value\r
4186   End Sub\r
4187 \r
4188   Public Property Get  Value()\r
4189     Dim  s, i, e\r
4190 \r
4191     s = "count = " & Count\r
4192     For Each i In m_Array\r
4193       If IsObject( i ) Then\r
4194         s = s + vbCRLF + "Class " & TypeName( i )\r
4195         On Error Resume Next\r
4196           s = s + vbCRLF + i.Value\r
4197           e = Err.Number\r
4198         On Error GoTo 0\r
4199         If e <> 0 And e <> 438 Then  Err.Raise e\r
4200       Else\r
4201         s = s + vbCRLF +  "each = " & i\r
4202       End If\r
4203     Next\r
4204     Value = s\r
4205   End Property\r
4206 \r
4207   Public Sub  Copy( SrcArr )\r
4208     If IsArray( SrcArr ) Then\r
4209       m_Array = SrcArr\r
4210     ElseIf TypeName( SrcArr ) = "ArrayClass" Then\r
4211       m_Array = SrcArr.m_Array\r
4212     Else\r
4213       Err.Raise  1\r
4214     End If\r
4215   End Sub\r
4216 \r
4217   Public Sub  AddElems( SrcArr )\r
4218     If IsArray( SrcArr ) Then\r
4219       AddArrElem  m_Array, SrcArr\r
4220     ElseIf TypeName( SrcArr ) = "ArrayClass" Then\r
4221       AddArrElem  m_Array, SrcArr.m_Array\r
4222     Else\r
4223       Me.Add  SrcArr\r
4224     End If\r
4225   End Sub\r
4226 End Class\r
4227 \r
4228 \r
4229  \r
4230 '-------------------------------------------------------------------------\r
4231 ' ### <<<< [ArrayDictionary] Class >>>> \r
4232 '-------------------------------------------------------------------------\r
4233 \r
4234 Class  ArrayDictionary\r
4235 \r
4236   Public  m_Dic\r
4237 \r
4238   Private Sub  Class_Initialize\r
4239     Set  m_Dic = CreateObject("Scripting.Dictionary")\r
4240   End Sub\r
4241 \r
4242   Public Sub  ToEmpty\r
4243     m_Dic.RemoveAll\r
4244   End Sub\r
4245 \r
4246   Public Sub  Add( key, item )\r
4247     Dim  dic_item\r
4248 \r
4249     If m_Dic.Exists( key ) Then\r
4250       m_Dic.Item( key ).Add  item\r
4251     Else\r
4252       Set  dic_item = New ArrayClass : ErrCheck\r
4253       dic_item.Add  item\r
4254       m_Dic.Add  key, dic_item\r
4255     End If\r
4256   End Sub\r
4257 \r
4258   Public Function  Count\r
4259     Dim  i\r
4260     Count = 0\r
4261     For Each i in m_Dic.Items()\r
4262       Count = Count + i.Count\r
4263     Next\r
4264   End Function\r
4265 \r
4266   Public Sub  Echo\r
4267     Dim  i, n\r
4268 \r
4269     WScript.Echo  "--- ArrayDictionary ------------------------------"\r
4270     WScript.Echo  "key  count = " & m_Dic.Count\r
4271 \r
4272     WScript.Echo  "item count = " & Count\r
4273 \r
4274     For Each i in m_Dic.Keys()\r
4275       WScript.Echo  "key=""" & i & """"\r
4276       m_Dic.Item(i).Echo\r
4277     Next\r
4278     WScript.Echo ""\r
4279   End Sub\r
4280 \r
4281 End Class\r
4282 \r
4283 \r
4284  \r
4285 '-------------------------------------------------------------------------\r
4286 ' ### <<<< [StringStream] Class >>>> \r
4287 '-------------------------------------------------------------------------\r
4288 \r
4289 Class  StringStream\r
4290 \r
4291   Public   m_Str\r
4292   Public   m_INextLine\r
4293   Private  m_RaedLine, m_WriteLine, m_bPrevIsWrite\r
4294   Public Property Get Line()\r
4295     If m_bPrevIsWrite Then  Line = m_WriteLine  Else  Line = m_ReadLine\r
4296   End Property\r
4297 \r
4298   Public  Sub  SetString( Str )\r
4299     m_Str = Str\r
4300     m_INextLine = 1\r
4301     m_RaedLine = 1\r
4302     m_WriteLine = 1\r
4303   End Sub\r
4304 \r
4305   Public Function  ReadLine()\r
4306     Dim  i\r
4307 \r
4308     i = InStr( m_INextLine, m_Str, vbCRLF )\r
4309     If i > 0 Then\r
4310       ReadLine = Mid( m_Str, m_INextLine, i - m_INextLine )\r
4311       m_INextLine = i + 2\r
4312     Else\r
4313       ReadLine = Mid( m_Str, m_INextLine )\r
4314       m_Str = Empty\r
4315       m_INextLine = Empty\r
4316     End If\r
4317     m_RaedLine = m_RaedLine + 1\r
4318   End Function\r
4319 \r
4320   Public Function  ReadAll()\r
4321     ReadAll = m_Str\r
4322     m_Str = Empty\r
4323   End Function\r
4324 \r
4325   Public Property Get AtEndOfStream : AtEndOfStream = IsEmpty( m_Str ) : End Property\r
4326   Public Sub  Write( Str ) : m_Str = m_Str + Str : End Sub\r
4327   Public Sub  WriteLine( LineStr ) : m_Str = m_Str + LineStr + vbCRLF : m_WriteLine = m_WriteLine + 1 : End Sub\r
4328 End Class\r
4329 \r
4330 \r
4331  \r
4332 '-------------------------------------------------------------------------\r
4333 ' ### <<<< [StrMatchKey] Class >>>> \r
4334 '-------------------------------------------------------------------------\r
4335 Class  StrMatchKey\r
4336 \r
4337   Public Property Let  Keyword( s )\r
4338     m_Keyword = s\r
4339     m_LeftCount = InStr( s, "*" ) - 1\r
4340     m_LeftStr = Left( s, m_LeftCount )\r
4341     m_RightCount = Len( s ) - m_LeftCount - 1\r
4342     m_RightStr = Right( s, m_RightCount )\r
4343 \r
4344     If InStr( m_LeftCount + 2, s, "*" ) > 0 Then _\r
4345       Raise  1,"* \82ð\95¡\90\94\8ew\92è\82·\82é\82±\82Æ\82Í\82Å\82«\82Ü\82¹\82ñ"\r
4346   End Property\r
4347 \r
4348   Public Property Get  Keyword()\r
4349     Keyword = m_Keyword\r
4350   End Property\r
4351 \r
4352 \r
4353   Public Function  IsMatch( TestStr )\r
4354     '// m_Keyword must be low case\r
4355 \r
4356     If LCase( Right( TestStr, m_RightCount ) ) = m_RightStr Then\r
4357       If m_LeftCount = 0 Then  IsMatch = True : Exit Function\r
4358       If LCase( Left( TestStr, m_LeftCount ) ) = m_LeftStr Then\r
4359         IsMatch = True\r
4360       End If\r
4361     End If\r
4362   End Function\r
4363 \r
4364   Public Function  IsMatchULCase( TestStr )\r
4365     If Right( TestStr, m_RightCount ) = m_RightStr Then\r
4366       If m_LeftCount = 0 Then  IsMatchULCase = True : Exit Function\r
4367       If Left( TestStr, m_LeftCount ) = m_LeftStr Then\r
4368         IsMatchULCase = True\r
4369       End If\r
4370     End If\r
4371   End Function\r
4372 \r
4373 \r
4374   Public  m_Keyword\r
4375   Public  m_LeftCount\r
4376   Public  m_RightCount\r
4377   Public  m_LeftStr\r
4378   Public  m_RightStr\r
4379 End Class\r
4380 \r
4381 \r
4382  \r
4383 '********************************************************************************\r
4384 '  <<< [LenK] >>> \r
4385 '********************************************************************************\r
4386 Function  LenK( Str )\r
4387   Dim  c, a, i, n_zen\r
4388 \r
4389   i = 1 : n_zen = 0\r
4390   Do\r
4391     c = Mid( Str, i, 1 )\r
4392     If c = "" Then  LenK = i - 1 + n_zen : Exit Function\r
4393     a = Asc( c )\r
4394     If a >= 256 or a < 0 Then  n_zen = n_zen + 1\r
4395     i = i + 1\r
4396   Loop\r
4397 End Function\r
4398 \r
4399 \r
4400  \r
4401 '********************************************************************************\r
4402 '  <<< [DateAddStr] >>> \r
4403 '********************************************************************************\r
4404 Function  DateAddStr( BaseDate, Plus )\r
4405   Dim  i, i2, c, flag, num, unit, i_over\r
4406 \r
4407   DateAddStr = BaseDate\r
4408   i=1\r
4409   i_over = Len( Plus ) + 1\r
4410 \r
4411   '//=== Skip spaces\r
4412   While Mid( Plus, i, 1 ) = " " : i=i+1 : WEnd\r
4413 \r
4414   '//=== Get flag\r
4415   flag = +1\r
4416   c = Mid( Plus, i, 1 )\r
4417   If c = "+" Then\r
4418     i=i+1\r
4419   ElseIf c = "-" Then\r
4420     flag = -1 : i=i+1\r
4421   End If\r
4422 \r
4423   Do\r
4424 \r
4425     '//=== Skip spaces\r
4426     While Mid( Plus, i, 1 ) = " " : i=i+1 : WEnd\r
4427 \r
4428     If i = i_over Then  Exit Do\r
4429 \r
4430     '//=== Get number\r
4431     c = Mid( Plus, i, 1 )\r
4432     i2 = i\r
4433     While (c >= "0" and c <= "9") or c="-" or c="+" : i2=i2+1 : c = Mid( Plus, i2, 1 ) : WEnd\r
4434     num = CInt( Mid( Plus, i, i2 - i ) )\r
4435     i = i2\r
4436 \r
4437     '//=== Skip spaces\r
4438     While Mid( Plus, i, 1 ) = " " : i=i+1 : WEnd\r
4439 \r
4440     '//=== Get unit\r
4441     c = Mid( Plus, i, 1 )\r
4442     i2 = i\r
4443     While (c >= "a" and c <= "z") or (c >= "A" and c <= "Z") : i2=i2+1 : c = Mid( Plus, i2, 1 ) : WEnd\r
4444     Select Case  LCase( Mid( Plus, i, i2 - i ) )\r
4445       Case "year",  "years"  : unit = "yyyy"\r
4446       Case "month", "months" : unit = "m"\r
4447       Case "day",   "days"   : unit = "d"\r
4448       Case "hour",  "hours"  : unit = "h"\r
4449       Case "minute","minutes","min": unit = "n"\r
4450       Case "second","seconds","sec": unit = "s"\r
4451       Case Else  Err.Raise  1,,"\92P\88Ê\82ª\82¨\82©\82µ\82¢"\r
4452     End Select\r
4453     i = i2\r
4454 \r
4455     '//=== Add Date\r
4456     DateAddStr = DateAdd( unit, flag * num, DateAddStr )\r
4457 \r
4458   Loop\r
4459 End Function\r
4460 \r
4461  \r
4462 '*-------------------------------------------------------------------------*\r
4463 '* ### <<<< System (safe part) >>>> \r
4464 '*-------------------------------------------------------------------------*\r
4465 \r
4466 \r
4467  \r
4468 '********************************************************************************\r
4469 '  <<< [RegRead] >>> \r
4470 '********************************************************************************\r
4471 Function  RegRead( Path )\r
4472   Dim  e\r
4473   If TryStart(e) Then  On Error Resume Next\r
4474     RegRead = g_sh.RegRead( Path )\r
4475   If TryEnd Then  On Error GoTo 0\r
4476   If e.num = E_PathNotFound or e.num = E_WIN32_FILE_NOT_FOUND Then\r
4477    e.Clear\r
4478   End If\r
4479   If e.num <> 0 Then  e.Raise\r
4480 End Function\r
4481 \r
4482 \r
4483 \r
4484  \r
4485 '********************************************************************************\r
4486 '  <<< [RegEnumKey] >>> \r
4487 '********************************************************************************\r
4488 Sub  RegEnumKey( ByVal Path, out_Keys, Opt )\r
4489   ReDim  out_Keys(0)\r
4490   Dim    keys, key, i, u\r
4491 \r
4492   If IsEmpty( Opt ) Then  RegEnumKey_sub  Path, out_Keys : Exit Sub\r
4493 \r
4494   i = 0 : u = 0\r
4495   out_Keys(0) = Path\r
4496 \r
4497   Do\r
4498     RegEnumKey_sub  out_Keys(i), keys '// get keys\r
4499 \r
4500     If not IsNull( keys ) Then\r
4501       For Each key  In keys\r
4502         u=u+1\r
4503         ReDim Preserve  out_Keys( u + 1 )\r
4504         out_Keys(u) = out_Keys(i) + "\" + key\r
4505       Next\r
4506     End If\r
4507     i=i+1\r
4508     If i > u Then  Exit Do\r
4509   Loop\r
4510 End Sub\r
4511 \r
4512 \r
4513 Sub  RegEnumKey_sub( ByVal Path, out_Keys )\r
4514   Dim  reg, i, root_key\r
4515 \r
4516   i = InStr( Path, "\" )\r
4517   Select Case  Left( Path, i - 1 )\r
4518     Case "HKEY_CLASSES_ROOT"  : root_key = &h80000000\r
4519     Case "HKEY_CURRENT_USER"  : root_key = &h80000001\r
4520     Case "HKEY_LOCAL_MACHINE" : root_key = &h80000002\r
4521     Case "HKEY_USERS"         : root_key = &h80000003\r
4522     Case "HKEY_PERFORMANCE_DATA":root_key= &h80000004\r
4523     Case "HKEY_CURRENT_CONFIG": root_key = &h80000005\r
4524     Case "HKEY_DYN_DATA"      : root_key = &h80000006\r
4525     Case Else : Err.Raise  &h80070002\r
4526   End Select\r
4527 \r
4528   Path = Mid( Path, i + 1 )\r
4529 \r
4530   If IsEmpty( g_reg ) Then _\r
4531     Set g_reg = GetObject("winmgmts:{impersonationLevel=impersonate}!root/default:StdRegProv")\r
4532   g_reg.EnumKey  root_key, Path, out_Keys\r
4533 \r
4534   If IsNull( out_Keys ) Then  ReDim  out_Keys(-1)\r
4535 End Sub\r
4536 \r
4537 \r
4538  \r
4539 '********************************************************************************\r
4540 '  <<< [RegEnumValues] >>> \r
4541 '********************************************************************************\r
4542 Class  RegValueName\r
4543   Public  Name\r
4544   Public  Type_\r
4545 End Class\r
4546 \r
4547 \r
4548 Sub  RegEnumValues( ByVal Path, out_Values )\r
4549   Dim  reg, i, root_key, names, types\r
4550 \r
4551   i = InStr( Path, "\" )\r
4552   Select Case  Left( Path, i - 1 )\r
4553     Case "HKEY_CLASSES_ROOT"  : root_key = &h80000000\r
4554     Case "HKEY_CURRENT_USER"  : root_key = &h80000001\r
4555     Case "HKEY_LOCAL_MACHINE" : root_key = &h80000002\r
4556     Case "HKEY_USERS"         : root_key = &h80000003\r
4557     Case "HKEY_PERFORMANCE_DATA":root_key= &h80000004\r
4558     Case "HKEY_CURRENT_CONFIG": root_key = &h80000005\r
4559     Case "HKEY_DYN_DATA"      : root_key = &h80000006\r
4560     Case Else : Err.Raise  &h80070002\r
4561   End Select\r
4562 \r
4563   Path = Mid( Path, i + 1 )\r
4564 \r
4565   If IsEmpty( g_reg ) Then _\r
4566     Set g_reg = GetObject("winmgmts:{impersonationLevel=impersonate}!root/default:StdRegProv")\r
4567   g_reg.EnumValues  root_key, Path, names, types\r
4568 \r
4569   ReDim  out_Values( UBound( names ) )\r
4570   For i=0 To UBound( names )\r
4571 \r
4572     Set  out_Values(i) = new RegValueName : ErrCheck\r
4573 \r
4574     out_Values(i).Name = names(i)\r
4575 \r
4576     Select Case  types(i)\r
4577       Case 1 : out_Values(i).Type_ = "REG_SZ"\r
4578       Case 2 : out_Values(i).Type_ = "REG_EXPAND_SZ"\r
4579       Case 3 : out_Values(i).Type_ = "REG_BINARY"\r
4580       Case 4 : out_Values(i).Type_ = "REG_DWORD"\r
4581       Case 7 : out_Values(i).Type_ = "REG_MULTI_SZ"\r
4582     End Select\r
4583   Next\r
4584 End Sub\r
4585 \r
4586  \r
4587 '********************************************************************************\r
4588 '  <<< [RegExists] >>> \r
4589 '********************************************************************************\r
4590 Function  RegExists( Path )\r
4591   Dim en,ed\r
4592   Const  E_PathNotFound = &h80070002\r
4593 \r
4594   On Error Resume Next\r
4595     g_sh.RegRead  Path\r
4596   en = Err.Number : ed = Err.Description : On Error GoTo 0\r
4597   If en = E_PathNotFound Then  RegExists = False : Exit Function\r
4598   If en <> 0 Then  Err.Raise en,,ed\r
4599   RegExists = True\r
4600 End Function\r
4601 \r
4602  \r
4603 '*-------------------------------------------------------------------------*\r
4604 '* ### <<<< Error, Err2 >>>> \r
4605 '*-------------------------------------------------------------------------*\r
4606 \r
4607 \r
4608  \r
4609 '********************************************************************************\r
4610 '  <<< [Finish] >>> \r
4611 '********************************************************************************\r
4612 Sub  Finish\r
4613   WScript.Quit 9\r
4614 End Sub\r
4615 \r
4616 \r
4617  \r
4618 '********************************************************************************\r
4619 '  <<< [Error] >>> \r
4620 '********************************************************************************\r
4621 Sub  Error\r
4622   Err.Raise  1,,""\r
4623 End Sub\r
4624 \r
4625 \r
4626  \r
4627 '********************************************************************************\r
4628 '  <<< [Err2] >>> \r
4629 '********************************************************************************\r
4630 Class Err2\r
4631 \r
4632   Public  Number       ' Err.Number\r
4633   Public  num          ' Err.Number\r
4634   Public  Description  ' Err.Description (Error Message)\r
4635   Public  desc         ' Err.Description (Error Message)\r
4636   Public  Source       ' Err.Source\r
4637   Public  ErrID        ' count of (num <> 0) in each first Copy after Clear\r
4638   Public  RaiseID      ' count of (num <> 0) in Copy\r
4639   Public  BreakErrID   ' as integer\r
4640   Public  BreakRaiseID ' as integer\r
4641 \r
4642   Private Sub Class_Initialize\r
4643     num = 0 : Description = "" : ErrID = 0 : RaiseID = 0\r
4644   End Sub\r
4645 \r
4646   Public Sub OnSuccessFinish\r
4647     If Err.Number = 0 and Me.num <> 0 Then\r
4648       echo "<ERROR msg='Script finished before Err2.Clear or Raise the error'"+vbCRLF+_\r
4649            "jp='\83G\83\89\81[\82ª Err2.Clear \82Ü\82½\82Í Raise \82³\82ê\82È\82¢\82Å\8fI\97¹\82µ\82Ü\82µ\82½'"+vbCRLF+_\r
4650            "err_symbol='E_NotClear' />"\r
4651 \r
4652       Dim  b_dbg : b_dbg = not IsDefined( "Setting_getCanExceptionDebugger" )\r
4653       If not b_dbg Then  b_dbg = Setting_getCanExceptionDebugger()\r
4654 \r
4655       If Me.ErrID >= 2 or b_dbg Then\r
4656         echo  "Run debugger with writing following code in main function." + vbCRLF + _\r
4657               "g_Err2.BreakErrID = " & Me.ErrID & " [or] " & Me.ErrID & ".5"\r
4658       End If\r
4659       On Error Resume Next\r
4660       Err.Raise  Me.num, Me.Source, Me.desc\r
4661     End If\r
4662   End Sub\r
4663 \r
4664   Public Sub OnErrorFinish\r
4665     If Me.num <> 0 Then\r
4666       echo  "Run debugger with writing following code in main function." + vbCRLF + _\r
4667             "g_Err2.BreakErrID = " & Me.ErrID & " [or] " & Me.ErrID & ".5"\r
4668     End If\r
4669   End Sub\r
4670 \r
4671   Public Sub Copy( err )\r
4672     Me.Number = err.Number\r
4673     Me.num = err.Number\r
4674     Me.Description = err.Description\r
4675     Me.desc = err.Description\r
4676     Me.Source = err.Source\r
4677     If Me.num <> 0 Then Me.RaiseID = Me.RaiseID + 1 : If Me.RaiseID = 1 Then Me.ErrID = Me.ErrID + 1\r
4678   End Sub\r
4679 \r
4680   Public Function Value\r
4681     Value = GetErrStr( num, Description )\r
4682   End Function\r
4683 \r
4684   Public Sub OverRaise( e_num, e_desc )\r
4685     num = e_num\r
4686     Description = e_desc\r
4687     Raise\r
4688   End Sub\r
4689 \r
4690   Public Sub Raise\r
4691     If num = 0 Then\r
4692       Err.Raise 1  '// Look at caller function using watch window of debugger.\r
4693     Else\r
4694       Err.Raise num, Source, Description  '// Re-raise previous Error again.\r
4695        '// Write  g_Err2.BreakErrID = (ErrID) or (ErrID)+0.5 at the first of main function.\r
4696        '// [sample]  g_Err2.BreakErrID = 1\r
4697     End If\r
4698   End Sub\r
4699 \r
4700   Public Sub Clear\r
4701     num = 0 : Description = "" : RaiseID = 0\r
4702   End Sub\r
4703 End Class\r
4704 \r
4705 \r
4706  \r
4707 '********************************************************************************\r
4708 '  <<< [Raise] >>> \r
4709 '********************************************************************************\r
4710 Sub  Raise( ErrNum, Description )\r
4711   g_Err2.num = ErrNum\r
4712   g_Err2.Source = "ERROR"\r
4713   g_Err2.Description = Description\r
4714   g_Err2.RaiseID = g_Err2.RaiseID + 1 : If g_Err2.RaiseID = 1 Then g_Err2.ErrID = g_Err2.ErrID + 1\r
4715   If g_debug Then\r
4716     echo  "Run debugger with writing following code in main function."\r
4717     echo  "g_Err2.BreakErrID = " & g_Err2.ErrID & " [or] " & g_Err2.ErrID & ".5"\r
4718   End If\r
4719   Err.raise  g_Err2.num, g_Err2.Source, g_Err2.Description\r
4720 End Sub\r
4721 \r
4722 \r
4723  \r
4724 '********************************************************************************\r
4725 '  <<< [SetErrBreak] >>> \r
4726 '********************************************************************************\r
4727 Sub  SetErrBreak( ErrID, RaiseID )\r
4728   g_Err2.BreakErrID = ErrID\r
4729   g_Err2.BreakRaiseID = RaiseID\r
4730 End Sub\r
4731 \r
4732 \r
4733  \r
4734 '********************************************************************************\r
4735 '  <<< [NestPos] >>> \r
4736 '********************************************************************************\r
4737 Class NestPos\r
4738   Public  m_HereArr()\r
4739 \r
4740   Private Sub Class_Initialize ' \83R\83\93\83X\83g\83\89\83N\83^\r
4741     Redim  m_HereArr(0)\r
4742     m_HereArr(0) = 0\r
4743   End Sub\r
4744 \r
4745   Public Function  GetPos( arr )\r
4746     Dim  u, i\r
4747     u = UBound( m_HereArr )\r
4748 \r
4749     Redim Preserve  arr(u-1)\r
4750 \r
4751     For i=0 To u-1\r
4752       arr(i) = m_HereArr(i)\r
4753     Next\r
4754   End Function\r
4755 \r
4756   Public Sub  OnBlockStart\r
4757     Dim  u\r
4758     u = UBound( m_HereArr )\r
4759     m_HereArr(u) = m_HereArr(u) + 1\r
4760     Redim Preserve  m_HereArr(u+1)\r
4761     m_HereArr(u+1) = 0\r
4762   End Sub\r
4763 \r
4764   Public Sub  OnBlockEnd\r
4765     Redim Preserve  m_HereArr( UBound( m_HereArr ) - 1 )\r
4766   End Sub\r
4767 End Class\r
4768 \r
4769 \r
4770  \r
4771 '********************************************************************************\r
4772 '  <<< [NotCallFinish] >>> \r
4773 '********************************************************************************\r
4774 Sub  NotCallFinish()\r
4775   echo  "[ERROR] not call Finish"\r
4776   Stop\r
4777   If g_b_cscript_exe Then pause\r
4778   WScript.Quit 1\r
4779 End Sub\r
4780 \r
4781 \r
4782  \r
4783 '********************************************************************************\r
4784 '  <<< [ErrorCheckInTerminate] >>> \r
4785 '********************************************************************************\r
4786 Sub  ErrorCheckInTerminate()\r
4787   If Err.Number <> 0 Then\r
4788     echo  GetErrStr( Err.Number, Err.Description + " in Class_Terminate" )\r
4789     Stop\r
4790     If g_b_cscript_exe Then pause\r
4791   End If\r
4792 End Sub\r
4793 \r
4794 \r
4795  \r
4796 '********************************************************************************\r
4797 '  <<< [TryStart] >>> \r
4798 '********************************************************************************\r
4799 Function TryStart( e )\r
4800   Set e = g_Err2\r
4801   If IsEmpty( e.BreakErrID ) Then\r
4802     TryStart = True\r
4803   Else\r
4804     If e.ErrID = e.BreakErrID - 1 Then\r
4805       TryStart = False\r
4806     Else\r
4807       TryStart = True\r
4808     End If\r
4809   End If\r
4810 End Function\r
4811 \r
4812 \r
4813  \r
4814 '********************************************************************************\r
4815 '  <<< [Trying] >>> \r
4816 '********************************************************************************\r
4817 Function Trying\r
4818   Trying = (Err.Number=0)\r
4819   If not Trying Then  If g_Err2.ErrID = g_Err2.BreakErrID - 1.5 Then  g_Err2.BreakErrID = Empty :_\r
4820     Stop  '// Look at caller function by call stack window\r
4821 End Function\r
4822 \r
4823 \r
4824  \r
4825 '********************************************************************************\r
4826 '  <<< [TryEnd] >>> \r
4827 '********************************************************************************\r
4828 Function TryEnd\r
4829 ' Do not have parameters.\r
4830 ' Because "If TryEnd(e) Then On Error Goto 0" cannot get error, if e is not Dim.\r
4831 \r
4832   If Err.Number <> 0 Then\r
4833     g_Err2.Copy Err\r
4834 \r
4835     If g_Err2.ErrID = g_Err2.BreakErrID Then\r
4836       TryEnd = False\r
4837     Else\r
4838       TryEnd = True\r
4839     End If\r
4840 \r
4841     If g_Err2.ErrID = g_Err2.BreakErrID - 0.5 Then  g_Err2.BreakErrID = Empty :_\r
4842       Stop  '// Look at caller function by call stack window\r
4843   Else\r
4844     TryEnd = True\r
4845   End If\r
4846 End Function\r
4847 \r
4848 \r
4849  \r
4850 '********************************************************************************\r
4851 '  <<< [ErrCheck] >>> \r
4852 '********************************************************************************\r
4853 Sub  ErrCheck()\r
4854   If Err.Number <> 0 Then  g_Err2.Copy Err : g_Err2.Raise\r
4855 End Sub\r
4856 \r
4857  \r
4858 '********************************************************************************\r
4859 '  <<< [chk_exist_in_lib] >>> \r
4860 ' comment\r
4861 '  - If there is not path in vbslib folder, raise error of E_FileNotExist.\r
4862 '********************************************************************************\r
4863 Sub  chk_exist_in_lib( ByVal path )\r
4864   If not exist( g_vbslib_ver_folder + path ) Then  Err.Raise  E_FileNotExist,, _\r
4865     "Not found """ + g_vbslib_ver_folder + path + """"\r
4866 End  Sub\r
4867 \r
4868 \r
4869  \r
4870 '-------------------------------------------------------------------------\r
4871 ' ### <<<< [SkipSection] Class >>>> \r
4872 '-------------------------------------------------------------------------\r
4873 Class  SkipSection\r
4874   Public  m_CurrentSecNum\r
4875   Public  m_SkipToSecNum\r
4876 End Class\r
4877 \r
4878 Dim  g_SkipSection\r
4879 Dim  g_bSkipSectionSupport\r
4880 \r
4881 Sub  SkipToSection( Num )\r
4882   If IsEmpty( Num ) Then\r
4883     g_SkipSection = Empty\r
4884   Else\r
4885     Set g_SkipSection = new SkipSection\r
4886     g_SkipSection.m_SkipToSecNum = Num\r
4887   End If\r
4888 End Sub\r
4889 \r
4890 Function  NotSkipSection()\r
4891   g_bSkipSectionSupport = True\r
4892   If IsEmpty( g_SkipSection ) Then  NotSkipSection = True : Exit Function\r
4893   Dim  m : Set m = g_SkipSection\r
4894   m.m_CurrentSecNum = m.m_CurrentSecNum + 1\r
4895   If m.m_CurrentSecNum < m.m_SkipToSecNum Then  NotSkipSection = False : Exit Function\r
4896   echo  "<Section num='" & m.m_CurrentSecNum & "'/>"\r
4897   NotSkipSection = True\r
4898 End Function\r
4899 \r
4900 \r
4901  \r
4902 '-------------------------------------------------------------------------\r
4903 ' ### <<<< [FinObj] Class >>>> \r
4904 '-------------------------------------------------------------------------\r
4905 Class  FinObj\r
4906   Public  m_Vars  ' as Dictionay\r
4907   Public  m_FinallyFunc\r
4908 \r
4909   Private Sub Class_Initialize\r
4910     Set m_Vars = CreateObject("Scripting.Dictionary")\r
4911   End Sub\r
4912 \r
4913   Public Sub  SetFunc( FuncName )\r
4914     Set m_FinallyFunc = GetRef( FuncName )\r
4915   End Sub\r
4916 \r
4917   Public Sub  SetVar( Name, Var )\r
4918     If IsObject( Var ) Then  Set m_Vars.Item( Name ) = Var _\r
4919     Else                         m_Vars.Item( Name ) = Var\r
4920   End Sub\r
4921 \r
4922   Private Sub Class_Terminate()\r
4923     If not IsEmpty( m_FinallyFunc ) Then\r
4924       Dim  en, ed : en = Err.Number : ed = Err.Description\r
4925       m_FinallyFunc  m_Vars\r
4926       Err.Raise  en,,ed\r
4927     End If\r
4928   End Sub\r
4929 End Class\r
4930  \r