frmmain.frm

VB开发的自动更新程序

      Begin VB.Menu menPrint 
         Caption         =   "打印(&P)"
         Shortcut        =   ^P
      End
      Begin VB.Menu menSep3 
         Caption         =   "-"
      End
      Begin VB.Menu menExit 
         Caption         =   "退出(&E)         "
         Shortcut        =   ^X
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'//Enumerators to identify acceptible data types. Each Key is assigned
'..an expected data type and are tested to ensure values meet criteria.
Private Enum enumDataTypes
    eBOOLEAN = 0
    eINTEGER = 1
    eLONG = 2
    eSTRING = 3
    eWEB = 4
    ePATH = 5
    eVERSION = 6
End Enum

'//Enumerators to identify header (section) for determining what keys may be used under them.
'..Used when Testing script for proper syntax and Value datatypes.
Private Enum enumSections
    eNONE = 0
    eSETUP = 1
    eFILES = 2
End Enum

Private Enum enumColors '------------------ Enumerators for tag colors
    eERROR = &HFF&
    eCOMMENT = &H8000&
End Enum

Private Type typeSectionTags '------------- Type declares for Section Header Tags
    Tag()       As String
    Length()    As Long
    Section()   As enumSections
End Type

Private Type typeKeyTags '----------------- Type declares for Key Tags
    Tag()       As String
    Length()    As Long
    Section()   As enumSections
    DataType()  As enumDataTypes
    HasValTag() As Boolean
End Type

Private Type typeValueTags '--------------- Type declares for Value Tags
    Tag()       As String
    Length()    As Long
    DataType()  As enumDataTypes
    TextAfter() As Boolean
End Type

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd _
    As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Const WM_USER               As Long = &H400 '---- Disable wordwrap declares
Private Const EM_SETTARGETDEVICE    As Long = WM_USER + 72

Private bSkipColoring               As Boolean '------- True when actively coloring a line
Private sExpValue                   As String '-------- Filled with expected datatype when testing

Private CURRLINENUMBER              As Long '---------- Variables that are refreshed in the rtBox_SelChange sub when the selected line number changes
Private CURRLINELENGTH              As Long
Private PREVLINENUMBER              As Long

Private Const GWL_WNDPROC           As Long = (-4)

Private SecTags                     As typeSectionTags
Private KeyTags                     As typeKeyTags
Private ValTags                     As typeValueTags

Private Sub Form_Load()
    rtHwnd = Me.rtBox.hwnd
    Call SendMessage(rtHwnd, EM_SETTARGETDEVICE, 0, 0) '----- Disable wordwrap (ESSENTIAL IN THIS APP)
    Me.rtBox.SelIndent = 100 '------------------------------- Set indent at left
    Me.WindowState = 2 '------------------------------------- Go maximized
    Call LoadTags '------------------------------------------ Assign script tags
    bChanged = False
    If Len(Setup.Script) Then Call FileOpen(Setup.Script) '-- Open passed file
    bChanged = False '--------------------------------------- Reset changed flag
    Call FillTreeView
    Call tv_NodeClick(Me.tv.Nodes(1))
    If Not InIDE Then '-------------------------------------- Skip all this in IDE to avoid crashes
        OldWindowProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)
        Call SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf SubClass_WndMessage)
    End If
    Call SetTVColor
    Me.Show
    Me.rtBox.Visible = True
    Me.rtBox.SetFocus
End Sub

Private Sub tbMain_ButtonClick(ByVal Button As MSComctlLib.Button)
On Error GoTo Errs
    Select Case Button.Caption
        Case "新建"
            Call FileNew
        Case "保存"
            Call FileSave
        Case "打印"
            Call FilePrint
        Case "注释代码"
            Call Comment
        Case "撤消注释"
            Call UnComment
        Case "打开"
            Call FileOpen
        Case "测试"
            Call TestScript
        Case "选项"
            frmOptions.Show 1
        Case "插入"
            frmInsert.Show 1
        Case "分发"
            Call CreateDistributable
        Case "帮助"
            WinHelp Me.hwnd, App.path & "\ReVive.hlp", HELP_CONTENTS, 0&
    End Select
