| Attribute VB_Name = "Analyse" |
| '************************************************************************* |
| ' |
| ' Licensed to the Apache Software Foundation (ASF) under one |
| ' or more contributor license agreements. See the NOTICE file |
| ' distributed with this work for additional information |
| ' regarding copyright ownership. The ASF licenses this file |
| ' to you under the Apache License, Version 2.0 (the |
| ' "License"); you may not use this file except in compliance |
| ' with the License. You may obtain a copy of the License at |
| ' |
| ' http://www.apache.org/licenses/LICENSE-2.0 |
| ' |
| ' Unless required by applicable law or agreed to in writing, |
| ' software distributed under the License is distributed on an |
| ' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY |
| ' KIND, either express or implied. See the License for the |
| ' specific language governing permissions and limitations |
| ' under the License. |
| ' |
| '************************************************************************* |
| Option Explicit |
| |
| Private Const C_STAT_NOT_STARTED As Integer = 1 |
| Private Const C_STAT_RETRY As Integer = 2 |
| Private Const C_STAT_ERROR As Integer = 3 |
| Private Const C_STAT_DONE As Integer = 4 |
| Private Const C_STAT_ABORTED As Integer = 5 |
| |
| Private Const C_MAX_RETRIES As Integer = 5 |
| Private Const C_ABORT_TIMEOUT As Integer = 30 |
| |
| Private Const MAX_WAIT_TIME As Long = 600 |
| |
| Private Const C_STAT_FINISHED As String = "finished" |
| Private Const C_STAT_ANALYSED As String = "analysed=" |
| Private Const C_STAT_ANALYSING As String = "analysing=" |
| Private Const CSINGLE_FILE As String = "singlefile" |
| Private Const CFILE_LIST As String = "filelist" |
| Private Const CSTAT_FILE As String = "statfilename" |
| Private Const CLAST_CHECKPOINT As String = "LastCheckpoint" |
| Private Const CNEXT_FILE As String = "NextFile" |
| Private Const C_ABORT_ANALYSIS As String = "AbortAnalysis" |
| |
| Private Const CAPPNAME_WORD As String = "word" |
| Private Const CAPPNAME_EXCEL As String = "excel" |
| Private Const CAPPNAME_POWERPOINT As String = "powerpoint" |
| Private Const C_EXENAME_WORD As String = "winword.exe" |
| Private Const C_EXENAME_EXCEL As String = "excel.exe" |
| Private Const C_EXENAME_POWERPOINT As String = "powerpnt.exe" |
| |
| Const CNEW_RESULTS_FILE = "newresultsfile" |
| Const C_LAUNCH_DRIVER = ".\resources\LaunchDrivers.exe" |
| |
| 'from http://support.microsoft.com/kb/q129796 |
| |
| Private Type STARTUPINFO |
| cb As Long |
| lpReserved As String |
| lpDesktop As String |
| lpTitle As String |
| dwX As Long |
| dwY As Long |
| dwXSize As Long |
| dwYSize As Long |
| dwXCountChars As Long |
| dwYCountChars As Long |
| dwFillAttribute As Long |
| dwFlags As Long |
| wShowWindow As Integer |
| cbReserved2 As Integer |
| lpReserved2 As Long |
| hStdInput As Long |
| hStdOutput As Long |
| hStdError As Long |
| End Type |
| |
| Private Type PROCESS_INFORMATION |
| hProcess As Long |
| hThread As Long |
| dwProcessID As Long |
| dwThreadID As Long |
| End Type |
| |
| Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _ |
| hHandle As Long, ByVal dwMilliseconds As Long) As Long |
| |
| Private Declare Function CreateProcessA Lib "kernel32" (ByVal _ |
| lpApplicationName As String, ByVal lpCommandLine As String, ByVal _ |
| lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _ |
| ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _ |
| ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _ |
| lpStartupInfo As STARTUPINFO, lpProcessInformation As _ |
| PROCESS_INFORMATION) As Long |
| |
| Private Declare Function CloseHandle Lib "kernel32" _ |
| (ByVal hObject As Long) As Long |
| |
| Private Declare Function GetExitCodeProcess Lib "kernel32" _ |
| (ByVal hProcess As Long, lpExitCode As Long) As Long |
| |
| Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, _ |
| ByVal uExitCode As Long) As Long |
| |
| Private Const NORMAL_PRIORITY_CLASS = &H20& |
| Private Const WAIT_TIMEOUT As Long = &H102 |
| Private Const ABORTED As Long = -2 |
| |
| ' from http://vbnet.mvps.org/index.html?code/system/toolhelpprocesses.htm |
| Public Const TH32CS_SNAPPROCESS As Long = 2& |
| Public Const MAX_PATH As Long = 260 |
| |
| Public Type PROCESSENTRY32 |
| dwSize As Long |
| cntUsage As Long |
| th32ProcessID As Long |
| th32DefaultHeapID As Long |
| th32ModuleID As Long |
| cntThreads As Long |
| th32ParentProcessID As Long |
| pcPriClassBase As Long |
| dwFlags As Long |
| szExeFile As String * MAX_PATH |
| End Type |
| |
| Public Declare Function CreateToolhelp32Snapshot Lib "kernel32" _ |
| (ByVal lFlags As Long, ByVal lProcessID As Long) As Long |
| |
| Public Declare Function ProcessFirst Lib "kernel32" _ |
| Alias "Process32First" _ |
| (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long |
| |
| Public Declare Function ProcessNext Lib "kernel32" _ |
| Alias "Process32Next" _ |
| (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long |
| |
| |
| Public Function IsOfficeAppRunning(curApplication As String) As Boolean |
| 'DV: we need some error handling here |
| Dim hSnapShot As Long |
| Dim uProcess As PROCESSENTRY32 |
| Dim success As Long |
| Dim bRet As Boolean |
| Dim bAppFound As Boolean |
| Dim exeName As String |
| Dim curExeName As String |
| |
| bRet = True |
| On Error GoTo FinalExit |
| |
| curExeName = LCase$(curApplication) |
| |
| If (curExeName = CAPPNAME_WORD) Then |
| exeName = C_EXENAME_WORD |
| ElseIf (curExeName = CAPPNAME_EXCEL) Then |
| exeName = C_EXENAME_EXCEL |
| ElseIf (curExeName = CAPPNAME_POWERPOINT) Then |
| exeName = C_EXENAME_POWERPOINT |
| Else |
| GoTo FinalExit |
| End If |
| |
| hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&) |
| |
| If hSnapShot = -1 Then GoTo FinalExit |
| |
| uProcess.dwSize = Len(uProcess) |
| success = ProcessFirst(hSnapShot, uProcess) |
| bAppFound = False |
| |
| While ((success = 1) And Not bAppFound) |
| Dim i As Long |
| i = InStr(1, uProcess.szExeFile, Chr(0)) |
| curExeName = LCase$(Left$(uProcess.szExeFile, i - 1)) |
| If (curExeName = exeName) Then |
| bAppFound = True |
| Else |
| success = ProcessNext(hSnapShot, uProcess) |
| End If |
| Wend |
| bRet = bAppFound |
| |
| Call CloseHandle(hSnapShot) |
| |
| FinalExit: |
| IsOfficeAppRunning = bRet |
| |
| End Function |
| |
| Private Sub CalculateProgress(statusFileName As String, fso As FileSystemObject, _ |
| lastIndex As Long, docOffset As Long, _ |
| myDocList As Collection) |
| |
| On Error GoTo FinalExit |
| |
| Dim curFile As String |
| Dim fileCont As TextStream |
| Dim myFile As file |
| |
| If (fso.FileExists(statusFileName)) Then |
| Dim statLine As String |
| |
| Set fileCont = fso.OpenTextFile(statusFileName, ForReading, False, TristateTrue) |
| statLine = fileCont.ReadLine |
| |
| If (Left(statLine, Len(C_STAT_ANALYSED)) = C_STAT_ANALYSED) Then |
| curFile = Mid(statLine, Len(C_STAT_ANALYSED) + 1) |
| ElseIf (Left(statLine, Len(C_STAT_ANALYSING)) = C_STAT_ANALYSING) Then |
| curFile = Mid(statLine, Len(C_STAT_ANALYSING) + 1) |
| End If |
| End If |
| |
| ' when we don't have a file, we will show the name of the last used file in |
| ' the progress window |
| If (curFile = "") Then curFile = myDocList.item(lastIndex) |
| |
| If (GetDocumentIndex(curFile, myDocList, lastIndex)) Then |
| Set myFile = fso.GetFile(curFile) |
| Call ShowProgress.SP_UpdateProgress(myFile.Name, myFile.ParentFolder.path, lastIndex + docOffset) |
| End If |
| |
| FinalExit: |
| If Not (fileCont Is Nothing) Then fileCont.Close |
| Set fileCont = Nothing |
| Set myFile = Nothing |
| |
| End Sub |
| |
| Function CheckAliveStatus(statFileName As String, _ |
| curApplication As String, _ |
| lastDate As Date, _ |
| fso As FileSystemObject) As Boolean |
| |
| Dim isAlive As Boolean |
| Dim currDate As Date |
| Dim statFile As file |
| Dim testing As Long |
| |
| isAlive = False |
| |
| If Not fso.FileExists(statFileName) Then |
| currDate = Now() |
| If (val(DateDiff("s", lastDate, currDate)) > MAX_WAIT_TIME) Then |
| isAlive = False |
| Else |
| isAlive = True |
| End If |
| Else |
| Set statFile = fso.GetFile(statFileName) |
| currDate = statFile.DateLastModified |
| If (currDate > lastDate) Then |
| lastDate = currDate |
| isAlive = True |
| Else |
| currDate = Now() |
| If (lastDate >= currDate) Then ' There might be some inaccuracies in file and system dates |
| isAlive = True |
| ElseIf (val(DateDiff("s", lastDate, currDate)) > MAX_WAIT_TIME) Then |
| isAlive = False |
| Else |
| isAlive = IsOfficeAppRunning(curApplication) |
| End If |
| End If |
| End If |
| |
| CheckAliveStatus = isAlive |
| End Function |
| |
| Sub TerminateOfficeApps(fso As FileSystemObject, aParameter As String) |
| |
| Dim msoKillFileName As String |
| |
| msoKillFileName = fso.GetAbsolutePathName(".\resources\msokill.exe") |
| If fso.FileExists(msoKillFileName) Then |
| Shell msoKillFileName & aParameter |
| Else |
| End If |
| End Sub |
| |
| Public Function launchDriver(statFileName As String, cmdLine As String, _ |
| curApplication As String, fso As FileSystemObject, _ |
| myDocList As Collection, myOffset As Long, _ |
| myIniFilePath As String) As Long |
| |
| Dim proc As PROCESS_INFORMATION |
| Dim start As STARTUPINFO |
| Dim ret As Long |
| Dim currDate As Date |
| Dim lastIndex As Long |
| |
| currDate = Now() |
| lastIndex = 1 |
| |
| ' Initialize the STARTUPINFO structure: |
| start.cb = Len(start) |
| |
| ' Start the shelled application: |
| ret = CreateProcessA(vbNullString, cmdLine$, 0&, 0&, 1&, _ |
| NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc) |
| |
| ' Wait for the shelled application to finish: |
| Do |
| ret = WaitForSingleObject(proc.hProcess, 100) |
| If ret <> WAIT_TIMEOUT Then |
| Exit Do |
| End If |
| If Not CheckAliveStatus(statFileName, curApplication, currDate, fso) Then |
| ' Try to close open office dialogs and then wait a little bit |
| TerminateOfficeApps fso, " --close" |
| ret = WaitForSingleObject(proc.hProcess, 1000) |
| |
| ' next try to kill all office programs and then wait a little bit |
| TerminateOfficeApps fso, " --kill" |
| ret = WaitForSingleObject(proc.hProcess, 1000) |
| |
| ret = TerminateProcess(proc.hProcess, "0") |
| ret = WAIT_TIMEOUT |
| Exit Do |
| End If |
| If (ShowProgress.g_SP_Abort) Then |
| WriteToLog C_ABORT_ANALYSIS, True, myIniFilePath |
| Call HandleAbort(proc.hProcess, curApplication) |
| ret = ABORTED |
| Exit Do |
| End If |
| Call CalculateProgress(statFileName, fso, lastIndex, myOffset, myDocList) |
| DoEvents 'allow other processes |
| Loop While True |
| |
| If (ret <> WAIT_TIMEOUT) And (ret <> ABORTED) Then |
| Call GetExitCodeProcess(proc.hProcess, ret&) |
| End If |
| Call CloseHandle(proc.hThread) |
| Call CloseHandle(proc.hProcess) |
| launchDriver = ret |
| End Function |
| |
| Function CheckAnalyseStatus(statusFileName As String, _ |
| lastFile As String, _ |
| fso As FileSystemObject) As Integer |
| |
| Dim currStatus As Integer |
| Dim fileCont As TextStream |
| |
| If Not fso.FileExists(statusFileName) Then |
| currStatus = C_STAT_NOT_STARTED |
| Else |
| Dim statText As String |
| Set fileCont = fso.OpenTextFile(statusFileName, ForReading, False, TristateTrue) |
| statText = fileCont.ReadLine |
| If (statText = C_STAT_FINISHED) Then |
| currStatus = C_STAT_DONE |
| ElseIf (Left(statText, Len(C_STAT_ANALYSED)) = C_STAT_ANALYSED) Then |
| currStatus = C_STAT_RETRY |
| lastFile = Mid(statText, Len(C_STAT_ANALYSED) + 1) |
| ElseIf (Left(statText, Len(C_STAT_ANALYSING)) = C_STAT_ANALYSING) Then |
| currStatus = C_STAT_RETRY |
| lastFile = Mid(statText, Len(C_STAT_ANALYSING) + 1) |
| Else |
| currStatus = C_STAT_ERROR |
| End If |
| fileCont.Close |
| End If |
| |
| CheckAnalyseStatus = currStatus |
| End Function |
| |
| Function WriteDocsToAnalyze(myDocList As Collection, myApp As String, _ |
| fso As FileSystemObject) As String |
| On Error GoTo HandleErrors |
| Dim currentFunctionName As String |
| currentFunctionName = "WriteDocsToAnalyze" |
| |
| Dim TempPath As String |
| Dim fileName As String |
| Dim fileContent As TextStream |
| |
| fileName = "" |
| TempPath = fso.GetSpecialFolder(TemporaryFolder).path |
| |
| If (TempPath = "") Then |
| TempPath = "." |
| End If |
| |
| Dim vFileName As Variant |
| Dim Index As Long |
| Dim limit As Long |
| |
| limit = myDocList.count |
| If (limit > 0) Then |
| fileName = fso.GetAbsolutePathName(TempPath & "\FileList" & myApp & ".txt") |
| Set fileContent = fso.OpenTextFile(fileName, ForWriting, True, TristateTrue) |
| |
| For Index = 1 To limit |
| vFileName = myDocList(Index) |
| fileContent.WriteLine (vFileName) |
| Next |
| |
| fileContent.Close |
| End If |
| |
| FinalExit: |
| Set fileContent = Nothing |
| WriteDocsToAnalyze = fileName |
| Exit Function |
| |
| HandleErrors: |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source |
| Resume FinalExit |
| End Function |
| |
| ' This function looks for the given document name in the document collection |
| ' and returns TRUE and the position of the document in that collection if found, |
| ' FALSE otherwise |
| Function GetDocumentIndex(myDocument As String, _ |
| myDocList As Collection, _ |
| lastIndex As Long) As Boolean |
| |
| Dim currentFunctionName As String |
| currentFunctionName = "GetDocumentIndex" |
| |
| On Error GoTo HandleErrors |
| |
| Dim lastEntry As Long |
| Dim curIndex As Long |
| Dim curEntry As String |
| Dim entryFound As Boolean |
| |
| entryFound = False |
| lastEntry = myDocList.count |
| curIndex = lastIndex |
| |
| ' We start the search at the position of the last found |
| ' document |
| While Not entryFound And curIndex <= lastEntry |
| curEntry = myDocList.item(curIndex) |
| If (curEntry = myDocument) Then |
| lastIndex = curIndex |
| entryFound = True |
| Else |
| curIndex = curIndex + 1 |
| End If |
| Wend |
| |
| ' When we could not find the document, we start the search |
| ' from the beginning of the list |
| If Not entryFound Then |
| curIndex = 1 |
| While Not entryFound And curIndex <= lastIndex |
| curEntry = myDocList.item(curIndex) |
| If (curEntry = myDocument) Then |
| lastIndex = curIndex |
| entryFound = True |
| Else |
| curIndex = curIndex + 1 |
| End If |
| Wend |
| End If |
| |
| FinalExit: |
| GetDocumentIndex = entryFound |
| Exit Function |
| HandleErrors: |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source |
| Resume FinalExit |
| End Function |
| |
| Function AnalyseList(myDocList As Collection, _ |
| myApp As String, _ |
| myIniFilePath As String, _ |
| myOffset As Long, _ |
| analysisAborted As Boolean) As Boolean |
| |
| On Error GoTo HandleErrors |
| Dim currentFunctionName As String |
| currentFunctionName = "AnalyseList" |
| |
| Dim cmdLine As String |
| Dim filelist As String |
| Dim statFileName As String |
| Dim finished As Boolean |
| Dim analyseStatus As Integer |
| Dim nRetries As Integer |
| Dim lastFile As String |
| Dim lastHandledFile As String |
| Dim launchStatus As Long |
| Dim fso As New FileSystemObject |
| Dim progressTitle As String |
| |
| filelist = WriteDocsToAnalyze(myDocList, myApp, fso) |
| cmdLine = fso.GetAbsolutePathName(C_LAUNCH_DRIVER) & " " & myApp |
| finished = False |
| |
| Dim TempPath As String |
| TempPath = fso.GetSpecialFolder(TemporaryFolder).path |
| If (TempPath = "") Then TempPath = "." |
| statFileName = fso.GetAbsolutePathName(TempPath & "\StatFile" & myApp & ".txt") |
| If (fso.FileExists(statFileName)) Then fso.DeleteFile (statFileName) |
| |
| WriteToLog CFILE_LIST, filelist, myIniFilePath |
| WriteToLog CSTAT_FILE, statFileName, myIniFilePath |
| WriteToLog CLAST_CHECKPOINT, "", myIniFilePath |
| WriteToLog CNEXT_FILE, "", myIniFilePath |
| WriteToLog C_ABORT_ANALYSIS, "", myIniFilePath |
| |
| ' In this loop we will restart the driver until we have finished the analysis |
| nRetries = 0 |
| While Not finished And nRetries < C_MAX_RETRIES |
| launchStatus = launchDriver(statFileName, cmdLine, myApp, fso, _ |
| myDocList, myOffset, myIniFilePath) |
| If (launchStatus = ABORTED) Then |
| finished = True |
| analyseStatus = C_STAT_ABORTED |
| analysisAborted = True |
| Else |
| analyseStatus = CheckAnalyseStatus(statFileName, lastHandledFile, fso) |
| End If |
| If (analyseStatus = C_STAT_DONE) Then |
| finished = True |
| ElseIf (analyseStatus = C_STAT_RETRY) Then |
| If (lastHandledFile = lastFile) Then |
| nRetries = nRetries + 1 |
| Else |
| lastFile = lastHandledFile |
| nRetries = 1 |
| End If |
| Else |
| nRetries = nRetries + 1 |
| End If |
| Wend |
| |
| If (analyseStatus = C_STAT_DONE) Then |
| AnalyseList = True |
| Else |
| AnalyseList = False |
| End If |
| |
| 'The next driver should not overwrite this result file |
| WriteToLog CNEW_RESULTS_FILE, "False", myIniFilePath |
| |
| FinalExit: |
| Set fso = Nothing |
| Exit Function |
| |
| HandleErrors: |
| AnalyseList = False |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source |
| Resume FinalExit |
| End Function |
| |
| Sub HandleAbort(hProcess As Long, curApplication As String) |
| |
| On Error Resume Next |
| |
| Dim ret As Long |
| Dim curDate As Date |
| Dim stillWaiting As Boolean |
| Dim killApplication As Boolean |
| Dim waitTime As Long |
| |
| curDate = Now() |
| stillWaiting = True |
| killApplication = False |
| |
| While stillWaiting |
| stillWaiting = IsOfficeAppRunning(curApplication) |
| If (stillWaiting) Then |
| waitTime = val(DateDiff("s", curDate, Now())) |
| If (waitTime > C_ABORT_TIMEOUT) Then |
| stillWaiting = False |
| killApplication = True |
| End If |
| End If |
| Wend |
| |
| If (killApplication) Then |
| ShowProgress.g_SP_AllowOtherDLG = True |
| TerminateMSO.Show vbModal, ShowProgress |
| End If |
| |
| ret = TerminateProcess(hProcess, "0") |
| End Sub |
