frmmain.frm

VB开发的自动更新程序

            .ShowSave
            sFile = .FileName
            If Dir(sFile, 39) <> "" And sFile <> Setup.Script Then
                If MsgBox("The file you have selected already exist. Do you want to overwrite it?    ", vbYesNo + vbQuestion, "File Exist") = vbNo Then
                    Exit Function
                End If
            End If
            Me.rtBox.SaveFile .FileName, rtfText
            bChanged = False
        End With
    End If
    Me.Caption = "ReVive Script Editor - " & sFile
    Setup.Script = sFile
    FileSave = True
Errs_Exit:
    Exit Function
Errs:
    If Err.Number <> 32755 Then '------------------------- 32755 = "Cancel was selected."
        MsgBox "The following error occured while attempting to save file  " & vbNewLine & _
                "'" & sFile & "'.   " & vbNewLine & vbNewLine & _
                Err.Description, vbExclamation, "Error Saving File"
    End If
    Resume Errs_Exit
End Function

Private Sub FilePrint()
On Error GoTo Errs
    With cd
        .Flags = cdlPDReturnDC + cdlPDNoPageNums
        If rtBox.SelLength = 0 Then
           .Flags = .Flags + cdlPDAllPages
        Else
           .Flags = .Flags + cdlPDSelection
        End If
        .ShowPrinter
        rtBox.SelPrint .hDC
    End With
Errs:
    If Err Then
        If Err.Number <> 32755 Then  '//32755 = "Cancel was selected."
            MsgBox Err.Number & ":  " & Err.Description, vbExclamation, "Error Printing Script"
        End If
        Exit Sub
    End If
End Sub

Private Sub FileOpen(Optional ByVal sFile As String)
On Error GoTo Errs
Dim m           As Integer
Dim lLineCount  As Long
Dim x           As Long
    If bChanged Then
        m = MsgBox("脚本已改变,请问是否保存?   ", vbYesNoCancel + vbQuestion, "提示")
        If m = 6 Then
            If Not FileSave Then Exit Sub
        ElseIf m = 2 Then
            Exit Sub
        End If
    End If
    If Len(sFile) = 0 Then
        With Me.cd
            .HelpFile = App.path & "\ReVive.hlp"
            .HelpContext = 5
            .HelpCommand = cdlHelpContext
            .Filter = "在线更新脚本文件 (*.rus)|*.rus" & _
                      "|文本文件 (*.txt;*.rtf;*.doc)|*.txt;*.rtf;*.doc" & _
                      "|全部文件 (*.*)|*.*"
            .FileName = ""
            .DefaultExt = ".rus"
            .DialogTitle = "请选择一个脚本文件..."
            .Flags = cdlOFNFileMustExist Or cdlOFNExplorer _
                Or cdlOFNHideReadOnly Or cdlOFNPathMustExist _
                    Or cdlOFNShareAware Or cdlOFNHelpButton
            .ShowOpen
            sFile = .FileName
        End With
        Setup.Script = sFile
    End If
    Screen.MousePointer = 11
    SetWindowState bLocked
    Me.rtBox.LoadFile sFile
    Me.Caption = "脚本编辑器 - " & sFile
    lLineCount = SendMessage(rtHwnd, EM_GETLINECOUNT, ByVal 0&, ByVal 0&)
    For x = -lLineCount To -1
        ColorLine Abs(x)
    Next x
Errs_Exit:
    bChanged = False
    PREVLINENUMBER = 1
    SetWindowState bUnLocked
    Screen.MousePointer = 0
    Exit Sub
Errs:
    If Err.Number <> 32755 Then '------------------------- 32755 = "Cancel was selected."
        MsgBox "无法打开选择的文件.  ", vbExclamation, "打开文件错误."
    End If
    Resume Errs_Exit
End Sub

Private Sub FileNew()
Dim m As Integer
On Error GoTo Errs
    If bChanged Then
        m = MsgBox("脚本已改变,请问是否保存?    ", vbYesNoCancel + vbQuestion, "提示")
        If m = 6 Then
            If Not FileSave Then Exit Sub
        ElseIf m = 2 Then
            Exit Sub
        End If
    End If
    frmNew.Show 1
Errs:
    If Err Then Exit Sub
End Sub

Private Sub AddSectionTag(ByVal Tag As String, _
    Section As enumSections)
Static s As Long
    With SecTags
        ReDim Preserve .Tag(0 To s)
        ReDim Preserve .Length(0 To s)
        ReDim Preserve .Section(0 To s)
        .Tag(s) = Tag                   '//Actual tag
        .Length(s) = Len(.Tag(s))
        .Section(s) = Section
    End With
    s = s + 1
End Sub

Private Sub AddKeyTag(ByVal Tag As String, _
        ByVal Section As enumSections, ByVal DataType As enumDataTypes, _
        ByVal HasValTag As Boolean)
Static k As Long
    With KeyTags
        ReDim Preserve .Tag(0 To k)
        ReDim Preserve .Length(0 To k)
        ReDim Preserve .DataType(0 To k)
        ReDim Preserve .Section(0 To k)
        ReDim Preserve .HasValTag(0 To k)
        .Tag(k) = Tag                   '//Actual tag
        .DataType(k) = DataType         '//Datatype accepted for tag
        .Section(k) = Section           '//Section tag belongs in
        .HasValTag(k) = HasValTag
        .Length(k) = Len(.Tag(k))
    End With
    k = k + 1
End Sub

Private Sub AddValueTag(ByVal Tag As String, _
        ByVal DataType As enumDataTypes, ByVal AllowTextAfter As Boolean)
