frmdoc.frm

VB写的一个IDE开发环境,支持脚本运行,内置了一个简单的编译器,可以直接生成EXE.. 推荐下载!

            frmMain.保存
        End If
    End If
    Set oSyntax = Nothing
    
End Sub

Private Sub Image1_Click()
    Me.WindowState = 1
End Sub

Private Sub Image2_Click()
    Me.WindowState = 2
    Picture1.Visible = False
    Picture3.Visible = False
    frmMain.Picture3.Visible = True
    Form_Resize
End Sub

Private Sub Image3_Click()
    Unload Me
End Sub

Private Sub Picture1_DblClick()
    Image2_Click
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub

Private Sub rtfText_Change()
高亮
WriteLineNumbers
Call 提示信息
End Sub

Public Sub Undo()
SendMessage rtfText.hwnd, WM_UNDO, 0, 0
End Sub
Public Sub CopyM()
SendMessage rtfText.hwnd, WM_COPY, 0, 0
End Sub
Public Sub Cut()
SendMessage rtfText.hwnd, WM_CUT, 0, 0
End Sub
Public Sub Paste()
SendMessage rtfText.hwnd, WM_PASTE, 0, 0
End Sub
Public Sub Delete()
SendMessage rtfText.hwnd, WM_CLEAR, 0, 0
End Sub
Public Sub SelAll()
SendMessage rtfText.hwnd, EM_SETSEL, 0, -1
End Sub

Public Sub Find(FindStr As String)
On Error GoTo Err:
Dim Tmp, temp
    Tmp = Me.rtfText.Find(FindStr)
    Me.rtfText.SelStart = Tmp
    Me.rtfText.SelLength = Len(FindStr)
    temp = Len(FindStr) + Tmp
    SendMessage Me.rtfText.hwnd, EM_SETSEL, Tmp, temp
'Call Sleep(1000)
    Exit Sub
Err:
    MsgBox "没有找到！"
End Sub

Public Sub SelectCurrentLine()
Dim lStart      As Long
Dim lFinish     As Long
    lStart = SendMessage(rtfText.hwnd, EM_LINEINDEX, CurrentLineNumber - 1, 0&)
    lFinish = SendMessage(rtfText.hwnd, EM_LINELENGTH, lStart, 0)
    rtfText.SelStart = lStart
    rtfText.SelLength = lFinish
End Sub

Public Sub ResetColours(lLine As Long)
Dim lStart      As Long
Dim lFinish     As Long
Dim lCursor     As Long
Dim lSelectLen  As Long
    'LockWindowUpdate rtfText.hwnd
    lStart = SendMessage(rtfText.hwnd, EM_LINEINDEX, lLine, 0&)
    lFinish = SendMessage(rtfText.hwnd, EM_LINELENGTH, lStart, 0)
    lCursor = rtfText.SelStart
    lSelectLen = rtfText.SelLength
    rtfText.SelStart = lStart
    rtfText.SelLength = lFinish
    rtfText.SelColor = vbBlack
    rtfText.SelBold = False
    rtfText.SelItalic = False
    rtfText.SelStart = lCursor
    rtfText.SelLength = lSelectLen
    'LockWindowUpdate 0&
