frmmain.frm

一个完整的HTML编辑器

'frmDocument.rtfText

'#####################################
'# Subs & Functions of Coloring Ends #
'#####################################

Private Sub LoadNewDoc()
    Static lDocumentCount As Long
    Dim frmD As frmDocument
    lDocumentCount = lDocumentCount + 1
    Set frmD = New frmDocument
    frmD.Caption = "Document " & lDocumentCount
    CoDocs.AddItem lDocumentCount
    'CoCap.AddItem frmD.Caption
    frmD.Show
End Sub


Private Sub MDIForm_Unload(Cancel As Integer)
    If Me.WindowState <> vbMinimized Then
        SaveSetting App.Title, "Settings", "MainLeft", Me.Left
        SaveSetting App.Title, "Settings", "MainTop", Me.Top
        SaveSetting App.Title, "Settings", "MainWidth", Me.Width
        SaveSetting App.Title, "Settings", "MainHeight", Me.Height
    End If
End Sub

Private Sub mnuCaps_Click()
Bottom.Visible = True
filFileName.Height = Me.Height - Bottom.Height - 5300
SSTab.Height = picB.Height - 770 + Bottom.Height - 270
End Sub

Private Sub MnuColorEdit_Click()
frmRGBHex.Show
End Sub

Private Sub mnuFiles_Click()
picB.Visible = True

End Sub

Private Sub mnuOpenWWW_Click()
'#################
'# Open From Web #
'#################
frmOpenWWW.Show
End Sub

Private Sub mnuRplace_Click()
frmReplace.Show
End Sub


Private Sub tbToolBar_ButtonClick(ByVal Button As MSComCtlLib.Button)
'RefreshCol
    
    On Error Resume Next
    Select Case Button.Key
        Case "New"
            LoadNewDoc
            HTMLTemplate
            HtmlHighlight
        'ColorEdit
        Case "Color Editor"
            frmRGBHex.Show
        'ColorEdit
        Case "RefreshCol"
            'Refresh
            HtmlHighlight
        Case "FullSize"
            'FullSize
            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 Full
        Case "Open"
            mnuFileOpen_Click
        Case "Save"
            mnuFileSave_Click
        Case "Print"
            mnuFilePrint_Click
        Case "Cut"
            mnuEditCut_Click
        Case "Copy"
            mnuEditCopy_Click
        Case "Paste"
            mnuEditPaste_Click
        Case "Bold"
frmDocument.rtfText.SelRTF = "<B> </B>"
            
            'ActiveForm.rtfText.SelBold = Not ActiveForm.rtfText.SelBold
            Button.Value = IIf(ActiveForm.rtfText.SelBold, tbrPressed, tbrUnpressed)
        Case "Italic"
frmDocument.rtfText.SelRTF = "<I> </I>"
            
            Button.Value = IIf(ActiveForm.rtfText.SelItalic, tbrPressed, tbrUnpressed)
        Case "Underline"
frmDocument.rtfText.SelRTF = "<U> </U>"
            Button.Value = IIf(ActiveForm.rtfText.SelUnderline, tbrPressed, tbrUnpressed)
        Case "Align Left"
frmDocument.rtfText.SelRTF = "<DIV Align=""Left""> </DIV>"
        Case "Center"
frmDocument.rtfText.SelRTF = "<DIV Align=""Middle""> </DIV>"
        Case "Align Right"
frmDocument.rtfText.SelRTF = "<DIV Align=""Right""> </DIV>"
    End Select
End Sub

Private Sub mnuHelpAbout_Click()
    'frmAbout.Show vbModal, Me
frmSplash.Show vbModal, Me
End Sub

Private Sub mnuHelpSearchForHelpOn_Click()
    Dim nRet As Integer


    'if there is no helpfile for this project display a message to the user
    'you can set the HelpFile for your application in the
    'Project Properties dialog
    If Len(App.HelpFile) = 0 Then
        MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation, Me.Caption
    Else
        On Error Resume Next
        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 261, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If

