frmmain.frm

VB开发的自动更新程序

Dim lLineLength     As Long         '//Length of untrimmed line
Dim sLineText       As String       '//Line before trimming
Dim sValueText      As String       '//Value text after = sign
Dim sText As String * 255           '//Buffer for EM_GETLINE call
Dim lStartTopLine   As Long         '//Starting top visible line
Dim lEndTopLine   As Long           '//Ending top visible line


lLine = lLine - 1                   '//Adjust since API calls are 0 based
lStartChar = SendMessage(rtHwnd, EM_LINEINDEX, lLine, ByVal 0&)

'//Cancel if line was deleted (this may occur only when coloring non-selected lines)
If lStartChar = -1 Then Exit Sub

SetWindowState bLocked              '//Lock the RTB from processing updates
bSkipColoring = True                '//Skip coloring routines while processing
lSelStart = Me.rtBox.SelStart       '//Get current caret position
lSelStartLen = Me.rtBox.SelLength   '//Get current selected text length

'//Fill variables upfront to be used during processing
lStartTopLine = SendMessage(rtHwnd, EM_GETFIRSTVISIBLELINE, ByVal 0&, ByVal 0&)
lLineLength = SendMessage(rtHwnd, EM_LINELENGTH, lStartChar, ByVal 0&)
sText = Space(255): Call SendMessage(rtHwnd, EM_GETLINE, lLine, ByVal sText)
sLineText = UCase$(StripNulls(Left$(sText, lLineLength))): sText = ""
sTrimmedLine = Trim$(sLineText)

'//Except for assigning the RTB's selected text color and bolded state, the remaining
'..code works with assigned variables, so processing is still fairly quick.
With Me.rtBox
    Select Case Left$(sTrimmedLine, 1)
        Case ";"
            '//Commented line, so only make it eCOMMENT color
            SendMessage rtHwnd, EM_SETSEL, ByVal lStartChar, ByVal lStartChar + lLineLength
            .SelColor = eCOMMENT
            .SelBold = False

        Case "["
            '//Section Header, see if it matches Header list from LoadTag procedure
            lConstStart = InStr(1, sLineText, "[", vbTextCompare)
            lConstEnd = InStr(1, sLineText, "]", vbTextCompare)
            If lConstEnd > lConstStart Then
                With SecTags
                    For x = 0 To UBound(.Tag)
                        sTrimmedLine2 = Left$(sTrimmedLine, .Length(x))
                        If sTrimmedLine2 = UCase$(.Tag(x)) Then
                            bTagFound = True
                            Exit For
                        End If
                    Next x
                End With
                If bTagFound Then
                    Y = InStr(1, sLineText, SecTags.Tag(x), vbTextCompare)
                    '//Bold and color section header text
                    SendMessage rtHwnd, EM_SETSEL, ByVal lStartChar + Y - 1, ByVal lStartChar + Y - 1 + SecTags.Length(x)
                    .SelBold = True
                    .SelColor = Setup.SecTagColor
                    .SelText = SecTags.Tag(x)
                    '//Comment any remaining text after section header closes
                    If (lLineLength - lConstEnd) > 0 Then
                        SendMessage rtHwnd, EM_SETSEL, ByVal lStartChar + lConstEnd, ByVal lStartChar + lLineLength
                        .SelBold = False
                        .SelColor = eCOMMENT
                    End If
                Else
                    SendMessage rtHwnd, EM_SETSEL, ByVal lStartChar, ByVal lStartChar + lLineLength
                    .SelColor = vbBlack
                    .SelBold = False
                End If
            Else
                SendMessage rtHwnd, EM_SETSEL, ByVal lStartChar, ByVal lStartChar + lLineLength
                .SelColor = vbBlack
                .SelBold = False
            End If
            
        Case Else
            '//Keys
            With KeyTags
                For x = 0 To UBound(.Tag)
                    sTrimmedLine2 = Left$(sTrimmedLine, .Length(x))
                    If sTrimmedLine2 = UCase$(.Tag(x)) Then
                        bTagFound = True
                        Exit For
                    End If
                Next x
            End With
            If bTagFound Then
                '//Tag was found, lets process it
                Y = InStr(1, sLineText, KeyTags.Tag(x), vbTextCompare)
                '//Color tag
                SendMessage rtHwnd, EM_SETSEL, ByVal lStartChar + Y - 1, ByVal lStartChar + Y - 1 + KeyTags.Length(x)
                .SelBold = False
                .SelColor = Setup.KeyTagColor
                .SelText = KeyTags.Tag(x)      '//Makes tag the case you specifed in LoadTags
                '//Color any remaining text vbBlack
                If (lLineLength - Y + 1 - KeyTags.Length(x)) > 0 Then
                    SendMessage rtHwnd, EM_SETSEL, ByVal lStartChar + Y - 1 + KeyTags.Length(x), ByVal lStartChar + lLineLength
                    .SelBold = False
                    .SelColor = vbBlack
                    '//Now check for value tags. This also ensures tags are in the right place
                    '..after the = sign, but allows for spaces and tabs between them for formatting.
                    If KeyTags.HasValTag(x) Then
                        sTrimmedLine = Replace(sLineText, vbTab, "")
                        sTrimmedLine = Replace(sLineText, " ", "")
                        Y = InStr(1, sTrimmedLine, "=", vbTextCompare)
                        If Len(sTrimmedLine) > Y Then
                            sValueText = Right$(sTrimmedLine, Len(sTrimmedLine) - Y)
                            For z = 0 To UBound(ValTags.Tag)
                                If ValTags.DataType(z) = KeyTags.DataType(x) Then
                                    If Left$(sValueText, ValTags.Length(z)) = UCase$(ValTags.Tag(z)) Then
                                        lConstStart = InStr(1, sLineText, UCase$(ValTags.Tag(z)))
                                        '//Color value tag
                                        SendMessage rtHwnd, EM_SETSEL, ByVal lStartChar + lConstStart - 1, ByVal lStartChar + lConstStart - 1 + ValTags.Length(z)
                                        .SelColor = Setup.ValTagColor
                                        .SelText = ValTags.Tag(z)   '//Makes tag the case you specifed in LoadTags
                                        If Not ValTags.TextAfter(z) Then
                                            '//Don't allow text after so color it red
                                            SendMessage rtHwnd, EM_SETSEL, ByVal lStartChar + lConstStart + ValTags.Length(z) - 1, ByVal lStartChar + lLineLength
                                            .SelColor = eERROR
                                        End If
                                        Exit For
                                    End If
                                End If
                            Next z
                        End If
                    End If
                End If
            Else
                '//No tags found so color line vbBlack
                SendMessage rtHwnd, EM_SETSEL, ByVal lStartChar, ByVal lStartChar + lLineLength
                .SelBold = False
                .SelColor = vbBlack
            End If
    End Select
    '//Return cursor to starting selection
    SendMessage rtHwnd, EM_SETSEL, ByVal lSelStart, ByVal lSelStart + lSelStartLen
