yxwmain.frm

文本编辑器。可以通过此列制作出自己的实用编辑器。

         Caption         =   "层叠"
      End
      Begin VB.Menu mnuWindowTileHorizontal 
         Caption         =   "水平平铺"
      End
      Begin VB.Menu mnuWindowTileVertical 
         Caption         =   "垂直平铺"
      End
      Begin VB.Menu mnuWindowArrangeIcons 
         Caption         =   "排列图标"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuHelpContents 
         Caption         =   "内容"
      End
      Begin VB.Menu mnuHelpSearchForHelpOn 
         Caption         =   "联机帮助..."
      End
      Begin VB.Menu mnuHelpBar0 
         Caption         =   "-"
      End
      Begin VB.Menu mnuHelpAbout 
         Caption         =   "关于"
      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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Const EM_UNDO = &HC7
Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)
Const HelpCNT = &HB


Private Sub cmFontName_click()
  Startsel = fMainForm.ActiveForm.rtfText.SelStart
  Length = Len(fMainForm.ActiveForm.rtfText.SelText)
  fontname_change
End Sub

Private Sub cmFontSize_click()
   
   Startsel = fMainForm.ActiveForm.rtfText.SelStart
   Length = Len(fMainForm.ActiveForm.rtfText.SelText)
   FontSize_Change
End Sub

Private Sub color_Click()
 
  fontcolor
End Sub

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)
    
    LoadNewDoc
    
    Dim i As Integer
    Screen.ActiveForm.AutoRedraw = True
    For i = 0 To Screen.FontCount - 1
      cmFontName.AddItem Screen.Fonts(i)
    Next i
    cmFontName.ListIndex = 0
    
    For i = 8 To 72 Step 2
      cmFontSize.AddItem i
    Next i
    cmFontSize.ListIndex = 2
    undo = False
     frmD.mnuEditUndo.Enabled = False
     fMainForm.tbToolBar.Buttons(11).Enabled = False
End Sub

Private Sub MDIForm_Resize()
  With tbToolBar.Buttons("btnfontname")
      cmFontName.Move .Left, .Top, .Width
      cmFontName.ZOrder 0
   End With
 With tbToolBar.Buttons("btnfontsize")
      cmFontSize.Move .Left, .Top, .Width
      cmFontSize.ZOrder 0
      
   End With
   With tbToolBar.Buttons("btnfontcolor")
      color.Move .Left, .Top, .Width
      color.ZOrder 0
      
   End With
End Sub

Private Sub mnuFileOpen_Click()
  Open_Click
End Sub

Private Sub mnuViewToolbar_Click()
    mnuViewToolbar.Checked = Not mnuViewToolbar.Checked
    tbToolBar.Visible = mnuViewToolbar.Checked
    
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 tbToolBar_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    Select Case Button.Key
        Case "New"
            LoadNewDoc
        Case "Open"
            Open_Click
        Case "Save"
            Save_Click
        Case "Print"
            mnuFilePrint_Click
        Case "Cut"
            Cut_Click
        Case "Copy"
            Copy_Click
        Case "Paste"
            Paste_Click
        Case "Delete"
            Delete_Click
        Case "Undo"
            If undo Then
              undo_click
            End If
        Case "Redo"
            If undo = False Then
              undo_click
            End If
        Case "Spell Check"
            SpellCheck (fMainForm.ActiveForm.rtfText.Text)
        Case "Bold"
            ActiveForm.rtfText.SelBold = Not ActiveForm.rtfText.SelBold
            Button.Value = IIf(ActiveForm.rtfText.SelBold, tbrPressed, tbrUnpressed)
        Case "Italic"
            ActiveForm.rtfText.SelItalic = Not ActiveForm.rtfText.SelItalic
            Button.Value = IIf(ActiveForm.rtfText.SelItalic, tbrPressed, tbrUnpressed)
        Case "Underline"
            ActiveForm.rtfText.SelUnderline = Not ActiveForm.rtfText.SelUnderline
            Button.Value = IIf(ActiveForm.rtfText.SelUnderline, tbrPressed, tbrUnpressed)
        Case "Align Left"
            ActiveForm.rtfText.SelAlignment = rtfLeft
        Case "Center"
            ActiveForm.rtfText.SelAlignment = rtfCenter
        Case "Align Right"
            ActiveForm.rtfText.SelAlignment = rtfRight
        Case "Help"
            mnuHelpContents_Click
     
    End Select
End Sub

Private Sub mnuHelpAbout_Click()
    MsgBox "Version " & App.Major & "." & App.Minor & "." & App.Revision
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
     On Error GoTo errhandler
     ShellExecute 0, "Open", "D:\Program Files\Microsoft Office\Office\2052\MSOHELP.CHM", 0, 0, 1
      Exit Sub
   
errhandler:
  MsgBox Err.Description
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
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()
    'ToDo: Add 'mnuViewRefresh_Click' code.
    MsgBox "Add 'mnuViewRefresh_Click' code."
End Sub

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






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


Private Sub mnuFileExit_Click()
    mnuFileSaveAll_Click
    End

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()
Dim i As Integer
If Mid(Screen.ActiveForm.Caption, 10, 1) < 9 And Mid(Screen.ActiveForm.Caption, 10, 1) > 0 And Screen.ActiveForm.Caption <> "Project1" Then
 While TextChanged(Mid(fMainForm.ActiveForm.Caption, 10, 1))
  
  If Mid(Screen.ActiveForm.Caption, 10, 1) < 9 And Mid(Screen.ActiveForm.Caption, 10, 1) > 0 Then
     If InStr(Screen.ActiveForm.Caption, "Document") = 1 Then
        mnuFileSaveAs_Click
        Unload Screen.ActiveForm
        Exit Sub
     Else
        End
     End If
  Else
    Exit Sub
  End If
  If Screen.ActiveForm.Caption = "Project1" Then
    End
 
    
  End If
  
 Wend
Else
  Exit Sub
End If
 

    
End Sub





Private Sub mnuFileClose_Click()
  Dim stat As Integer
  
     If TextChanged(Mid(fMainForm.ActiveForm.Caption, 10, 1)) Then
        stat = MsgBox("保存对该文件的修改吗？", vbYesNoCancel, "保存文件")
           If stat = 6 Then
              mnuFileSaveAs_Click
           ElseIf stat = 2 Then
             Exit Sub
          
          End If
      End If
      Unload Screen.ActiveForm
End Sub




Private Sub mnuFileNew_Click()
    LoadNewDoc
End Sub