casperedit.frm

一个完整的HTML编辑器

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "SHDOCVW.DLL"
Begin VB.Form frmDocument 
   Caption         =   "Document"
   ClientHeight    =   3075
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6150
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   3075
   ScaleWidth      =   6150
   WindowState     =   2  'Maximized
   Begin MSComctlLib.ProgressBar PrgBar 
      Height          =   255
      Left            =   3360
      TabIndex        =   4
      Top             =   0
      Visible         =   0   'False
      Width           =   2415
      _ExtentX        =   4260
      _ExtentY        =   450
      _Version        =   393216
      Appearance      =   1
   End
   Begin VB.ComboBox CoSyn 
      Height          =   315
      ItemData        =   "CasperEdit.frx":0000
      Left            =   1680
      List            =   "CasperEdit.frx":0002
      Style           =   2  'Dropdown List
      TabIndex        =   3
      Top             =   0
      Width           =   1575
   End
   Begin SHDocVwCtl.WebBrowser View 
      Height          =   1935
      Left            =   480
      TabIndex        =   2
      Top             =   360
      Visible         =   0   'False
      Width           =   3015
      ExtentX         =   5318
      ExtentY         =   3413
      ViewMode        =   0
      Offline         =   0
      Silent          =   0
      RegisterAsBrowser=   0
      RegisterAsDropTarget=   1
      AutoArrange     =   0   'False
      NoClientEdge    =   0   'False
      AlignLeft       =   0   'False
      ViewID          =   "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
      Location        =   "res://C:\WINDOWS\SYSTEM\SHDOCLC.DLL/dnserror.htm#http:///"
   End
   Begin RichTextLib.RichTextBox rtfText 
      Height          =   1995
      Left            =   480
      TabIndex        =   1
      Top             =   360
      Width           =   3000
      _ExtentX        =   5292
      _ExtentY        =   3519
      _Version        =   393217
      Enabled         =   -1  'True
      ScrollBars      =   3
      TextRTF         =   $"CasperEdit.frx":0004
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Arial"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin MSComctlLib.TabStrip TabV_E 
      Height          =   3135
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   4095
      _ExtentX        =   7223
      _ExtentY        =   5530
      _Version        =   393216
      BeginProperty Tabs {1EFB6598-857C-11D1-B16A-00C0F0283628} 
         NumTabs         =   2
         BeginProperty Tab1 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
            Caption         =   "Edit"
            ImageVarType    =   2
         EndProperty
         BeginProperty Tab2 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
            Caption         =   "View"
            ImageVarType    =   2
         EndProperty
      EndProperty
   End
