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

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