End Sub

Private Sub mnuHelpContents_Click()
    Dim nRet As Integer


    'if there is no helpfile for this project display a message to the user
    'you can set the HelpFile for your application in the
    'Project Properties dialog
    If Len(App.HelpFile) = 0 Then
        MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation, Me.Caption
    Else
        On Error Resume Next
        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 3, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If

End Sub


Private Sub mnuWindowArrangeIcons_Click()
    Me.Arrange vbArrangeIcons
End Sub

Private Sub mnuWindowTileVertical_Click()
    Me.Arrange vbTileVertical
End Sub

Private Sub mnuWindowTileHorizontal_Click()
    Me.Arrange vbTileHorizontal
End Sub

Private Sub mnuWindowCascade_Click()
    Me.Arrange vbCascade
End Sub

Private Sub mnuWindowNewWindow_Click()
    LoadNewDoc
    HtmlHighlight
    HTMLTemplate
End Sub

Private Sub mnuViewWebBrowser_Click()
    'ToDo: Add 'mnuViewWebBrowser_Click' code.
    MsgBox "Add 'mnuViewWebBrowser_Click' code."
End Sub

Private Sub mnuViewOptions_Click()
    'ToDo: Add 'mnuViewOptions_Click' code.
    MsgBox "Add 'mnuViewOptions_Click' code."
End Sub

Private Sub mnuViewRefresh_Click()
HtmlHighlight
End Sub

Private Sub mnuViewStatusBar_Click()
    mnuViewStatusBar.Checked = Not mnuViewStatusBar.Checked
    sbStatusBar.Visible = mnuViewStatusBar.Checked
End Sub

Private Sub mnuViewToolbar_Click()
    mnuViewToolbar.Checked = Not mnuViewToolbar.Checked
    tbToolBar.Visible = mnuViewToolbar.Checked
End Sub

Private Sub mnuEditPaste_Click()
    On Error Resume Next
    ActiveForm.rtfText.SelRTF = Clipboard.GetText

End Sub

Private Sub mnuEditCopy_Click()
    On Error Resume Next
    Clipboard.SetText ActiveForm.rtfText.SelRTF

End Sub

Private Sub mnuEditCut_Click()
    On Error Resume Next
    Clipboard.SetText ActiveForm.rtfText.SelRTF
    ActiveForm.rtfText.SelText = vbNullString

End Sub

Private Sub mnuFileExit_Click()
    'unload the form
    Unload Me

End Sub

Private Sub mnuFileSend_Click()
    'ToDo: Add 'mnuFileSend_Click' code.
    MsgBox "Add 'mnuFileSend_Click' code."
End Sub

Private Sub mnuFilePrint_Click()
    On Error Resume Next
    If ActiveForm Is Nothing Then Exit Sub
    

    With dlgCommonDialog
        .DialogTitle = "Print"
        .CancelError = True
        .Flags = cdlPDReturnDC + cdlPDNoPageNums
        If ActiveForm.rtfText.SelLength = 0 Then
            .Flags = .Flags + cdlPDAllPages
        Else
            .Flags = .Flags + cdlPDSelection
        End If
        .ShowPrinter
        If Err <> MSComDlg.cdlCancel Then
            ActiveForm.rtfText.SelPrint .hDC
        End If
    End With

End Sub

Private Sub mnuFilePrintPreview_Click()
    'ToDo: Add 'mnuFilePrintPreview_Click' code.
    MsgBox "Add 'mnuFilePrintPreview_Click' code."
End Sub

Private Sub mnuFilePageSetup_Click()
    On Error Resume Next
    With dlgCommonDialog
        .DialogTitle = "Page Setup"
        .CancelError = True
        .ShowPrinter
    End With

End Sub

Private Sub mnuFileProperties_Click()
    'ToDo: Add 'mnuFileProperties_Click' code.
    MsgBox "Add 'mnuFileProperties_Click' code."
End Sub