End With

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

bSkipColoring = False       '//Continue coloring
SetWindowState bUnLocked    '//Refresh RTB

End Sub

Private Sub Comment()
'-----------------------------------------------------------------------------------
' Purpose   : Comments selected block in a RTB. Results mimic VB IDE comment button.
'-----------------------------------------------------------------------------------
On Error Resume Next            '//Can't break it, but better safe than sorry!
Dim x               As Long     '//For loop, then first selected char when complete
Dim Y               As Long     '//Final selected char when complete
Dim lStartChar      As Long     '//First char position in selection
Dim lEndChar        As Long     '//Last char position in selection
Dim lStartLine      As Long     '//First selected line
Dim lEndLine        As Long     '//Last selected line
Dim lLineStartChar  As Long     '//First char position in processing line
Dim lLineLen        As Long     '//Length of processing line
Dim bBeginOffLeft   As Byte     '//Set to 1 if cursor started off left margin
    SetWindowState bLocked
    With Me.rtBox
        lStartChar = .SelStart
        lEndChar = lStartChar + .SelLength
        lStartLine = SendMessage(rtHwnd, EM_LINEFROMCHAR, lStartChar, ByVal 0&)
        lLineStartChar = SendMessage(rtHwnd, EM_LINEINDEX, lStartLine, ByVal 0&)
        If InStr(1, .SelText, vbCrLf, vbTextCompare) Then
            lEndLine = SendMessage(rtHwnd, EM_LINEFROMCHAR, lEndChar - 1, ByVal 0&)
        Else
            lEndLine = SendMessage(rtHwnd, EM_LINEFROMCHAR, lEndChar + 1, ByVal 0&)
        End If
        If lStartChar <> lLineStartChar Then bBeginOffLeft = 1
        '//Comment all lines in the selected block
        For x = lStartLine To lEndLine
            lLineStartChar = SendMessage(rtHwnd, EM_LINEINDEX, x, ByVal 0&)
            lLineLen = SendMessage(rtHwnd, EM_LINELENGTH, lLineStartChar, ByVal 0&)
            SendMessage rtHwnd, EM_SETSEL, ByVal lLineStartChar, ByVal lLineStartChar + lLineLen
            .SelText = ";" & .SelText
        Next x
        '//Now return the caret and select length to where it began (The Hard Part!).
        If bBeginOffLeft Or (lStartChar <> lEndChar) Then
            Y = lEndChar + (lEndLine - lStartLine) + 1
        Else
            Y = lEndChar + (lEndLine - lStartLine)
        End If
        x = lStartChar + bBeginOffLeft
        '//Stop coloring process and set adjusted selection
        bSkipColoring = True
        SendMessage rtHwnd, EM_SETSEL, ByVal x, ByVal Y
        bSkipColoring = False
        .SetFocus
    End With
    SetWindowState bUnLocked