Static v As Long
    With ValTags
        ReDim Preserve .Tag(0 To v)
        ReDim Preserve .Length(0 To v)
        ReDim Preserve .DataType(0 To v)
        ReDim Preserve .TextAfter(0 To v)
        .Tag(v) = Tag                   '//Actual tag
        .Length(v) = Len(.Tag(v))
        .DataType(v) = DataType
        .TextAfter(v) = AllowTextAfter
    End With
    v = v + 1
End Sub

Private Sub TestScript()
'---------------------------------------------------------------------------------------------
' Purpose   : Tests script for the following errors: (More or less in this order)
'             1. Invalid Section Headers not identified in LoadTag procedure.
'             2. Duplication of Section Headers within script.
'             3. Invalid Section Keys not identified in LoadTag procedure.
'             4. Duplication of Section Keys within same Section.
'             5. Placement of Section Keys in wrong Section as defined in LoadTag procedure.
'             6. Zero length Values for any Section Keys.
'             7. Invalid datatype for each Section Key Value as defined in LoadTag procedure.
'             8. Duplication of Description= values (each must be unique).
'             9. When selected, checks to ensure filenames meet DOS 8.3 format for pre-NT OS's
'             10. Unrecognized text throughout script that is not commented.
'---------------------------------------------------------------------------------------------
Dim line            As Long
Dim x               As Long
Dim sLineText       As String
Dim sKey            As String
Dim sKeyList        As String
Dim sValue          As String
Dim lTotalLines     As Long
Dim lLineLength     As Long
Dim lStartChar      As Long
Dim Section         As enumSections
Dim sSection        As String
Dim sSectionList    As String
Dim sDescriptList   As String
Dim sInstallList    As String
Dim sMessage        As String
Dim bError          As Boolean
Dim lSelStart       As Long
Dim lSelStartLen    As Long
Dim lStartTopLine   As Long
Dim lEndTopLine     As Long

SetWindowState bLocked
bSkipColoring = True

lStartTopLine = SendMessage(rtHwnd, EM_GETFIRSTVISIBLELINE, ByVal 0&, ByVal 0&)
lTotalLines = SendMessage(rtHwnd, EM_GETLINECOUNT, ByVal 0&, ByVal 0&)
Section = eNONE
sSection = "an unknown"
lSelStart = Me.rtBox.SelStart
lSelStartLen = Me.rtBox.SelLength

sSectionList = "|"
sKeyList = "|"
sDescriptList = "|"
sInstallList = "|"

For line = 1 To lTotalLines
    lStartChar = SendMessage(rtHwnd, EM_LINEINDEX, line - 1, ByVal 0&)
    lLineLength = SendMessage(rtHwnd, EM_LINELENGTH, lStartChar, ByVal 0&)
    SendMessage rtHwnd, EM_SETSEL, ByVal lStartChar, ByVal lStartChar + lLineLength
    sLineText = Me.rtBox.SelText
    sLineText = Trim$(StripNulls(Left$(sLineText, lLineLength)))
    If Len(sLineText) = 0 Then GoTo SkipLine
    Select Case Left$(sLineText, 1)
        Case ";", "'"
            GoTo SkipLine
        
        Case "["
            For x = 0 To UBound(SecTags.Tag)
                If Left$(sLineText, SecTags.Length(x)) = SecTags.Tag(x) Then
                    Section = SecTags.Section(x)
                    sSection = SecTags.Tag(x)
                    '//Verify section header is not duplicated
                    If InStr(1, sSectionList, "|" & sSection & "|") Then
                        bError = True
                        sMessage = "'" & sSection & "' section header is duplicated. Only first occurrence recognized.   "
                        Exit For
                    End If
                    sKeyList = ""
                    sSectionList = sSectionList & sSection & "|"
                    GoTo SkipLine
                End If
            Next x
            If bError Then Exit For '//Get out if duplicate section found.
            bError = True
            sMessage = "'" & Trim$(sLineText) & "' is not a recognized section header.   "
            Exit For
            
        Case Else
            sLineText = Replace(sLineText, vbTab, "")
            sLineText = Trim$(sLineText)
            x = InStr(1, sLineText, "=", vbTextCompare)
            If x = 0 Then
                bError = True
                sMessage = "Unrecognized and un-commented text.   "
                Exit For
            Else
                sKey = Left$(sLineText, x)
                sValue = Trim$(Right$(sLineText, Len(sLineText) - x))
                For x = 0 To UBound(KeyTags.Tag)
                    If sKey = KeyTags.Tag(x) Then
                        If KeyTags.Section(x) = Section Then
                            '//Verify Key is not duplicated in current section.
                            If InStr(1, sKeyList, "|" & sKey & "|") Then
                                bError = True
                                sMessage = "'" & Trim$(sKey) & "' key duplicated in '" & sSection & _
                                "' section. Only first occurrence recognized.   "
                                Exit For
                            Else
                                sKeyList = sKeyList & sKey & "|"
                            End If
                            '//Verify file Description= keys do not have duplicate values anywhere in script
                            If sKey = "Description=" Then
                                If InStr(1, sDescriptList, "|" & sValue & "|") Then
                                    bError = True
                                    sMessage = "'" & sValue & "' duplicated. Each '" & sKey & "' key " & _
                                    "must have a unique value.  "
                                    Exit For
                                Else
                                    sDescriptList = sDescriptList & sValue & "|"
                                End If
                            End If
                            '//Verify InstallPath= keys do not have duplicate values anywhere in script
                            If sKey = "InstallPath=" Then
                                If InStr(1, sInstallList, "|" & sValue & "|") Then
                                    bError = True
                                    sMessage = "'" & sValue & "' duplicated. Each '" & sKey & "' key " & _
                                    "must have a unique value.  "
                                    Exit For
                                Else
                                    sInstallList = sInstallList & sValue & "|"
                                End If
                            End If
                            Exit For
                        End If