Private Sub mnuFileSaveAll_Click()
frmSaveAs.Show
End Sub

Private Sub mnuFileSaveAs_Click()
frmSaveAs.Show
End Sub

Private Sub mnuFileSave_Click()
frmSaveAs.Show
End Sub

Private Sub mnuFileClose_Click()
    'ToDo: Add 'mnuFileClose_Click' code.
    Unload frmDocument
End Sub

Private Sub mnuFileOpen_Click()
    Dim sFile As String


    If ActiveForm Is Nothing Then LoadNewDoc
    

    With dlgCommonDialog
        .DialogTitle = "Open"
        .CancelError = False
        'ToDo: set the flags and attributes of the common dialog control
        .Filter = "All Files (*.*)|*.*"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    ActiveForm.rtfText.LoadFile sFile
    ActiveForm.Caption = sFile
    HtmlHighlight
End Sub

Private Sub mnuFileNew_Click()
    LoadNewDoc
End Sub

'Inside the NewDoc

Sub HTMLTemplate()
On Error Resume Next '    vbCrLf
    

frmDocument.rtfText.Text = "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.0 Transitional//EN' > " & vbCrLf & vbCrLf
frmDocument.rtfText.Text = frmDocument.rtfText.Text & "<!--X- Created with Casper HTML Editor 1.02 -X--> " & vbCrLf & vbCrLf
frmDocument.rtfText.Text = frmDocument.rtfText.Text & "<html>" & vbCrLf
frmDocument.rtfText.Text = frmDocument.rtfText.Text & "<head>" & vbCrLf
frmDocument.rtfText.Text = frmDocument.rtfText.Text & "    <title>Untitled</title>" & vbCrLf
frmDocument.rtfText.Text = frmDocument.rtfText.Text & "</head>" & vbCrLf & vbCrLf
frmDocument.rtfText.Text = frmDocument.rtfText.Text & "<body>" & vbCrLf & vbCrLf & vbCrLf & vbCrLf
frmDocument.rtfText.Text = frmDocument.rtfText.Text & "</body>" & vbCrLf
frmDocument.rtfText.Text = frmDocument.rtfText.Text & "</html>" & vbCrLf
    frmDocument.rtfText.SetFocus
End Sub

Public Sub InsertTag(Tag$, StopAsp As Boolean)
Dim S As Long
    
    S = frmMain.RichTxtBox.SelStart
    If Len(frmMain.RichTxtBox.SelText) > 0 Then frmMain.RichTxtBox.SelText = ""
    frmMain.RichTxtBox.SelText = Tag$
    
    If StopAsp = True Then
        frmMain.trapUndo = False
        HtmlColorCode S, S + Len(Tag), True
        frmMain.trapUndo = True
    Else
        frmMain.trapUndo = False
        HtmlColorCode S, S + Len(Tag), False
        frmMain.trapUndo = True
    End If
    
    'frmMain.trapUndo = True
End Sub



Public Function PARSE(strUnparsed, strSeparator)
    ' Clear previously parsed words....


    For i = 1 To 20
        strParsed(i) = ""
    Next i
    
    ' Do you really want to know how this wo
    '     rks?
    i = 1
    strStart = 1
    srchStart = 1


    If InStr(1, strUnparsed, strSeparator, vbTextCompare) <> 0 Then


        Do
            strParsed(i) = Mid(strUnparsed, srchStart, InStr(strStart, strUnparsed, strSeparator, vbTextCompare) - srchStart)
            srchStart = InStr(strStart, strUnparsed, strSeparator, vbTextCompare) + Len(strSeparator)
            strStart = srchStart


            If strParsed(i) <> "" Then
                i = i + 1
            End If
        Loop Until InStr(strStart, strUnparsed, strSeparator, vbTextCompare) = 0
        strParsed(i) = Mid(strUnparsed, srchStart, Len(strUnparsed) - srchStart + 1)
    Else
        strParsed(1) = strUnparsed
    End If
End Function