End
Attribute VB_Name = "frmDocument"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'########################################################################### '
'
' Casper HTML Editor,
' I have developed this just for fun and I of course used some
' of the codes out there. As far as I know you may use the code
' under GPL (General Public Licence), what you do with my code,
' the one I wrote is up to you. Funny think is you'll never know what
' is mine own code -:)
'
' Well anyway, I appreciate your time and if you have any suggestion on
' how to improve the editor, please contact me at : [e-mail]
'
' Why Casper ? Casper Semiramis III was my dog (boxer).
'
' PS:
' I'll work on it some more, specialy on Syntax coloring (It's so damn slow!)
' and then on the snippets & Java library.
'
'########################################################################### '





Private Sub cmdFullView_Click()
FullScreenCall
End Sub

Private Sub Command1_Click()
Unload frmDocument
End Sub

Private Sub Command2_Click()
frmReplace.Show
End Sub







Private Sub CoSyn_DblClick()
frmDocument.rtfText.SelRTF = CoSyn.Text
End Sub


Private Sub rtfText_SelChange()
    fMainForm.tbToolBar.Buttons("Bold").Value = IIf(rtfText.SelBold, tbrPressed, tbrUnpressed)
    fMainForm.tbToolBar.Buttons("Italic").Value = IIf(rtfText.SelItalic, tbrPressed, tbrUnpressed)
    fMainForm.tbToolBar.Buttons("Underline").Value = IIf(rtfText.SelUnderline, tbrPressed, tbrUnpressed)
    fMainForm.tbToolBar.Buttons("Align Left").Value = IIf(rtfText.SelAlignment = rtfLeft, tbrPressed, tbrUnpressed)
    fMainForm.tbToolBar.Buttons("Center").Value = IIf(rtfText.SelAlignment = rtfCenter, tbrPressed, tbrUnpressed)
    fMainForm.tbToolBar.Buttons("Align Right").Value = IIf(rtfText.SelAlignment = rtfRight, tbrPressed, tbrUnpressed)
End Sub

Private Sub Form_Load()

    Form_Resize
    Call Syntax
End Sub


Private Sub Form_Resize()
    On Error Resume Next
    rtfText.Move 250, 250, Me.ScaleWidth - 200, Me.ScaleHeight - 350
    rtfText.RightMargin = rtfText.Width - 400
    'Browser
    View.Move 250, 250, Me.ScaleWidth - 200, Me.ScaleHeight - 350
    View.RightMargin = View.Width - 400
lbl_Lines.Height = rtfText.Height
'TABLET
TabV_E.Width = Me.ScaleWidth
TabV_E.Height = Me.ScaleHeight
'
Main

frmMain.filFileName.Height = Me.Height - 4300 - frmMain.Bottom.Height
    
    'Close
    frmMain.cmdClose.Left = Bottom.Width - 300
    frmMain.txtClib.Width = Me.Width - 2000
    frmMain.cmdSave.Left = cmdClose.Left - 1300
    frmMain.cmdClear.Left = cmdClose.Left - 1300
End Sub

'View.LocationURL = c:\Casper~temp.html
Private Sub TabV_E_Click()
'#################
'# Save for View #
'#################
Dim strView As String
Dim intFile As Integer
intFile = FreeFile
Open "c:\Casper~temp.html" For Output As #intFile
Print #intFile, frmDocument.rtfText.Text
Close #intFile
'View Temp
If View.Visible = True Then
View.Visible = False
Exit Sub
End If
If View.Visible = False Then
View.Visible = True
View.Navigate ("c:\Casper~temp.html")
End If
End Sub


'############
'# COLORING #
'############
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 = rtfText.SelStart
    newElement.TextLen = Len(rtfText.Text)
    newElement.Text = 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)
'GetEditStatus
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 = rtfText.SelStart ' save this since selstart moves up after the paste
                A = Clipboard.GetText(vbCFText)
                rtfText.SelText = ""
                rtfText.SelText = A    ' This removes any unwanted formatting (font, &c)
                HtmlColorCode S, rtfText.SelStart
                
                KeyCode = 0
            Case vbKeyReturn
                InsertTag "<P>", True
                rtfText.SelColor = vbBlack
                KeyCode = 0
            Case vbKeySpace
                rtfText.SelColor = vbBlack
                rtfText.SelText = "&nbsp;"
                KeyCode = 0
            End Select
        End If
    ElseIf Shift And vbShiftMask Then
        If KeyCode = vbKeyReturn Then
            InsertTag "<BR>", True
            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
    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 = rtfText.SelStart + 1

   ' Get the line number
   lLine = 1 + SendMessageLong(rtfText.hwnd, EM_LINEFROMCHAR, _
           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

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

End Sub


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









Function Syntax()
CoSyn.AddItem ("<A ")
CoSyn.AddItem ("<A href")
CoSyn.AddItem ("<A name")
CoSyn.AddItem ("<Applet")
CoSyn.AddItem ("<Blockquote")
CoSyn.AddItem ("<Body")
CoSyn.AddItem ("<Div")
CoSyn.AddItem ("<Font")
CoSyn.AddItem ("<Form")
CoSyn.AddItem ("<Frame")
CoSyn.AddItem ("<Img src=''")
CoSyn.AddItem ("<li")
CoSyn.AddItem ("<ol")
CoSyn.AddItem ("<p>")
CoSyn.AddItem ("<p Align=''")
CoSyn.AddItem ("<strong")
CoSyn.AddItem ("<Style")
CoSyn.AddItem ("<Table")
CoSyn.AddItem ("<td")
CoSyn.AddItem ("<th")
CoSyn.AddItem ("<tr")
CoSyn.AddItem ("<ul")
frmFrontEdit.Show
End Function