📄 modglobal.bas
字号:
Public Function IsAppRunning(ByVal sWindowCaptionElement As String, Optional ByVal sClassName As String = "") As Boolean
Dim lHandle As Long
pAppFound = False
pSearchTitle = UCase$(sWindowCaptionElement)
pClassName = UCase$(sClassName)
Call EnumWindows(AddressOf EnumWindowsCallBack, lHandle) '---- Enumerate windows to see if ours is running
IsAppRunning = pAppFound '------------------------------------ Set function return
pClassName = vbNull '----------------------------------------- Cleanup
pSearchTitle = vbNull
End Function
Public Sub KillApp()
'--------------------------------------------------------------------------------------
' Purpose : Kills all parent window processes associated with a running ProcessID
'--------------------------------------------------------------------------------------
On Error GoTo Errs
Dim x As Integer
Dim ub As Integer
If Setup.RunMode = eNORMAL Then Screen.MousePointer = vbHourglass
With tRunningApps
ub = UBound(.lWndHwnd)
For x = 0 To ub '---- Cycle through processes looking for our application to close.
If .lWndProcessID(x) = lProcessToKill Then '---------- Look for ProcessID matches.
If GetParent(.lWndHwnd(x)) = 0 Then '------------- Filter out non-parent windows.
SendMessage .lWndHwnd(x), WM_CLOSE, 0&, 0& '-- Send close message.
End If
End If
Next x
End With
DoEvents: Sleep 1000 '--- Provide 1 Sec for processes to end and file locks to release.
'... This worked best with a variety of large and DB connected apps.
'... 1 Sec might be high, but it provided 100% success on all tests.
Errs:
Screen.MousePointer = vbDefault
If Err Then Err.Clear
End Sub
Public Sub CreateReport()
'---------------------------------------------------------------------------------------
' Purpose : Generates and displays LiveUpdate HTML Report
'---------------------------------------------------------------------------------------
On Error Resume Next
Dim s As String
Dim sFile As String
Dim sFileList As String
Dim sUpdatedList As String
Dim sAvailList As String
Dim sErrorList As String
Dim sMissingList As String
Dim sStatus() As String
Dim f As Integer
Dim x As Integer
Dim iFileCount As Integer
Dim iAvailCount As Integer
Dim iUpdatedCount As Integer
Dim iErrorCount As Integer
Dim iMissingFiles As Integer
sFileList = " - "
sUpdatedList = " - "
sAvailList = " - "
sErrorList = " - "
sMissingList = " - "
'//Do the math and create lists
With FileList
ReDim sStatus(1 To UBound(.Description))
For x = 1 To UBound(.Description)
Select Case .Status(x)
Case UPDATEREQ
iAvailCount = iAvailCount + 1
sAvailList = sAvailList & .FileName(x) & ", "
sStatus(x) = "Update Available"
Case NOUPDATEREQ
sStatus(x) = "Installed Version Current - No Update Available"
Case UPDATECOMP
iUpdatedCount = iUpdatedCount + 1
sUpdatedList = sUpdatedList & .FileName(x) & ", "
sStatus(x) = "Success - Update Complete"
Case UPDATECOMPREBOOT
iUpdatedCount = iUpdatedCount + 1
sUpdatedList = sUpdatedList & .FileName(x) & ", "
sStatus(x) = "Success - Reboot Required to Complete Update"
Case ERRCONNECTING
iErrorCount = iErrorCount + 1
sErrorList = sErrorList & .FileName(x) & ", "
sStatus(x) = "Failed - Error Connecting to File"
Case ERRTRANSFERRING
iErrorCount = iErrorCount + 1
sErrorList = sErrorList & .FileName(x) & ", "
sStatus(x) = "Failed - Error During File Transfer"
Case INSUFFPRIVILEGE
iErrorCount = iErrorCount + 1
sErrorList = sErrorList & .FileName(x) & ", "
sStatus(x) = "Failed - Insufficient Privilege to Update"
Case ERRUPDATING
iErrorCount = iErrorCount + 1
sErrorList = sErrorList & .FileName(x) & ", "
sStatus(x) = "Failed - Reason Unknown"
Case FILENOTINSTALLED
iMissingFiles = iMissingFiles + 1
sMissingList = sMissingList & .FileName(x) & ", "
iErrorCount = iErrorCount + 1
sErrorList = sErrorList & .FileName(x) & ", "
sStatus(x) = "Failed - File Must Be Present on Client to Update"
Case Else
sStatus(x) = "Update Available - Pending"
End Select
sFileList = sFileList & .FileName(x) & ", "
Next x
sFileList = IIf(Len(sFileList) > 25, LCase$(Left$(sFileList, Len(sFileList) - 2)), "")
sUpdatedList = IIf(Len(sUpdatedList) > 25, LCase$(Left$(sUpdatedList, Len(sUpdatedList) - 2)), "")
sAvailList = IIf(Len(sAvailList) > 25, LCase$(Left$(sAvailList, Len(sAvailList) - 2)), "")
sErrorList = IIf(Len(sErrorList) > 25, LCase$(Left$(sErrorList, Len(sErrorList) - 2)), "")
sMissingList = IIf(Len(sMissingList) > 25, LCase$(Left$(sMissingList, Len(sMissingList) - 2)), "")
iFileCount = x - 1
End With
'//Begin Creating Report
s = "<html>" & vbNewLine
'//Open head tag
s = s & "<head><META http-equiv=Content-Type content=text/html;charset=UTF-16>" & vbNewLine
'//Create styles
s = s & " <style>BODY{FONT-SIZE:10pt;FONT-FAMILY:MS Sans Serif,Arial}" & vbNewLine
s = s & " .headers{FONT-SIZE: larger;COLOR: white;BACKGROUND-COLOR: #2C78A0}" & vbNewLine
s = s & " .tables{FONT-SIZE: 10pt;COLOR: black;BACKGROUND-COLOR: #EBF2FA}" & vbNewLine
s = s & " </style>" & vbNewLine
'//////////////////////////////////////////////////////////////////////////////////////////
'//Following lines removed to avoid script warning in browser for XP users.
's = s & " <script>" & vbNewLine
's = s & " window.status='Report Generated by ReVive LiveUpdate'" & vbNewLine
's = s & " </script>" & vbNewLine
'//////////////////////////////////////////////////////////////////////////////////////////
'//Close head tag
s = s & "</head>" & vbNewLine
'//Assign browser title
s = s & "<title>" & Setup.AppShortName & " LiveUpdate Report</title>" & vbNewLine
'//Create overview table
s = s & "<BR>" & vbNewLine
s = s & "<table width=750 border=0 align=center cellpadding=0 cellspacing=0>" & vbNewLine
s = s & "<tr class=headers>" & vbNewLine
s = s & " <td width=750 colspan=2 align=center height=30><b>" & Setup.AppShortName & " LiveUpdate Report</b></td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> Application Title:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & Setup.AppLongName & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> Files Checked:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & iFileCount & sFileList & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> Updates Available:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & iAvailCount & sAvailList & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> Updates Completed:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & iUpdatedCount & sUpdatedList & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> Required Files Missing:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & iMissingFiles & sMissingList & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> File Update Errors:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & iErrorCount & sErrorList & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> Requires Admin to Update:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & Setup.AdminRequired & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> Date Created:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & Format(Now, "dd mmm yy - h:mm AM/PM") & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=headers>" & vbNewLine
s = s & " <td width=750 colspan=2 height=2></td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr>" & vbNewLine
s = s & " <td width=750 colspan=2 height=20></td>" & vbNewLine
s = s & "</tr>" & vbNewLine
'//Display file information
With FileList
For x = 1 To UBound(.Description)
s = s & "<tr class=headers>" & vbNewLine
s = s & " <td width=210 align=left height=24><font size=3><b> File " & x & "</b></font></td>" & vbNewLine
s = s & " <td width=540 align=right height=24><font size=3><b>" & .Description(x) & " </b></font></td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> Install Path:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & LCase$(.InstallPath(x)) & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> Installed Version:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & IIf(.CurrentVersion(x) = "0" Or .CurrentVersion(x) = "0.0.0.0", "Not Installed", .CurrentVersion(x)) & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> Updated Version:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & .UpdateVersion(x) & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> File Size:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & Format(.FileSize(x), "0,000 Bytes") & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> Must Succeed to Update App:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & .MustUpdate(x) & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> Must be Installed to Update:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & .MustExist(x) & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "<tr class=tables>" & vbNewLine
s = s & " <td width=210 height=24> Status of Update:</td>" & vbNewLine
s = s & " <td width=540 height=24>" & sStatus(x) & "</td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = IIf(x = UBound(.Description), s & "<tr class=headers>", s & "<tr class=tables>") & vbNewLine
s = s & " <td width=750 colspan=2 height=4></td>" & vbNewLine
s = s & "</tr>" & vbNewLine
Next x
End With
s = s & "<tr>" & vbNewLine
s = s & " <td width=750 colspan=2 height=20></td>" & vbNewLine
s = s & "</tr>" & vbNewLine
s = s & "</table>" & vbNewLine
s = s & "</html>" & vbNewLine
'//Save and open report
sFile = Environ("TEMP") & "\UpdateReport.htm"
f = FreeFile
Open sFile For Output As #f
Print #f, s
Close #f
ShellExecute 0&, "open", sFile, vbNullString, vbNullString, SW_MAXIMIZE
End Sub
'****************************************************************************************
' Private Helper Functions
'****************************************************************************************
Private Function EnumWindowsCallBack(ByVal lHandle As Long, ByVal lpData As Long) As Long
'-----------------------------------------------------------------------------------------
' Author : Chris Cochran (Using sample provided by Dave Scarmozzino, www.thescarms.com)
' Purpose : Call back function from IsAppRunning. Enumerates all parent windows and
' searches for a specific window title and optional classname.
'-----------------------------------------------------------------------------------------
On Error GoTo Errs
Dim lResult As Long
Dim lThreadId As Long
Dim lProcessId As Long
Dim sWindowTitle As String
Dim sClassName As String
Static lCount As Integer
EnumWindowsCallBack = 1
lThreadId = GetWindowThreadProcessId(lHandle, lProcessId)
If lThreadId = App.ThreadID Then Exit Function '---------------- Skip if ReVive ThreadID
If Setup.UpdateAppKill Then '----------------------------------- Skip if we are not killing the app
With tRunningApps
ReDim Preserve .lWndHwnd(0 To lCount)
ReDim Preserve .lWndProcessID(0 To lCount)
.lWndHwnd(lCount) = lHandle
.lWndProcessID(lCount) = lProcessId
End With
lCount = lCount + 1
End If
If Not pAppFound Then '----------------------------------------- Skip below code once app is found
sWindowTitle = Space$(MAX_PATH)
lResult = GetWindowText(lHandle, sWindowTitle, MAX_PATH) '-- Get window title
sWindowTitle = UCase$(Left$(sWindowTitle, lResult))
sClassName = Space$(MAX_PATH)
lResult = GetClassName(lHandle, sClassName, MAX_PATH) '----- Get window classname
sClassName = UCase$(Left$(sClassName, lResult))
If InStr(1, sWindowTitle, pSearchTitle) Then '-------------- Search for our title
If Len(pClassName) Then
If sClassName = pClassName Then '------------------- Check for matching classname if requested
pAppFound = True
lProcessToKill = lProcessId
End If
Else
pAppFound = True
lProcessToKill = lProcessId
End If
End If
End If
Errs:
If Err Then Err.Clear
End Function
Private Function GetLong(ByVal WordHi As Integer, ByVal WordLo As Integer) As Long
GetLong = (CLng(WordHi) * &H10000) Or (WordLo And &HFFFF&)
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -