语法着色控件使用典型范例

frmMain.frm

VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Object = "{BCA00000-0F85-414C-A938-5526E9F1E56A}#4.0#0"; "CASMUI.dll"
Begin VB.Form frmMain 
   Caption         =   "FileMonitor"
   ClientHeight    =   8235
   ClientLeft      =   60
   ClientTop       =   630
   ClientWidth     =   9195
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   8235
   ScaleWidth      =   9195
   Begin CodeMax4Ctl.CodeMax CodeMax1 
      Height          =   3855
      Left            =   0
      OleObjectBlob   =   "frmMain.frx":030A
      TabIndex        =   1
      Top             =   405
      Width           =   6135
   End
   Begin VB.Timer Timer2 
      Interval        =   3000
      Left            =   3360
      Top             =   4800
   End
   Begin RichTextLib.RichTextBox rtbFile 
      Height          =   375
      Left            =   0
      TabIndex        =   0
      ToolTipText     =   "Drag the file to this place"
      Top             =   0
      Width           =   6135
      _ExtentX        =   10821
      _ExtentY        =   661
      _Version        =   393217
      MultiLine       =   0   'False
      AutoVerbMenu    =   -1  'True
      OLEDropMode     =   1
      TextRTF         =   $"frmMain.frx":03FA
   End
   Begin VB.Timer Timer1 
      Interval        =   1000
      Left            =   2760
      Top             =   4800
   End
   Begin VB.Label lblMsg 
      BackStyle       =   0  'Transparent
      BorderStyle     =   1  'Fixed Single
      Caption         =   "Ln 1, Col 0"
      Height          =   255
      Left            =   0
      TabIndex        =   2
      Top             =   7965
      Width           =   3255
   End
   Begin VB.Menu mnuFile 
      Caption         =   "&File"
      Begin VB.Menu mnuFileOpen 
         Caption         =   "&Open"
      End
      Begin VB.Menu mnuFLine1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileDelete 
         Caption         =   "&Delete"
         Shortcut        =   ^D
      End
      Begin VB.Menu mnuFileRContent 
         Caption         =   "&Refresh"
         Shortcut        =   ^T
      End
      Begin VB.Menu mnuFLine2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit 
         Caption         =   "&Exit"
      End
   End
   Begin VB.Menu mnuView 
      Caption         =   "&View"
      Begin VB.Menu mnuViewSetTop 
         Caption         =   "&Set Top"
         Shortcut        =   ^{F3}
      End
      Begin VB.Menu mnuVLine1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuViewLineNo 
         Caption         =   "Line &Numbers"
      End
      Begin VB.Menu mnuViewLineNoBold 
         Caption         =   "Line Number &BoldSel"
      End
      Begin VB.Menu mnuViewMargin 
         Caption         =   "Selection Margin"
      End
      Begin VB.Menu mnuSelLine 
         Caption         =   "Auto Select Line"
      End
   End
   Begin VB.Menu mnuWM 
      Caption         =   "Wide&Monitor"
      Begin VB.Menu mnuWMForm 
         Caption         =   "FormLog"
         Shortcut        =   ^{F1}
      End
      Begin VB.Menu mnuWMControl 
         Caption         =   "ControlLog"
         Shortcut        =   ^{F2}
      End
      Begin VB.Menu mnuWLine1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuWMRFileName 
         Caption         =   "Refresh File &Name"
         Shortcut        =   ^N
      End
      Begin VB.Menu mnuWMAutoRFileName 
         Caption         =   "Auto &Refresh File Name"
         Shortcut        =   ^R
      End
      Begin VB.Menu mnuWLine2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuWMAnalysis 
         Caption         =   "&Analysis VBP"
      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
Private Declare Function SetWindowPos& Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Dim sFileTime As String
Dim sFileTimeTmp As String
Dim isTop As Boolean
Dim isRefreshFN As Boolean
Dim isLineNumbering As Boolean
Dim isDisplayLeftMargin As Boolean
Dim isAutoSelLine As Boolean
Dim isAnalysisVbp As Boolean
Dim isNumberBoldSel As Boolean
Dim lngLastLine As Long
Dim lngLastSelLine As Long
Private Sub Form_Load()
    Call initApp
    Call mnuViewSetTop_Click
    Call mnuWMAutoRFileName_Click
    Call mnuViewMargin_Click
    Call mnuViewLineNo_Click