Errs:
    If Err Then MsgBox Err.Description
    Exit Sub
End Sub

Private Sub LoadTags()
Dim x As Long

'******** IF YOU WANT TO USE MORE HIGHLIGHTED TAGS, JUST ADD THEM HERE *********

'*************************** DECRIPTION OF TAGS ********************************
'1. SectionTags are headers for each section, such as [Setup].
'2. KeyTags are keys used in the script, such as "AdminRequired=".
'3. ValueTags are values deemed appropriate for a datatype assigned to a KeyTag.
'
' Syntax: AddKeyTag "TAGNAME=" As String, SECTIONNAME As enumSections, _
'               VALUETYPE as enumDataTypes, HASVALUETAG as Boolean
'
'         AddValueTag "TAGNAME"=, DATATYPE as enumDataTypes, _
'               ALLOWTEXTAFTER as Boolean
'
'         AddSectionTag "TAGNAME" As String, Section As enumSections
'*******************************************************************************

    AddKeyTag "AdminRequired=", eSETUP, eBOOLEAN, True '------ Add Setup section tags
    AddKeyTag "ForceReboots=", eSETUP, eBOOLEAN, True
    AddKeyTag "ScriptURLPrim=", eSETUP, eWEB, False
    AddKeyTag "ScriptURLAlt=", eSETUP, eWEB, False
    AddKeyTag "AppShortName=", eSETUP, eSTRING, False
    AddKeyTag "AppLongName=", eSETUP, eSTRING, False
    AddKeyTag "NotifyIcon=", eSETUP, eWEB, False
    AddKeyTag "UpdateAppTitle=", eSETUP, eSTRING, False
    AddKeyTag "UpdateAppClass=", eSETUP, eSTRING, False
    AddKeyTag "UpdateAppKill=", eSETUP, eBOOLEAN, True
    AddKeyTag "LaunchIfKilled=", eSETUP, ePATH, True
    AddKeyTag "ShowFileIcons=", eSETUP, eBOOLEAN, True
    AddKeyTag "RegRISFiles=", eSETUP, eBOOLEAN, True
    AddKeyTag "Description=", eFILES, eSTRING, False '-------- Add File section tags
    AddKeyTag "UpdateVersion=", eFILES, eVERSION, False
    AddKeyTag "DownloadURL=", eFILES, eWEB, False
    AddKeyTag "InstallPath=", eFILES, ePATH, True
    AddKeyTag "FileSize=", eFILES, eLONG, False
    AddKeyTag "MustUpdate=", eFILES, eBOOLEAN, True
    AddKeyTag "MustExist=", eFILES, eBOOLEAN, True
    AddKeyTag "UpdateMessage=", eFILES, eSTRING, False
    AddValueTag "<ap>", ePATH, True '------------------------- Add Value tags
    AddValueTag "<sp>", ePATH, True
    AddValueTag "<win>", ePATH, True
    AddValueTag "<sys>", ePATH, True
    AddValueTag "<temp>", ePATH, True
    AddValueTag "<pf>", ePATH, True
    AddValueTag "<cf>", ePATH, True
    AddValueTag "<userdesktop>", ePATH, True
    AddValueTag "<userstartmenu>", ePATH, True
    AddValueTag "<commondesktop>", ePATH, True
    AddValueTag "<commonstartmenu>", ePATH, True
    AddValueTag "True", eBOOLEAN, False
    AddValueTag "False", eBOOLEAN, False
    AddValueTag "0", eBOOLEAN, False
    AddValueTag "1", eBOOLEAN, False
    AddSectionTag "[Setup]", eSETUP '------------------------- Add Section header tags
    For x = 1 To 99
        AddSectionTag "[File " & Format(x, "00]"), eFILES
    Next x
End Sub

