| 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 |