1Attribute VB_Name = "Analyse" 2'************************************************************************* 3' 4' Licensed to the Apache Software Foundation (ASF) under one 5' or more contributor license agreements. See the NOTICE file 6' distributed with this work for additional information 7' regarding copyright ownership. The ASF licenses this file 8' to you under the Apache License, Version 2.0 (the 9' "License"); you may not use this file except in compliance 10' with the License. You may obtain a copy of the License at 11' 12' http://www.apache.org/licenses/LICENSE-2.0 13' 14' Unless required by applicable law or agreed to in writing, 15' software distributed under the License is distributed on an 16' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 17' KIND, either express or implied. See the License for the 18' specific language governing permissions and limitations 19' under the License. 20' 21'************************************************************************* 22Option Explicit 23 24Private Const C_STAT_NOT_STARTED As Integer = 1 25Private Const C_STAT_RETRY As Integer = 2 26Private Const C_STAT_ERROR As Integer = 3 27Private Const C_STAT_DONE As Integer = 4 28Private Const C_STAT_ABORTED As Integer = 5 29 30Private Const C_MAX_RETRIES As Integer = 5 31Private Const C_ABORT_TIMEOUT As Integer = 30 32 33Private Const MAX_WAIT_TIME As Long = 600 34 35Private Const C_STAT_FINISHED As String = "finished" 36Private Const C_STAT_ANALYSED As String = "analysed=" 37Private Const C_STAT_ANALYSING As String = "analysing=" 38Private Const CSINGLE_FILE As String = "singlefile" 39Private Const CFILE_LIST As String = "filelist" 40Private Const CSTAT_FILE As String = "statfilename" 41Private Const CLAST_CHECKPOINT As String = "LastCheckpoint" 42Private Const CNEXT_FILE As String = "NextFile" 43Private Const C_ABORT_ANALYSIS As String = "AbortAnalysis" 44 45Private Const CAPPNAME_WORD As String = "word" 46Private Const CAPPNAME_EXCEL As String = "excel" 47Private Const CAPPNAME_POWERPOINT As String = "powerpoint" 48Private Const C_EXENAME_WORD As String = "winword.exe" 49Private Const C_EXENAME_EXCEL As String = "excel.exe" 50Private Const C_EXENAME_POWERPOINT As String = "powerpnt.exe" 51 52Const CNEW_RESULTS_FILE = "newresultsfile" 53Const C_LAUNCH_DRIVER = ".\resources\LaunchDrivers.exe" 54 55'from http://support.microsoft.com/kb/q129796 56 57Private Type STARTUPINFO 58 cb As Long 59 lpReserved As String 60 lpDesktop As String 61 lpTitle As String 62 dwX As Long 63 dwY As Long 64 dwXSize As Long 65 dwYSize As Long 66 dwXCountChars As Long 67 dwYCountChars As Long 68 dwFillAttribute As Long 69 dwFlags As Long 70 wShowWindow As Integer 71 cbReserved2 As Integer 72 lpReserved2 As Long 73 hStdInput As Long 74 hStdOutput As Long 75 hStdError As Long 76End Type 77 78Private Type PROCESS_INFORMATION 79 hProcess As Long 80 hThread As Long 81 dwProcessID As Long 82 dwThreadID As Long 83End Type 84 85Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _ 86 hHandle As Long, ByVal dwMilliseconds As Long) As Long 87 88Private Declare Function CreateProcessA Lib "kernel32" (ByVal _ 89 lpApplicationName As String, ByVal lpCommandLine As String, ByVal _ 90 lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _ 91 ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _ 92 ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _ 93 lpStartupInfo As STARTUPINFO, lpProcessInformation As _ 94 PROCESS_INFORMATION) As Long 95 96Private Declare Function CloseHandle Lib "kernel32" _ 97 (ByVal hObject As Long) As Long 98 99Private Declare Function GetExitCodeProcess Lib "kernel32" _ 100 (ByVal hProcess As Long, lpExitCode As Long) As Long 101 102Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, _ 103 ByVal uExitCode As Long) As Long 104 105Private Const NORMAL_PRIORITY_CLASS = &H20& 106Private Const WAIT_TIMEOUT As Long = &H102 107Private Const ABORTED As Long = -2 108 109' from http://vbnet.mvps.org/index.html?code/system/toolhelpprocesses.htm 110Public Const TH32CS_SNAPPROCESS As Long = 2& 111Public Const MAX_PATH As Long = 260 112 113Public Type PROCESSENTRY32 114 dwSize As Long 115 cntUsage As Long 116 th32ProcessID As Long 117 th32DefaultHeapID As Long 118 th32ModuleID As Long 119 cntThreads As Long 120 th32ParentProcessID As Long 121 pcPriClassBase As Long 122 dwFlags As Long 123 szExeFile As String * MAX_PATH 124End Type 125 126Public Declare Function CreateToolhelp32Snapshot Lib "kernel32" _ 127 (ByVal lFlags As Long, ByVal lProcessID As Long) As Long 128 129Public Declare Function ProcessFirst Lib "kernel32" _ 130 Alias "Process32First" _ 131 (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long 132 133Public Declare Function ProcessNext Lib "kernel32" _ 134 Alias "Process32Next" _ 135 (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long 136 137 138Public Function IsOfficeAppRunning(curApplication As String) As Boolean 139'DV: we need some error handling here 140 Dim hSnapShot As Long 141 Dim uProcess As PROCESSENTRY32 142 Dim success As Long 143 Dim bRet As Boolean 144 Dim bAppFound As Boolean 145 Dim exeName As String 146 Dim curExeName As String 147 148 bRet = True 149 On Error GoTo FinalExit 150 151 curExeName = LCase$(curApplication) 152 153 If (curExeName = CAPPNAME_WORD) Then 154 exeName = C_EXENAME_WORD 155 ElseIf (curExeName = CAPPNAME_EXCEL) Then 156 exeName = C_EXENAME_EXCEL 157 ElseIf (curExeName = CAPPNAME_POWERPOINT) Then 158 exeName = C_EXENAME_POWERPOINT 159 Else 160 GoTo FinalExit 161 End If 162 163 hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&) 164 165 If hSnapShot = -1 Then GoTo FinalExit 166 167 uProcess.dwSize = Len(uProcess) 168 success = ProcessFirst(hSnapShot, uProcess) 169 bAppFound = False 170 171 While ((success = 1) And Not bAppFound) 172 Dim i As Long 173 i = InStr(1, uProcess.szExeFile, Chr(0)) 174 curExeName = LCase$(Left$(uProcess.szExeFile, i - 1)) 175 If (curExeName = exeName) Then 176 bAppFound = True 177 Else 178 success = ProcessNext(hSnapShot, uProcess) 179 End If 180 Wend 181 bRet = bAppFound 182 183 Call CloseHandle(hSnapShot) 184 185FinalExit: 186 IsOfficeAppRunning = bRet 187 188End Function 189 190Private Sub CalculateProgress(statusFileName As String, fso As FileSystemObject, _ 191 lastIndex As Long, docOffset As Long, _ 192 myDocList As Collection) 193 194 On Error GoTo FinalExit 195 196 Dim curFile As String 197 Dim fileCont As TextStream 198 Dim myFile As file 199 200 If (fso.FileExists(statusFileName)) Then 201 Dim statLine As String 202 203 Set fileCont = fso.OpenTextFile(statusFileName, ForReading, False, TristateTrue) 204 statLine = fileCont.ReadLine 205 206 If (Left(statLine, Len(C_STAT_ANALYSED)) = C_STAT_ANALYSED) Then 207 curFile = Mid(statLine, Len(C_STAT_ANALYSED) + 1) 208 ElseIf (Left(statLine, Len(C_STAT_ANALYSING)) = C_STAT_ANALYSING) Then 209 curFile = Mid(statLine, Len(C_STAT_ANALYSING) + 1) 210 End If 211 End If 212 213 ' when we don't have a file, we will show the name of the last used file in 214 ' the progress window 215 If (curFile = "") Then curFile = myDocList.item(lastIndex) 216 217 If (GetDocumentIndex(curFile, myDocList, lastIndex)) Then 218 Set myFile = fso.GetFile(curFile) 219 Call ShowProgress.SP_UpdateProgress(myFile.Name, myFile.ParentFolder.path, lastIndex + docOffset) 220 End If 221 222FinalExit: 223 If Not (fileCont Is Nothing) Then fileCont.Close 224 Set fileCont = Nothing 225 Set myFile = Nothing 226 227End Sub 228 229Function CheckAliveStatus(statFileName As String, _ 230 curApplication As String, _ 231 lastDate As Date, _ 232 fso As FileSystemObject) As Boolean 233 234 Dim isAlive As Boolean 235 Dim currDate As Date 236 Dim statFile As file 237 Dim testing As Long 238 239 isAlive = False 240 241 If Not fso.FileExists(statFileName) Then 242 currDate = Now() 243 If (val(DateDiff("s", lastDate, currDate)) > MAX_WAIT_TIME) Then 244 isAlive = False 245 Else 246 isAlive = True 247 End If 248 Else 249 Set statFile = fso.GetFile(statFileName) 250 currDate = statFile.DateLastModified 251 If (currDate > lastDate) Then 252 lastDate = currDate 253 isAlive = True 254 Else 255 currDate = Now() 256 If (lastDate >= currDate) Then ' There might be some inaccuracies in file and system dates 257 isAlive = True 258 ElseIf (val(DateDiff("s", lastDate, currDate)) > MAX_WAIT_TIME) Then 259 isAlive = False 260 Else 261 isAlive = IsOfficeAppRunning(curApplication) 262 End If 263 End If 264 End If 265 266 CheckAliveStatus = isAlive 267End Function 268 269Sub TerminateOfficeApps(fso As FileSystemObject, aParameter As String) 270 271 Dim msoKillFileName As String 272 273 msoKillFileName = fso.GetAbsolutePathName(".\resources\msokill.exe") 274 If fso.FileExists(msoKillFileName) Then 275 Shell msoKillFileName & aParameter 276 Else 277 End If 278End Sub 279 280Public Function launchDriver(statFileName As String, cmdLine As String, _ 281 curApplication As String, fso As FileSystemObject, _ 282 myDocList As Collection, myOffset As Long, _ 283 myIniFilePath As String) As Long 284 285 Dim proc As PROCESS_INFORMATION 286 Dim start As STARTUPINFO 287 Dim ret As Long 288 Dim currDate As Date 289 Dim lastIndex As Long 290 291 currDate = Now() 292 lastIndex = 1 293 294 ' Initialize the STARTUPINFO structure: 295 start.cb = Len(start) 296 297 ' Start the shelled application: 298 ret = CreateProcessA(vbNullString, cmdLine$, 0&, 0&, 1&, _ 299 NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc) 300 301 ' Wait for the shelled application to finish: 302 Do 303 ret = WaitForSingleObject(proc.hProcess, 100) 304 If ret <> WAIT_TIMEOUT Then 305 Exit Do 306 End If 307 If Not CheckAliveStatus(statFileName, curApplication, currDate, fso) Then 308 ' Try to close open office dialogs and then wait a little bit 309 TerminateOfficeApps fso, " --close" 310 ret = WaitForSingleObject(proc.hProcess, 1000) 311 312 ' next try to kill all office programs and then wait a little bit 313 TerminateOfficeApps fso, " --kill" 314 ret = WaitForSingleObject(proc.hProcess, 1000) 315 316 ret = TerminateProcess(proc.hProcess, "0") 317 ret = WAIT_TIMEOUT 318 Exit Do 319 End If 320 If (ShowProgress.g_SP_Abort) Then 321 WriteToLog C_ABORT_ANALYSIS, True, myIniFilePath 322 Call HandleAbort(proc.hProcess, curApplication) 323 ret = ABORTED 324 Exit Do 325 End If 326 Call CalculateProgress(statFileName, fso, lastIndex, myOffset, myDocList) 327 DoEvents 'allow other processes 328 Loop While True 329 330 If (ret <> WAIT_TIMEOUT) And (ret <> ABORTED) Then 331 Call GetExitCodeProcess(proc.hProcess, ret&) 332 End If 333 Call CloseHandle(proc.hThread) 334 Call CloseHandle(proc.hProcess) 335 launchDriver = ret 336End Function 337 338Function CheckAnalyseStatus(statusFileName As String, _ 339 lastFile As String, _ 340 fso As FileSystemObject) As Integer 341 342 Dim currStatus As Integer 343 Dim fileCont As TextStream 344 345 If Not fso.FileExists(statusFileName) Then 346 currStatus = C_STAT_NOT_STARTED 347 Else 348 Dim statText As String 349 Set fileCont = fso.OpenTextFile(statusFileName, ForReading, False, TristateTrue) 350 statText = fileCont.ReadLine 351 If (statText = C_STAT_FINISHED) Then 352 currStatus = C_STAT_DONE 353 ElseIf (Left(statText, Len(C_STAT_ANALYSED)) = C_STAT_ANALYSED) Then 354 currStatus = C_STAT_RETRY 355 lastFile = Mid(statText, Len(C_STAT_ANALYSED) + 1) 356 ElseIf (Left(statText, Len(C_STAT_ANALYSING)) = C_STAT_ANALYSING) Then 357 currStatus = C_STAT_RETRY 358 lastFile = Mid(statText, Len(C_STAT_ANALYSING) + 1) 359 Else 360 currStatus = C_STAT_ERROR 361 End If 362 fileCont.Close 363 End If 364 365 CheckAnalyseStatus = currStatus 366End Function 367 368Function WriteDocsToAnalyze(myDocList As Collection, myApp As String, _ 369 fso As FileSystemObject) As String 370 On Error GoTo HandleErrors 371 Dim currentFunctionName As String 372 currentFunctionName = "WriteDocsToAnalyze" 373 374 Dim TempPath As String 375 Dim fileName As String 376 Dim fileContent As TextStream 377 378 fileName = "" 379 TempPath = fso.GetSpecialFolder(TemporaryFolder).path 380 381 If (TempPath = "") Then 382 TempPath = "." 383 End If 384 385 Dim vFileName As Variant 386 Dim Index As Long 387 Dim limit As Long 388 389 limit = myDocList.count 390 If (limit > 0) Then 391 fileName = fso.GetAbsolutePathName(TempPath & "\FileList" & myApp & ".txt") 392 Set fileContent = fso.OpenTextFile(fileName, ForWriting, True, TristateTrue) 393 394 For Index = 1 To limit 395 vFileName = myDocList(Index) 396 fileContent.WriteLine (vFileName) 397 Next 398 399 fileContent.Close 400 End If 401 402FinalExit: 403 Set fileContent = Nothing 404 WriteDocsToAnalyze = fileName 405 Exit Function 406 407HandleErrors: 408 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 409 Resume FinalExit 410End Function 411 412' This function looks for the given document name in the document collection 413' and returns TRUE and the position of the document in that collection if found, 414' FALSE otherwise 415Function GetDocumentIndex(myDocument As String, _ 416 myDocList As Collection, _ 417 lastIndex As Long) As Boolean 418 419 Dim currentFunctionName As String 420 currentFunctionName = "GetDocumentIndex" 421 422 On Error GoTo HandleErrors 423 424 Dim lastEntry As Long 425 Dim curIndex As Long 426 Dim curEntry As String 427 Dim entryFound As Boolean 428 429 entryFound = False 430 lastEntry = myDocList.count 431 curIndex = lastIndex 432 433 ' We start the search at the position of the last found 434 ' document 435 While Not entryFound And curIndex <= lastEntry 436 curEntry = myDocList.item(curIndex) 437 If (curEntry = myDocument) Then 438 lastIndex = curIndex 439 entryFound = True 440 Else 441 curIndex = curIndex + 1 442 End If 443 Wend 444 445 ' When we could not find the document, we start the search 446 ' from the beginning of the list 447 If Not entryFound Then 448 curIndex = 1 449 While Not entryFound And curIndex <= lastIndex 450 curEntry = myDocList.item(curIndex) 451 If (curEntry = myDocument) Then 452 lastIndex = curIndex 453 entryFound = True 454 Else 455 curIndex = curIndex + 1 456 End If 457 Wend 458 End If 459 460FinalExit: 461 GetDocumentIndex = entryFound 462 Exit Function 463HandleErrors: 464 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 465 Resume FinalExit 466End Function 467 468Function AnalyseList(myDocList As Collection, _ 469 myApp As String, _ 470 myIniFilePath As String, _ 471 myOffset As Long, _ 472 analysisAborted As Boolean) As Boolean 473 474 On Error GoTo HandleErrors 475 Dim currentFunctionName As String 476 currentFunctionName = "AnalyseList" 477 478 Dim cmdLine As String 479 Dim filelist As String 480 Dim statFileName As String 481 Dim finished As Boolean 482 Dim analyseStatus As Integer 483 Dim nRetries As Integer 484 Dim lastFile As String 485 Dim lastHandledFile As String 486 Dim launchStatus As Long 487 Dim fso As New FileSystemObject 488 Dim progressTitle As String 489 490 filelist = WriteDocsToAnalyze(myDocList, myApp, fso) 491 cmdLine = fso.GetAbsolutePathName(C_LAUNCH_DRIVER) & " " & myApp 492 finished = False 493 494 Dim TempPath As String 495 TempPath = fso.GetSpecialFolder(TemporaryFolder).path 496 If (TempPath = "") Then TempPath = "." 497 statFileName = fso.GetAbsolutePathName(TempPath & "\StatFile" & myApp & ".txt") 498 If (fso.FileExists(statFileName)) Then fso.DeleteFile (statFileName) 499 500 WriteToLog CFILE_LIST, filelist, myIniFilePath 501 WriteToLog CSTAT_FILE, statFileName, myIniFilePath 502 WriteToLog CLAST_CHECKPOINT, "", myIniFilePath 503 WriteToLog CNEXT_FILE, "", myIniFilePath 504 WriteToLog C_ABORT_ANALYSIS, "", myIniFilePath 505 506 ' In this loop we will restart the driver until we have finished the analysis 507 nRetries = 0 508 While Not finished And nRetries < C_MAX_RETRIES 509 launchStatus = launchDriver(statFileName, cmdLine, myApp, fso, _ 510 myDocList, myOffset, myIniFilePath) 511 If (launchStatus = ABORTED) Then 512 finished = True 513 analyseStatus = C_STAT_ABORTED 514 analysisAborted = True 515 Else 516 analyseStatus = CheckAnalyseStatus(statFileName, lastHandledFile, fso) 517 End If 518 If (analyseStatus = C_STAT_DONE) Then 519 finished = True 520 ElseIf (analyseStatus = C_STAT_RETRY) Then 521 If (lastHandledFile = lastFile) Then 522 nRetries = nRetries + 1 523 Else 524 lastFile = lastHandledFile 525 nRetries = 1 526 End If 527 Else 528 nRetries = nRetries + 1 529 End If 530 Wend 531 532 If (analyseStatus = C_STAT_DONE) Then 533 AnalyseList = True 534 Else 535 AnalyseList = False 536 End If 537 538 'The next driver should not overwrite this result file 539 WriteToLog CNEW_RESULTS_FILE, "False", myIniFilePath 540 541FinalExit: 542 Set fso = Nothing 543 Exit Function 544 545HandleErrors: 546 AnalyseList = False 547 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 548 Resume FinalExit 549End Function 550 551Sub HandleAbort(hProcess As Long, curApplication As String) 552 553 On Error Resume Next 554 555 Dim ret As Long 556 Dim curDate As Date 557 Dim stillWaiting As Boolean 558 Dim killApplication As Boolean 559 Dim waitTime As Long 560 561 curDate = Now() 562 stillWaiting = True 563 killApplication = False 564 565 While stillWaiting 566 stillWaiting = IsOfficeAppRunning(curApplication) 567 If (stillWaiting) Then 568 waitTime = val(DateDiff("s", curDate, Now())) 569 If (waitTime > C_ABORT_TIMEOUT) Then 570 stillWaiting = False 571 killApplication = True 572 End If 573 End If 574 Wend 575 576 If (killApplication) Then 577 ShowProgress.g_SP_AllowOtherDLG = True 578 TerminateMSO.Show vbModal, ShowProgress 579 End If 580 581 ret = TerminateProcess(hProcess, "0") 582End Sub 583