End Sub
'得到某行内容
Public Function GetLine(lngLine As Long) As String
Dim sAllText    As String
Dim lngindex    As Long
Dim lnglength   As Long
Dim x           As Long
Dim stemp       As String
Dim sChar       As Long
Dim Tmp
    sAllText = rtfText.Text
    lngindex = SendMessage(rtfText.hwnd, EM_LINEINDEX, lngLine - 1, 0)
    lnglength = SendMessage(rtfText.hwnd, EM_LINELENGTH, lngindex, 0) + 2
    
    For x = 1 To Len(sAllText)
        Tmp = Mid(sAllText, x, 1)
        If LenB(StrConv(Tmp, vbFromUnicode)) = 2 Then
            If lngindex < 0 Or lngindex = 0 Then lngindex = 1: Exit For
            lngindex = lngindex - 1
        'ElseIf LenB(StrConv(Tmp, vbFromUnicode)) = 1 Then
        '    If Not Asc(Tmp) = 10 And Not Asc(Tmp) = 13 Then lngindex = lngindex + 1
        End If
    Next x
    
    stemp = Mid$(sAllText, lngindex + 1, lnglength)
    
    For x = 1 To Len(stemp) 'LenB(StrConv(stemp, vbFromUnicode))
        sChar = Asc(Mid$(stemp, x, 1))
        If Not sChar = 10 And Not sChar = 13 Then
            GetLine = GetLine & Mid$(stemp, x, 1)
        End If
    Next x
End Function
'行
Public Function CurrentLineNumber() As Long
    CurrentLineNumber = SendMessage(rtfText.hwnd, EM_LINEFROMCHAR, ByVal -1, 0&) + 1
End Function
'列
Public Function CurrentColumnNumber() As Long
Dim lCurLine As Long
    lCurLine = 1 + rtfText.GetLineFromChar(rtfText.SelStart)
    CurrentColumnNumber = SendMessage(rtfText.hwnd, EM_LINEINDEX, ByVal lCurLine - 1, 0&)
    CurrentColumnNumber = (rtfText.SelStart) - CurrentColumnNumber
End Function
'行
Public Function LineCount() As Long
    LineCount = SendMessage(rtfText.hwnd, EM_GETLINECOUNT, 0, 0)
End Function

Public Sub WriteLineNumbers()
'Exit Sub
Dim x           As Long
Dim lStart      As Long
Dim FontHeight  As Long
Dim lFinish     As Long
Dim colCount    As Long
    lStart = SendMessage(rtfText.hwnd, EM_GETFIRSTVISIBLELINE, 0, 0) + 1
    picLineNumbers.Cls
    'picLineNumbers.Font = rtfText.Font.Name
    'picLineNumbers.FontSize = rtfText.Font.Size
    'picLineNumbers.BackColor = &HC8D0D4
    picLineNumbers.ForeColor = vbWhite
    FontHeight = picLineNumbers.TextHeight("1")
    'Exit Sub
    lFinish = (rtfText.Height / FontHeight) + lStart
    If lFinish > LineCount Then lFinish = LineCount
    For x = lStart To lFinish
        picLineNumbers.Print x & " "
    Next x
End Sub

Private Sub rtfText_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    WriteLineNumbers
End Sub