End Sub

Private Sub UnComment()
'--------------------------------------------------------------------------------------
' Purpose   : UnComments selected block in an RTB. Results mimic VB IDE comment button.
'--------------------------------------------------------------------------------------
On Error Resume Next            '//Can't break it, but better safe than sorry!
Dim x                   As Long
Dim Y                   As Long
Dim lStartChar          As Long
Dim lEndChar            As Long
Dim lStartLine          As Long
Dim lEndLine            As Long
Dim lLineStartChar      As Long
Dim lLineLen            As Long
Dim sSelLineText        As String
Dim lCharsRemoved       As Long
Dim bCaretAfterComm     As Byte
    SetWindowState bLocked
    With Me.rtBox
        lStartChar = .SelStart
        lEndChar = lStartChar + .SelLength
        lStartLine = SendMessage(rtHwnd, EM_LINEFROMCHAR, lStartChar, ByVal 0&)
        lLineStartChar = SendMessage(rtHwnd, EM_LINEINDEX, lStartLine, ByVal 0&)
        If InStr(1, .SelText, vbCrLf, vbTextCompare) Then
            lEndLine = SendMessage(rtHwnd, EM_LINEFROMCHAR, lEndChar - 1, ByVal 0&)
        Else
            lEndLine = SendMessage(rtHwnd, EM_LINEFROMCHAR, lEndChar + 1, ByVal 0&)
        End If
        '//UnComment all affected lines in the selected block
        For x = lStartLine To lEndLine
            lLineStartChar = SendMessage(rtHwnd, EM_LINEINDEX, x, ByVal 0&)
            lLineLen = SendMessage(rtHwnd, EM_LINELENGTH, lLineStartChar, ByVal 0&)
            SendMessage rtHwnd, EM_SETSEL, ByVal lLineStartChar, ByVal lLineStartChar + lLineLen
            sSelLineText = Replace$(Replace$(.SelText, vbTab, ""), " ", "")
            If Left$(sSelLineText, 1) = ";" Then
                '//See if the 1st selected char is after the 1st removed comment.
                '..We need this info to determine new select start position.
                If lStartLine = x Then
                    Y = InStr(1, .SelText, ";", vbTextCompare) + lLineStartChar - 1
                    If lStartChar > Y Then
                        bCaretAfterComm = 1
                    Else
                        '//Increment lCharsRemoved if comment is in the 1st lines selection
                        If lStartChar < lEndChar Then lCharsRemoved = lCharsRemoved + 1
                    End If
                ElseIf lEndLine = x Then
                    '//Increment lCharsRemoved if comment is in the last lines selection
                    Y = InStr(1, .SelText, ";", vbTextCompare)
                    If lEndChar - lLineStartChar - 1 > Y Then lCharsRemoved = lCharsRemoved + 1
                Else
                    '//Increment lCharsRemoved for all lines in the middle with leading comments
                    lCharsRemoved = lCharsRemoved + 1
                End If
                '//Set new text for line with comment removed
                sSelLineText = .SelText
                Y = InStr(1, sSelLineText, ";", vbTextCompare)
                .SelText = Left$(sSelLineText, Y - 1) & Right(sSelLineText, lLineLen - Y)
            End If
        Next x
        '//Now return the caret and select length to the corrected positions
        x = lStartChar - bCaretAfterComm
        bSkipColoring = True
        SendMessage rtHwnd, EM_SETSEL, ByVal x, ByVal lEndChar - lCharsRemoved - bCaretAfterComm
        bSkipColoring = False
        .SetFocus
    End With
    SetWindowState bUnLocked
End Sub
Private Function StripNulls(ByVal sString As String) As String
    sString = Replace(sString, vbTab, " ")
    sString = Replace(sString, vbLf, " ")
    sString = Replace(sString, vbCr, " ")
    StripNulls = sString
End Function

Private Function FileSave(Optional ByVal SaveAs = False) As Boolean
On Error GoTo Errs
Dim sFile As String
    If Len(Setup.Script) And Not SaveAs Then
        sFile = Setup.Script
        Me.rtBox.SaveFile Setup.Script, rtfText
        bChanged = False
    Else
        With Me.cd
            .Filter = "ReVive Update Script (*.rus)|*.rus" & _
                      "|Text Files (*.txt;*.rtf;*.doc)|*.txt;*.rtf;*.doc" & _
                      "|All Files (*.*)|*.*"
            .FileName = IIf(Len(Setup.AppShortName) = 0, "update.rus", Setup.AppShortName & ".rus")
            .DefaultExt = ".rus"
            .DialogTitle = "Select a script file name and location..."
            .Flags = cdlOFNFileMustExist Or cdlOFNExplorer _
                Or cdlOFNHideReadOnly Or cdlOFNPathMustExist _
                    Or cdlOFNShareAware