Private Sub Form_Resize()
On Error Resume Next
Dim fH As Long
Dim fW As Long
    fH = Me.Height
    fW = Me.Width
    Me.rtBox.Move 0, 600, fW - 2785, fH - 1270
    Me.tv.Move fW - 2755, 960, 2635, fH - 3775
    Me.rtTip.Move fW - 2765, fH - 2805, 2645, 2130
    Me.lblAdd.Move fW - 2600
End Sub

Private Sub menExit_Click()
    Unload Me
End Sub

Private Sub menNew_Click()
    Call FileNew
End Sub

Private Sub menOpen_Click()
    Call FileOpen
End Sub

Private Sub menPrint_Click()
    Call FilePrint
End Sub

Private Sub menSave_Click()
    Call FileSave
End Sub

Private Sub menSaveAs_Click()
On Error GoTo Errs
    FileSave True
Errs:
    Exit Sub
End Sub

Private Sub rtBox_Change()
'---------------------------------------------------------------------------
' Purpose   : Colors current line when text is altered if CURRLINELENGTH > 0
'---------------------------------------------------------------------------
    bChanged = True
    If Not bSkipColoring Then
        If CURRLINELENGTH Then Call ColorLine(CURRLINENUMBER)
    End If
End Sub

Private Sub rtBox_SelChange()
'----------------------------------------------------------------------------
' Purpose   : Checks if user transversed lines, and if they did see if text
'             was modified on last line. If modified, recolor PREVLINENUMBER.
'----------------------------------------------------------------------------
Dim lSelStart As Long
Dim lResult As Long
    lSelStart = Me.rtBox.SelStart
    CURRLINENUMBER = 1 + SendMessage(rtHwnd, EM_LINEFROMCHAR, lSelStart, ByVal 0&)
    CURRLINELENGTH = SendMessage(rtHwnd, EM_LINELENGTH, lSelStart, ByVal 0&)
    If Not bSkipColoring And (PREVLINENUMBER <> CURRLINENUMBER) Then
        lResult = SendMessage(rtHwnd, EM_GETMODIFY, ByVal 0&, ByVal 0&)
        If lResult <> 0 Then
            Call ColorLine(PREVLINENUMBER)
            Call SendMessage(rtHwnd, EM_SETMODIFY, False, ByVal 0&)
        End If
        PREVLINENUMBER = CURRLINENUMBER
    End If
End Sub

Public Sub ColorLine(ByVal lLine As Long)
'------------------------------------------------------------------------------------------------------
' Purpose   : Colors text of passed line. This is alot of code, but it is thorough and fairly quick.
'             It allows formatting with tabs and spaces, and is Tag and Key location and
'             data type aware. For example:
'             1. Does not recognize section headers not identified in LoadTag procedure.
'             2. Value tags are only recognized where Key and Value data types match.
'             3. Value tags are only recognized following an =, and allow spaces and tabs between.
'             4. Tags are colored and altered as typed to match case specified in LoadTag procedure.
'             5. Ignored text after identified section headers is colored as commented.
'             6. Illegal text after Values (when not allowed per LoadTag) is colored red.
'             7. Previous lines are always recolored when exiting them. (See rtBox_SelChange)
'             8. RichTextBox autoscroll is effectively disabled when coloring previous lines.
'             9. Users caret point and selection length is always restored when procedure completes.
'------------------------------------------------------------------------------------------------------
Dim x               As Long         '//Perennial favorite, gotta have it!
Dim Y               As Long         '//Perennial favorite, gotta have it!
Dim z               As Long         '//Perennial favorite, gotta have it!
Dim lSelStart       As Long         '//Starting cursor position
Dim lSelStartLen    As Long         '//Starting selection length
Dim lStartChar      As Long         '//First character in current line
Dim sTrimmedLine    As String       '//Line trimmed of Nulls and spaces
Dim sTrimmedLine2   As String       '//Misc uses
Dim bTagFound       As Boolean      '//True when a tag is found
Dim lConstStart     As Long         '//Beginned char of tag or directory contants
Dim lConstEnd       As Long         '//Ending char of tag or directory contants