Private Sub rtfText_OLEDragDrop(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
rtfText.LoadFile Data.Files.Item(1)
End Sub



'Public Sub ColourSelection(lStartLine As Long, lEndLine As Long)
'Dim x                       As Long
'Dim i                       As Long
'Dim lCurLineStart           As Long
'Dim lCurLineEnd             As Long
'Dim sLineText               As String
'Dim sLineTextRTF            As String
'Dim lnglength               As Long
'Dim nQuoteEnd               As Long
'Dim sCurrentWord            As String
'Dim sChar                   As String
'Dim nWordPos                As Long
'Dim lColour                 As Long
'Dim lLastBreak              As Long
'Dim sBoldStart              As String
'Dim sBoldEnd                As String
'Dim bDone                   As Boolean
'Dim lLineOffset             As Long
'Dim lStartRTFCode           As Long
'Dim stmpstring              As String
'
'    With rtfText
'        For i = lStartLine To lEndLine
'            lCurLineStart = SendMessage(.hwnd, EM_LINEINDEX, i, 0&)
'            lnglength = SendMessage(.hwnd, EM_LINELENGTH, lCurLineStart, 0)
'            If lCurLineStart >= 0 And lnglength > 0 Then
'                .SelStart = lCurLineStart
'                .SelLength = lnglength
'                If lCurLineStart = 1 Then lCurLineStart = 0
'                    sLineText = .SelText
'                    If InStr(1, sLineText, "\") Or InStr(1, sLineText, "{") Or InStr(1, sLineText, "}") Then
'                        sLineText = Replace$(sLineText, "\", "\\")
'                        sLineText = Replace$(sLineText, "{", "\{")
'                        sLineText = Replace$(sLineText, "}", "\}")
'                        lnglength = Len(sLineText)
'                    End If
'                    If Left$(LTrim$(sLineText), 2) = "//" Then
'                        .SelColor = m_ColourComment
'                        If m_ItalicComments = True Then
'                            .SelItalic = True
'                        End If
'                    Else
'                        lLastBreak = 1
'                        For x = 1 To Len(sLineText)
'                            sChar = Mid$(sLineText, x, 1)
'                            bDone = False
'                            Select Case sChar
'                                Case COMMENT_IDENTIFER
'                                    If Len(sLineTextRTF) > 0 Then
'                                        .SelRTF = "{{\colortfTextl;\red" & RGBRed1 & "\green" & _
'                                                    RGBGreen1 & "\blue" & RGBBlue1 & ";\red" & RGBRed2 & _
'                                                    "\green" & RGBGreen2 & "\blue" & RGBBlue2 & ";\red" & _
'                                                    RGBRed3 & "\green" & RGBGreen3 & "\blue" & RGBBlue3 & _
'                                                    ";\red" & RGBRed4 & "\green" & RGBGreen4 & "\blue" & _
'                                                    RGBBlue4 & ";\red" & RGBRed5 & "\green" & RGBGreen5 _
'                                                    & "\blue" & RGBBlue5 & ";}" & sLineTextRTF & "\I0\B0}\par"
'                                    End If
'                                    .SelStart = lCurLineStart + x - 1
'                                    .SelLength = (lnglength + 2) - x
'                                    .SelColor = m_ColourComment
'                                    If m_ItalicComments = True Then
'                                        .SelItalic = True
'                                    End If
'                                    bDone = True
'                                    Exit For
'                                Case Chr(34)
'                                    nQuoteEnd = InStr(x + 1, sLineText, Chr(34), vbBinaryCompare)
'                                    If nQuoteEnd = 0 Then nQuoteEnd = Len(sLineText)
'                                    If sLineTextRTF = "" Then sLineTextRTF = sLineText
'                                    If m_ProcessStrings = True Then
'                                        stmpstring = "{\cf4" & Mid$(sLineText, x, (nQuoteEnd - x) + 1) & "\cf0}"
'                                        sLineTextRTF = Replace$(sLineTextRTF, Mid$(sLineText, x, (nQuoteEnd - x) + 1), "{\cf4" & Mid$(sLineText, x, (nQuoteEnd - x) + 1) & "\cf0}")
'                                        lLineOffset = lLineOffset + 10
'                                    End If
'                                    x = nQuoteEnd
'                                Case "a" To "z", "A" To "Z", "_"
'                                    sCurrentWord = sCurrentWord & sChar
'                                    If x = Len(sLineText) Then GoTo ColourWord
'                                Case "0" To "9"
'                                    If Len(sCurrentWord) > 1 Then GoTo ColourWord
'                                    sCurrentWord = sChar
'                                    GoTo ColourNumber
'                                Case "$"
'                                    If Len(sCurrentWord) > 1 Then GoTo ColourWord
'                                    sCurrentWord = sChar
'                                    GoTo ColourNumber
'                                Case "-"
'                                    If Len(sCurrentWord) > 1 Then GoTo ColourWord
'                                    sCurrentWord = sChar
'                                    GoTo ColourNumber
'                                Case Else
'ColourWord:
'                                    If sCurrentWord <> "" Then
'                                        nWordPos = InStr(1, m_ceKeyWords & m_ceOperators, "*" & sCurrentWord & "*", vbTextCompare)
'                                        If nWordPos > 0 Then
'                                            If nWordPos > Len(m_ceKeyWords) Then
'                                                lColour = 2
'                                            Else
'                                                lColour = 1
'                                            End If
'                                            If m_BoldSelectedKeyWords = True Then
'                                                If InStr(1, m_ceBoldWords, "*" & sCurrentWord & "*", vbTextCompare) Then
'                                                    sBoldStart = "\b1"
'                                                    sBoldEnd = "\b0"
'                                                Else
'                                                    sBoldStart = ""
'                                                    sBoldEnd = ""
'                                                End If
'                                            End If
'                                            If m_NormaliseCase = True Then
'                                                sCurrentWord = Mid$(m_ceKeyWords & m_ceOperators, InStr(1, LCase$(m_ceKeyWords & m_ceOperators), "*" & LCase$(sCurrentWord) & "*", vbBinaryCompare) + 1, Len(sCurrentWord))
'                                            End If
'                                            If sLineTextRTF = "" Then sLineTextRTF = sLineText
'                                            sLineTextRTF = ReplaceFullWord$(sLineTextRTF, sCurrentWord, "{\cf" & lColour & sBoldStart & sCurrentWord & sBoldEnd & "\cf0}", lLastBreak + lLineOffset, 1, vbTextCompare)
'                                            lLineOffset = lLineOffset + 10 + IIf(Len(sBoldStart) > 0, 6, 0)
'                                        GoTo ResetWord
'                                        End If
'ColourNumber:
'                                        If IsNumeric(sCurrentWord) = True Or sCurrentWord = "," Or sCurrentWord = "$" Then
'                                            If sLineTextRTF = "" Then sLineTextRTF = sLineText
'                                            sLineTextRTF = ReplaceFullWord$(sLineTextRTF, sCurrentWord, "{\cf" & 5 & " " & sCurrentWord & "\cf0}", lLastBreak + lLineOffset, 1, vbTextCompare)
'                                            lLineOffset = lLineOffset + 11 + IIf(Len(sBoldStart) > 0, 6, 0)
'                                        End If
'ColourComma:
'                                        If sCurrentWord = "," Or sCurrentWord = ";" Or sCurrentWord = "<" Or sCurrentWord = ">" Or sCurrentWord = "=" Or sCurrentWord = "!" Or sCurrentWord = "@" Then
'                                            If sLineTextRTF = "" Then sLineTextRTF = sLineText
'                                            sLineTextRTF = ReplaceFullWord$(sLineTextRTF, sCurrentWord, "{\cf" & 2 & sCurrentWord & "\cf0}", lLastBreak + lLineOffset, 1, vbTextCompare)
'                                            lLineOffset = lLineOffset + 11 + IIf(Len(sBoldStart) > 0, 6, 0)
'                                        End If
'ResetWord:
'                                        sCurrentWord = ""
'                                    End If
'                                    lLastBreak = x
'                            End Select
'                        Next x
'                        If sLineTextRTF <> "" And bDone = False Then
'                            .SelRTF = "{{\colortfTextl;\red" & RGBRed1 & "\green" & _
'                                        RGBGreen1 & "\blue" & RGBBlue1 & ";\red" & RGBRed2 & _
'                                        "\green" & RGBGreen2 & "\blue" & RGBBlue2 & ";\red" & _
'                                        RGBRed3 & "\green" & RGBGreen3 & "\blue" & RGBBlue3 & _
'                                        ";\red" & RGBRed4 & "\green" & RGBGreen4 & "\blue" & _
'                                        RGBBlue4 & ";\red" & RGBRed5 & "\green" & RGBGreen5 _
'                                        & "\blue" & RGBBlue5 & ";}" & sLineTextRTF & "\I0\B0}\par"
'
'                        End If
'                        sLineTextRTF = ""
'                        lLineOffset = 0
'                    End If
'            End If
'        Next i
'    End With
'End Sub