frmmain.frm

VB开发的自动更新程序

                    End If
                Next x
                If bError Then Exit For '//Get out if duplicate key found.
                If x = UBound(KeyTags.Tag) + 1 Then
                    bError = True
                    sMessage = "'" & Trim$(sKey) & "' is not a recognized key in " & sSection & " section.   "
                    Exit For
                Else
                    If Section <> KeyTags.Section(x) Then
                        bError = True
                        sMessage = "'" & Trim$(sKey) & "' is not a recognized key in " & sSection & " section.   "
                        Exit For
                    ElseIf Len(sValue) = 0 Then
                        bError = True
                        sMessage = "Key '" & Trim$(sKey) & "' has no assigned value.   "
                        Exit For
                    ElseIf Not IsValueValid(sValue, KeyTags.DataType(x)) Then
                        bError = True
                        sMessage = "'" & Trim$(sValue) & "' is not a valid datatype for '" & sKey & "' key.   " & _
                                vbNewLine & vbNewLine & sExpValue
                        Exit For
                    End If
                End If
            End If

    End Select
    
SkipLine:
Next line

If bError Then
    SetWindowState bUnLocked
    MsgBox sMessage & vbNewLine & vbNewLine & "If you wish to ignore this " & _
            "line while testing please comment it.   ", vbExclamation, "Script Error"
Else
    '//Return cursor to starting selection
    SendMessage rtHwnd, EM_SETSEL, ByVal lSelStart, ByVal lSelStart + lSelStartLen
    '//This mess seems to have whipped (or sudo-disabled) the richtextboxes autoscroll
    '..into submission when coloring a PREVLINENUMBER that is out of view. It basically
    '..checks the difference between where we are now and where we started, and returns
    '..the scrolling position to where we began if necessary.
    lEndTopLine = SendMessage(rtHwnd, EM_GETFIRSTVISIBLELINE, ByVal 0&, ByVal 0&)
    If lStartTopLine <> lEndTopLine Then
        x = IIf(lStartTopLine < lEndTopLine, -(lEndTopLine - lStartTopLine), lStartTopLine - lEndTopLine)
        Call SendMessage(rtHwnd, EM_LINESCROLL, ByVal 0&, ByVal x)
    End If
    MsgBox "No apparent errors were detected in script.   ", vbInformation, "Test Complete"
    SetWindowState bUnLocked
End If
bSkipColoring = False
End Sub

Private Function IsValueValid(ByVal sValue As String, ByVal DataType As enumDataTypes) As Boolean
On Error GoTo Errs
Dim b As Boolean
Dim l As Long
Dim i As Integer
Dim s As String
    sValue = LCase$(sValue)
    Select Case DataType
        Case eBOOLEAN
            sExpValue = "Expected value: True, False, 0 or 1.  "
            '//I am looking for specific characters in this app, but a cBOOL will normally work.
            If sValue <> "true" And sValue <> "false" And sValue <> "0" And sValue <> "1" Then
                GoTo Errs
            End If
        Case eINTEGER
            sExpValue = "Expected value: -32,768 to 32,767.  "
            i = CInt(sValue)
        Case eLONG
            sExpValue = "Expected value: -2,147,483,648 to 2,147,483,647.  "
            l = CLng(sValue)
        Case eWEB
            sExpValue = "Expected value: Must begin with http://, ftp://, \\ or a drive letter followed by :.  "
            If Left$(sValue, 7) <> "http://" And Left$(sValue, 6) <> "ftp://" And _
                Left$(sValue, 2) <> "\\" And Mid$(sValue, 2, 1) <> ":" Then
                GoTo Errs
            End If
        Case eVERSION
            sExpValue = "Expected value: A valid version number formatted like '0.0.0.0', containing only characters 0 - 9 and 3 decimal points(.)."
            If Not IsVersionValid(sValue) Then GoTo Errs
        Case ePATH
            sExpValue = "Expected value: A valid path, including filename, meeting Windows naming convention rules.  "
            If Not IsLocalPathValid(sValue, False) Then GoTo Errs
    End Select
    IsValueValid = True
Errs:
    Exit Function
End Function

Private Function IsLocalPathValid(ByVal sPath As String, _
    Optional ByVal VerifyDriveExist As Boolean = False) As Boolean
'---------------------------------------------------------------------
' Purpose   : Checks if sPath will pass Windows file and folder naming
'             convention rules before attempting to create it.
'---------------------------------------------------------------------
On Error GoTo Errs
Dim folder()    As String
Dim badchars()  As String
Dim reswords()  As String
Dim path        As String
Dim i           As Byte
Dim x           As Long
Dim file        As String

