_src/TestByFCBatAuto/TestPrompt/vbslib/vbslib300/vbslib.vbs

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