frmmain.frm

一个完整的HTML编辑器

Private Sub cmdColorEdit_Click()
frmRGBHex.Show
End Sub

Private Sub cmdFullView_Click()
If picB.Visible = False Then
picB.Visible = True
Else
picB.Visible = False
End If
If Bottom.Visible = False Then
Bottom.Visible = True
Else
Bottom.Visible = False
End If
End Sub

Private Sub cmdOpenDoc_Click()
CoDocs.Visible = True
End Sub




Private Sub cmdSave_Click()




Dim strFilename As String
Dim intFreeFile As Integer
intFreeFile = FreeFile

dlgCommonDialog.CancelError = True
On Error GoTo ErrHandler

dlgCommonDialog.Filter = _
"Text Files .txt|*.txt*"
dlgCommonDialog.ShowSave
strFilename = dlgCommonDialog.FileName

Open strFilename For Output As #intFreeFile
Print #intFreeFile, txtClib.Text
Close #intFreeFile

Exit Sub
ErrHandler:



End Sub



Private Sub CoDocs_LostFocus()
CoDocs.Visible = False
End Sub

Private Sub Command1_Click()
picB.Visible = False
End Sub


Private Sub Command3_Click()
  Call ReColor
End Sub

Function ReColor()

' Set the colors:
m_TextCol = vbBlack
m_AttribCol = 8388736
m_TagCol = 10485760
m_CommentCol = 8421440
m_AspCol = 128

HtmlHighlight
End Function

Private Sub Command2_Click()
If CoSnip.Text = "GoTo.com Search Box" Then
MsgBox "GoTo.com"
End If
End Sub

Private Sub Command4_Click()
frmJava.Show
End Sub

Private Sub Command5_Click()
Unload frmDocument
End Sub

Private Sub Command6_Click()
frmReplace.Show
End Sub

Private Sub DirDirectory_Change()
On Error Resume Next
filFileName.Path = DirDirectory.Path
End Sub

Private Sub drvDrive_Change()
On Error Resume Next
DirDirectory.Path = drvDrive.Drive
End Sub


Private Sub filFileName_DblClick()
'Rename
Dim SplitName As String
'Contins
Dim intFileNum As Integer
Dim strTextLine As String, strFilename As String

If Right(DirDirectory.Path, 1) = "\" Then
strFilename = filFileName.Path & filFileName.FileName
Else
strFilename = filFileName.Path & "\" & filFileName.FileName
End If
'GIF AND JPG FILES PROCEDURE
SplitName = strFilename
'Detects The Extention
    Dim intPos As Integer

    Extension = vbNullString

    intPos = Len(SplitName)

    Do While intPos > 0
        Select Case Mid$(SplitName, intPos, 1)
            Case "."
                Extension = Mid$(SplitName, intPos + 1)
                Exit Do
            Case Else
        End Select

        intPos = intPos - 1
    Loop


If Extension = "gif" Then

frmDocument.rtfText.SelRTF = "<img src=" & SplitName & " width=" & " alt=''" & " Border=''" & " align=''" & ">"
HtmlHighlight

'width="" height="" alt="" border="" align="" onclick="" ondblclick="" usemap="">
'= "<img src=" & SplitName & " width=" & " alt=''" & " Border=''" & " align=''" & ">"
Exit Sub

End If






'HTML FILES PROCEDURE
intFileNum = FreeFile
Open strFilename For Input As #intFileNum
frmDocument.rtfText.Text = ""
Do While Not EOF(intFileNum)
Line Input #intFileNum, strTextLine
frmDocument.rtfText.Text = frmDocument.rtfText.Text & strTextLine & vbCrLf
'txtView.Text = txtView.Text & strTextLine & vbCrLf
Loop
Close #intFileNum

    ' Set the colors:
    m_TextCol = vbBlack
    m_AttribCol = 8388736
    m_TagCol = 10485760
    m_CommentCol = 8421440
    m_AspCol = 128
    
    'HTMLTemplate
    
    HtmlHighlight





End Sub

Function ReadTheFile()


Dim intFileNum As Integer
Dim strTextLine As String, strFilename As String

If Right(DirDirectory.Path, 1) = "\" Then
strFilename = filFileName.Path & filFileName.FileName
Else
strFilename = filFileName.Path & "\" & filFileName.FileName
End If

intFileNum = FreeFile
Open "c:\Casper~www~open.html" For Input As #intFileNum
txtView.Text = ""
Do While Not EOF(intFileNum)
Line Input #intFileNum, strTextLine
StatusBar.SimpleText = "Loading ..."
frmDocument.rtfText.Text = frmDocument.rtfText.Text & strLine & vbCrLf
'txtView.Text = txtView.Text & strTextLine & vbCrLf
Loop
Close #intFileNum

End Function


Private Sub MDIForm_Load()
    Me.Left = GetSetting(App.Title, "Settings", "MainLeft", 1000)
    Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000)
    Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 6500)
    Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 6500)
    SSTab.Height = picB.Height
    filFileName.Height = Me.Height - 5300 - Bottom.Height
    
    'Close
    cmdClose.Left = Bottom.Width - 300
    txtClib.Width = Me.Width - 2000
    cmdSave.Left = cmdClose.Left - 1300
    cmdClear.Left = cmdClose.Left - 1300
    txtClib.Text = "Notes Library ..."
    LoadNewDoc
    HTMLTemplate

    'JavaList Names

    
    CoSnip.AddItem "GoTo.com Search Box"
    CoSnip.AddItem "InfoSeek.com Search"
    CoSnip.AddItem "BohemiaTrading.com"