'    Call mnuSelLine_Click
End Sub
Private Sub Form_Resize()
    On Error GoTo Err1
    rtbFile.Width = Me.ScaleWidth
    lblMsg.Top = Me.ScaleHeight - lblMsg.Height
    lblMsg.Width = Me.ScaleWidth
    CodeMax1.Width = Me.ScaleWidth
    CodeMax1.Height = Me.ScaleHeight - CodeMax1.Top - lblMsg.Height
Err1:
End Sub
Private Sub CodeMax1_MouseUp(ByVal Button As CodeMax4Ctl.cmMouseBtn, ByVal Modifiers As CodeMax4Ctl.cmKeyMod, ByVal X As Long, ByVal Y As Long)
    If Not isAutoSelLine Then Exit Sub
    
    Dim r As New CodeMax4Ctl.Range
    Set r = CodeMax1.GetSel(False)
    
    If lngLastLine <> r.EndLineNo Then
        On Error GoTo Err1
        CodeMax1.SelectLine r.EndLineNo, True
        lngLastLine = r.EndLineNo
    End If
Err1:
End Sub
Private Sub CodeMax1_SelChange()
    Dim r As New CodeMax4Ctl.Range
    Set r = CodeMax1.GetSel(False)
    lblMsg.Caption = "Ln " & r.EndLineNo + 1 & ", Col " & r.EndColNo + 1
    
    If CodeMax1.LineCount = 1 Then CodeMax1.SetLineColor 0, &HFFFFC0
    On Error Resume Next
    If r.EndLineNo <> lngLastSelLine Then
        CodeMax1.SetLineColor lngLastSelLine, vbWhite
        lngLastSelLine = r.EndLineNo
        CodeMax1.SetLineColor r.EndLineNo, &HFFFFC0
    End If
End Sub
Private Sub mnuViewLineNoBold_Click()
    isNumberBoldSel = Not isNumberBoldSel
    mnuViewLineNoBold.Checked = isNumberBoldSel
    CodeMax1.LineNumberBoldSel = isNumberBoldSel
End Sub
Private Sub mnuWMAnalysis_Click()
    isAnalysisVbp = Not isAnalysisVbp
    mnuWMAnalysis.Checked = isAnalysisVbp
    
    If isAnalysisVbp And isRefreshFN Then
        Timer1.Enabled = False
        Call mnuWMAutoRFileName_Click
    End If
End Sub
Private Sub mnuWMAutoRFileName_Click()
    isRefreshFN = Not isRefreshFN
    mnuWMAutoRFileName.Checked = isRefreshFN
    Timer2.Enabled = isRefreshFN
    
    If Timer2.Enabled Then Timer1.Enabled = True
End Sub
Private Sub mnuSelLine_Click()
    isAutoSelLine = Not isAutoSelLine
    mnuSelLine.Checked = isAutoSelLine
End Sub
Private Sub mnuViewLineNo_Click()
    isLineNumbering = Not isLineNumbering
    mnuViewLineNo.Checked = isLineNumbering
    CodeMax1.LineNumbering = isLineNumbering
End Sub
Private Sub mnuViewMargin_Click()
    isDisplayLeftMargin = Not isDisplayLeftMargin
    mnuViewMargin.Checked = isDisplayLeftMargin
    CodeMax1.DisplayLeftMargin = isDisplayLeftMargin
End Sub
Private Sub mnuWMControl_Click()
    rtbFile.Text = "C:/egmain-ex/Bin/WideMonitor_CtrlLog"
    Call mnuWMRFileName_Click
End Sub
Private Sub mnuWMForm_Click()
    rtbFile.Text = "C:/egmain-ex/Bin/WideMonitor_FormLog"
    Call mnuWMRFileName_Click
End Sub
Private Sub mnuFileOpen_Click()
    Dim strFile$, strFilter$
    strFilter = "log(*.log;)" & Chr$(0) & _
                "*.log;" & Chr$(0) & _
                "txt(*.txt;)" & Chr$(0) & _
                "*.txt;" & Chr$(0) & _
                "All Files(*.*)" & Chr$(0) & _
                        "*.*" & Chr$(0)
    strFile = browseFile(Me.hWnd, "Select a file", strFilter)
    If strFile <> "" Then rtbFile.Text = strFile
End Sub
Private Sub mnuFileDelete_Click()
    On Error GoTo Err1
    Kill rtbFile.Text
    Call mnuFileRContent_Click
Err1:
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub
Private Sub mnuViewSetTop_Click()
    isTop = Not isTop
    mnuViewSetTop.Checked = isTop
    SetWindowPos Me.hWnd, IIf(isTop, -1, -2), 0, 0, 0, 0, 3