'//Exit if \\ is anywhere in path
If InStr(1, sPath, "\\", vbTextCompare) Then Exit Function

'//Build invalid char and reserved word lists
badchars = Split("| < > * ? / : " & Chr(34), " ")
reswords = Split("CON PRN AUX CLOCK$ NUL LPT1 LPT2 LPT3 LPT4 LPT5 LPT6 LPT7 " & _
                    "LPT8 LPT9 COM1 COM2 COM3 COM4 COM5 COM6 COM7 COM8 COM9", " ")

'//Replace contants with C: for this application
If InStr(1, sPath, "<", vbTextCompare) Then
    With ValTags
        For x = 0 To UBound(.Tag)
            If .DataType(x) = ePATH Then
                If InStr(1, sPath, .Tag(x), vbTextCompare) Then
                    sPath = Replace(sPath, .Tag(x), "C:")
                    Exit For
                End If
            End If
        Next x
    End With
End If

path = Right$(sPath, Len(sPath) - InStrRev(sPath, "\"))
x = InStrRev(path, ".")
If x = 0 Then
    '//Verify destination filename is included in InstallPath
    Exit Function
Else
    file = Left$(path, x - 1)
End If

'//Parse drive and folders
folder = Split(sPath, "\")

'//Extract drive and check if valid
path = LCase$(folder(0))
If VerifyDriveExist Then
    If Dir$(path, 63) = "" Then Exit Function
Else
    For x = 97 To 122
        If path = Chr(x) & ":" Then Exit For
    Next x
    If x = 123 Then Exit Function
End If

'//Check for invalid folder characters and reserved words
For i = 1 To UBound(folder)
    For x = 0 To 7
        If InStr(1, folder(i), badchars(x)) Then Exit Function
    Next x
    For x = 0 To 22
        If UCase$(folder(i)) = reswords(x) Then Exit Function
    Next x
Next i

'//If checking for Win95 - ME compatibility, check for filenames
'..longer than 8 characters (DOS 8.3 format)
If Setup.TestForFileNames Then
    If Len(file) > 8 Then
        MsgBox "InstallPath file name " & UCase$(file) & " is longer than 8 characters. When    " & Chr(13) & _
               "updating in-use files on clients running pre-NT based operating systems,    " & Chr(13) & _
               "Windows will rename this file " & Left$(UCase$(file), 6) & "~1, and will therefore inaccurately    " & Chr(13) & _
               "update the clients system. Please consider shortening the file name to    " & Chr(13) & _
               "no more than 8 characters to eliminate this possible compatibility issue.    ", vbInformation, "Compatibility Issue"
    End If
End If
        
IsLocalPathValid = True

Errs:
    If Err Then MsgBox Err.Description: Exit Function
    
End Function

Private Sub Form_Unload(Cancel As Integer)
On Error GoTo Errs
Dim m As Long
    If bChanged Then
        m = MsgBox("Do you wish to save the changes made to this script?   ", vbYesNoCancel + vbQuestion, "Save Changes?")
        If m = 6 Then
            If Not FileSave Then Cancel = 1: Exit Sub
        ElseIf m = 2 Then
            Cancel = True
            Exit Sub
        End If
    End If
    WinHelp Me.hwnd, App.path & "ReVive.hlp", HELP_QUIT, "" '--- Close any open help topics
Errs:
    Call SetWindowLong(Me.hwnd, GWL_WNDPROC, OldWindowProc)
    Set frmMain = Nothing
End Sub

Private Function FillTreeView()

With Me.tv
    Set .ImageList = Me.iml
    .Nodes.Add , , "[Setup]", "[Setup]", 6
    .Nodes.Add "[Setup]", 4, "AdminRequired=", "AdminRequired", 12
    .Nodes.Add "[Setup]", 4, "AppShortName=", "AppShortName", 12
    .Nodes.Add "[Setup]", 4, "AppLongName=", "AppLongName", 12
    .Nodes.Add "[Setup]", 4, "ForceReboots=", "ForceReboots", 12
    .Nodes.Add "[Setup]", 4, "LaunchIfKilled=", "LaunchIfKilled", 12
    .Nodes.Add "[Setup]", 4, "NotifyIcon=", "NotifyIcon", 12
    .Nodes.Add "[Setup]", 4, "RegRISFiles=", "RegRISFiles", 12
    .Nodes.Add "[Setup]", 4, "ScriptURLAlt=", "ScriptURLAlt", 12
    .Nodes.Add "[Setup]", 4, "ScriptURLPrim=", "ScriptURLPrim", 12
    .Nodes.Add "[Setup]", 4, "ShowFileIcons=", "ShowFileIcons", 12
    .Nodes.Add "[Setup]", 4, "UpdateAppClass=", "UpdateAppClass", 12
    .Nodes.Add "[Setup]", 4, "UpdateAppKill=", "UpdateAppKill", 12
    .Nodes.Add "[Setup]", 4, "UpdateAppTitle=", "UpdateAppTitle", 12
    
    .Nodes.Add , , "[Files]", "[Files]", 13
    .Nodes.Add "[Files]", 4, "Description=", "Description", 12
    .Nodes.Add "[Files]", 4, "DownloadURL=", "DownloadURL", 12
    .Nodes.Add "[Files]", 4, "FileSize=", "FileSize", 12
    .Nodes.Add "[Files]", 4, "InstallPath=", "InstallPath", 12
    .Nodes.Add "[Files]", 4, "MustExist=", "MustExist", 12
    .Nodes.Add "[Files]", 4, "MustUpdate=", "MustUpdate", 12
    .Nodes.Add "[Files]", 4, "UpdateVersion=", "UpdateVersion", 12
    .Nodes.Add "[Files]", 4, "UpdateMessage=", "UpdateMessage", 12
    
    .Nodes.Add , , "Directory Constants", "Directory Constants", 14
    .Nodes.Add "Directory Constants", 4, "<ap>", "<ap>", 12
    .Nodes.Add "Directory Constants", 4, "<cf>", "<cf>", 12
    .Nodes.Add "Directory Constants", 4, "<commondesktop>", "<commondesktop>", 12
    .Nodes.Add "Directory Constants", 4, "<commonstartmenu>", "<commonstartmenu>", 12
    .Nodes.Add "Directory Constants", 4, "<pf>", "<pf>", 12
    .Nodes.Add "Directory Constants", 4, "<sp>", "<sp>", 12
    .Nodes.Add "Directory Constants", 4, "<sys>", "<sys>", 12
    .Nodes.Add "Directory Constants", 4, "<temp>", "<temp>", 12
    .Nodes.Add "Directory Constants", 4, "<userdesktop>", "<userdesktop>", 12
    .Nodes.Add "Directory Constants", 4, "<userstartmenu>", "<userstartmenu>", 12
    .Nodes.Add "Directory Constants", 4, "<win>", "<win>", 12
    .Nodes(1).Expanded = True
    .Nodes(15).Expanded = True
    .Nodes(24).Expanded = True
    .Nodes(1).Bold = True
    .Nodes(15).Bold = True
    .Nodes(24).Bold = True
    .Nodes(1).Selected = True
End With
End Function

Private Sub tv_DblClick()
Dim s As String
    s = Me.tv.SelectedItem.Key
    If Left(s, 1) = "[" Or s = "Directory Constants" Then Exit Sub
    Me.rtBox.SetFocus
    Me.Font.name = "Courier New"
    SendKeys s
    If Left(s, 1) = "<" Then
        SendKeys "\"
    Else
        SendKeys vbTab
        If Me.TextWidth(s) <= 1160 Then SendKeys vbTab
    End If
    Me.Font.name = "MS Sans Serif"
End Sub

Private Sub tv_NodeClick(ByVal Node As MSComctlLib.Node)
    Call DisplayTip(Node.Text, Me)
End Sub

Private Sub SetTVColor()
Dim lStyle              As Long
Dim TVNode              As Node
Const GWL_STYLE         As Long = -16&
Const TVM_SETBKCOLOR    As Long = 4381&
Const TVS_HASLINES      As Long = 2&
    For Each TVNode In tv.Nodes
        TVNode.BackColor = 15790320
    Next
    Call SendMessage(tv.hwnd, TVM_SETBKCOLOR, 0, ByVal 15790320)
    lStyle = GetWindowLong(tv.hwnd, GWL_STYLE)
    Call SetWindowLong(tv.hwnd, GWL_STYLE, lStyle And (Not TVS_HASLINES))
    Call SetWindowLong(tv.hwnd, GWL_STYLE, lStyle)
End Sub

Private Function InIDE() As Boolean
On Error GoTo Errs
    Debug.Print 1 / 0
    Exit Function
Errs:
    InIDE = True
End Function