'##################
'# Coloring Stuff #
'##################

 Screen.MousePointer = vbHourglass
        

    ' Set the colors:
    m_TextCol = vbBlack
    m_AttribCol = 8388736
    m_TagCol = 10485760
    m_CommentCol = 8421440
    m_AspCol = 128
    
    HTMLTemplate
    
    HtmlHighlight
    
    Me.Caption = "Casper HTML: Untitled"
    
    ' Lets let the user see the text box now that everything is finished
    frmDocument.rtfText.Visible = True
    frmDocument.rtfText.TabStop = True
    
    ' Everything is finished so lets set the mouse pointer back so the user knows the wait is over
    Screen.MousePointer = vbNormal
    
    'trapUndo = True     'Enable Undo Trapping
'    RichTxtBox_Change      'Initialize First Undo
frmFrontEdit.Show

End Sub
'################################
'# Subs & Functions of Coloring #
'################################


Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyControl Then
        CtlKey = True
    ElseIf KeyCode = vbKeyF6 And (Shift And vbAltMask) Then
        KeyCode = 0
    End If
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyControl Then
        CtlKey = False
    End If
End Sub

Private Sub rtfText_Change()
    If Not trapUndo Then Exit Sub 'because trapping is disabled

    Dim newElement As New UndoElement   'create new undo element
    Dim c%, l&

    'remove all redo items because of the change
    For c% = 1 To RedoStack.Count
        RedoStack.Remove 1
    Next c%

    'set the values of the new element
    newElement.SelStart = frmDocument.rtfText.SelStart
    newElement.TextLen = Len(frmDocument.rtfText.Text)
    newElement.Text = frmDocument.rtfText.Text

    'add it to the undo stack
    UndoStack.Add Item:=newElement
    
'    EnableControls
End Sub


Private Sub rtfText_KeyPress(KeyAscii As Integer)
On Error Resume Next
    KeyAscii = KeyPressEvent(KeyAscii)
End Sub

Private Sub rtfText_KeyDown(KeyCode As Integer, Shift As Integer)
Dim TypedIn As String
    If Shift And vbCtrlMask Then
        If KeyCode > vbKey0 And KeyCode < vbKey7 Then
            Dim HeadingTag As String
            HeadingTag = "<H" & CStr(KeyCode - vbKey0) & "></H" & CStr(KeyCode - vbKey0) & ">"
            InsertTag HeadingTag, True
            PlaceCursor HeadingTag, 5
            rtfText.SelColor = vbBlack
        Else
            Select Case KeyCode
            Case vbKeyV
                ' User pressed Ctrl+V  - Paste
                Dim A$, S As Long
                S = frmDocument.rtfText.SelStart ' save this since selstart moves up after the paste
                A = Clipboard.GetText(vbCFText)
                frmDocument.rtfText.SelText = ""
                frmDocument.rtfText.SelText = A    ' This removes any unwanted formatting (font, &c)
                HtmlColorCode S, frmDocument.rtfText.SelStart
                
                KeyCode = 0
            Case vbKeyReturn
                InsertTag "<P>", True
                frmDocument.rtfText.SelColor = vbBlack
                KeyCode = 0
            Case vbKeySpace
                frmDocument.rtfText.SelColor = vbBlack
                frmDocument.rtfText.SelText = "&nbsp;"
                KeyCode = 0
            End Select
        End If
    ElseIf Shift And vbShiftMask Then
        If KeyCode = vbKeyReturn Then
            InsertTag "<BR>", True
            frmDocument.rtfText.SelColor = vbBlack
            KeyCode = 0
        End If
    End If
    IsOutsideTag
End Sub

Private Sub rtfText_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    IsOutsideTag
    'rtfText.SetFocus
End Sub



Private Sub rtfText_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyControl Then
        CtlKey = False
    End If
    IsOutsideTag
    frmDocument.rtfText.SetFocus
End Sub


Public Sub GetEditStatus()
   Dim lLine As Long, lCol As Long
   Dim cCol As Long, lChar As Long, i As Long

   lChar = frmDocument.rtfText.SelStart + 1

   ' Get the line number
   lLine = 1 + SendMessageLong(rtfText.hwnd, EM_LINEFROMCHAR, _
           frmDocument.rtfText.SelStart, 0&)

   ' Get the Character Position
   cCol = SendMessageLong(rtfText.hwnd, EM_LINELENGTH, lChar - 1, 0&)

   i = SendMessageLong(rtfText.hwnd, EM_LINEINDEX, lLine - 1, 0&)
   lCol = lChar - i


   sbStatusBar.Panels(1).Text = "Line: " & lLine & ", Col: " & lCol

End Sub


Public Sub PlaceCursor(Text$, Cursor As Long)
Dim T As Long
    T = frmDocument.rtfText.SelStart
    frmDocument.rtfText.SelStart = (T + Len(Tag)) - Cursor
End Sub