End Sub
Private Sub mnuFileRContent_Click()
    On Error GoTo Err1
    Call loadFile(rtbFile.Text)
    sFileTime = FileDateTime(rtbFile.Text)
    Exit Sub
Err1:
    CodeMax1.Text = ""
End Sub
Private Sub loadFile(strFile$)
        CodeMax1.Text = fileStr(rtbFile.Text)
        CodeMax1.SelectLine CodeMax1.LineCount - 1, True
        lngLastSelLine = CodeMax1.LineCount - 1
        CodeMax1.SetLineColor lngLastSelLine, &HFFFFC0
End Sub
Private Sub mnuWMRFileName_Click()
    Dim l1&
    If rtbFile.Text = "" Then Exit Sub
    l1 = InStr(LCase(rtbFile.Text), "log")
    If l1 > 0 Then rtbFile.Text = Left(rtbFile.Text, l1 + 2) & Format(Now, "yyyymmddhh") & ".log"
End Sub
Private Sub rtbFile_Change()
    Me.Caption = "FileMonitor" & IIf(rtbFile.Text <> "", " - ", "") & rtbFile.Text
    If isAnalysisVbp Then
        CodeMax1.Text = strAanalysisForms(rtbFile.Text)
    Else
        Call mnuFileRContent_Click
    End If
End Sub
Private Sub rtbFile_OLEDragDrop(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim strDragFile As String
    
    If Data.GetFormat(1) Then 'draged is chars block
        strDragFile = Data.GetData(1)
    ElseIf Data.GetFormat(15) Then 'draged is file object
        strDragFile = Data.Files.Item(Data.Files.Count)
    End If
    
    If strDragFile <> "" Then rtbFile.Text = strDragFile
End Sub
'refesh file content
Private Sub Timer1_Timer()
    On Error GoTo Err1
    If rtbFile.Text = "" Then Exit Sub
    sFileTimeTmp = FileDateTime(rtbFile.Text)
    If sFileTimeTmp <> sFileTime Then
        sFileTime = sFileTimeTmp
        Call loadFile(rtbFile.Text)
        Me.WindowState = 0
        
'        If Me.WindowState = 0 Then
'            Me.WindowState = 0
'        Else
'            Me.WindowState = 2
'        End If
    End If
Err1:
End Sub
'init the application controls and vars
Private Sub initApp()
    lngLastLine = -1
    lngLastSelLine = 0
    CodeMax1.SetColor cmClrLeftMargin, &HE0E0E0
    CodeMax1.SetColor cmClrLineNumberBk, &HE0E0E0
    Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
End Sub
'Aanalysis forms
Private Function strAanalysisForms(strFile As String) As String
    Dim strContent As String
    Dim l1&, l2&
    strContent = fileStr(strFile)
    l1 = 1
    Do
        l1 = InStr(l1, strContent, vbCrLf & "Form=")
        If l1 = 0 Then Exit Do
        l1 = l1 + Len(vbCrLf & "Form=")
        l2 = InStr(l1, strContent, vbCrLf)
        strAanalysisForms = strAanalysisForms & Mid(strContent, l1, l2 - l1) & vbCrLf
    Loop
    If Right(strAanalysisForms, 2) = vbCrLf Then strAanalysisForms = Left(strAanalysisForms, Len(strAanalysisForms) - 2)
End Function
'refresh the logfile's name
Private Sub Timer2_Timer()
    Static strLastMin As String
    Dim strTemp$, strHHTemp$
    strTemp = Format(Now, "hh")
    strHHTemp = getFileHour(rtbFile.Text)
    If strLastMin <> strTemp Or (strHHTemp <> "" And strHHTemp <> strTemp) Then
        strLastMin = strTemp
        Call mnuWMRFileName_Click
    End If
End Sub
'get the HH
Private Function getFileHour(strFile$) As String
    Dim i&
    i = InStr(LCase(strFile), ".log")
    If i > 0 Then
        getFileHour = Mid(strFile, i - 2, 2)
    End If
End Function
Private Function fileStr(ByVal strFileName As String) As String
    On Error GoTo Err1
    Open strFileName For Input As #1
    fileStr = StrConv(InputB$(LOF(1), #1), vbUnicode)
    Close #1
    If Right(fileStr, 2) = vbCrLf Then fileStr = Left(fileStr, Len(fileStr) - 2)
    Exit Function
Err1:
End Function