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