frmmain.frm

vb编写的写字板

   End
   Begin VB.Menu 格式 
      Caption         =   "格式(&T)"
      Begin VB.Menu 左缩进 
         Caption         =   "左缩进(&l)..."
      End
      Begin VB.Menu 右缩进 
         Caption         =   "右缩进(&r)..."
      End
      Begin VB.Menu 中央缩进 
         Caption         =   "中央缩进(&s)..."
      End
      Begin VB.Menu gs2 
         Caption         =   "-"
      End
      Begin VB.Menu 上标 
         Caption         =   "上标(&T)"
      End
      Begin VB.Menu 下标 
         Caption         =   "下标(&L)"
      End
      Begin VB.Menu mnugs1 
         Caption         =   "-"
      End
      Begin VB.Menu 项目符号 
         Caption         =   "项目符号(&f)..."
      End
      Begin VB.Menu cancelpro 
         Caption         =   "取消项目符号"
      End
   End
   Begin VB.Menu mnuWindow 
      Caption         =   "窗口(&W)"
      WindowList      =   -1  'True
      Begin VB.Menu mnuWindowNewWindow 
         Caption         =   "新建窗口(&N)"
      End
      Begin VB.Menu mnuWindowBar0 
         Caption         =   "-"
      End
      Begin VB.Menu mnuWindowCascade 
         Caption         =   "层叠(&C)"
      End
      Begin VB.Menu mnuWindowTileHorizontal 
         Caption         =   "横向平铺(&H)"
      End
      Begin VB.Menu mnuWindowTileVertical 
         Caption         =   "纵向平铺(&V)"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuForHelpOn 
         Caption         =   "帮助主题(&S)..."
      End
      Begin VB.Menu mnuHelpAbout 
         Caption         =   "关于(&A) "
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const EM_UNDO = &HC7
Const EM_REDO = &HC7
Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)

Private Sub cancelpro_Click()
ActiveForm.rtfText.SelBullet = False
End Sub

Private Sub MDIForm_Load()
  savevalue = True
    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
End Sub

Private Sub save()
On Error Resume Next
dlgCommonDialog.Filter = "text files(*.txt)|*.txt|"
dlgCommonDialog.FilterIndex = 0
dlgCommonDialog.ShowSave
strfilename = dlgCommonDialog.FileName
intfilenum = FreeFile()
Open strfilename For Output As #intfilenum
Print #intfilenum, RichTextBox1.Text
Close #intfilenum
Exit Sub
savevalue = True
End Sub
Private Sub mnuanswer()
    If savevalue = False Then
       msgreturn = MsgBox("当前文件已被修改，要保存吗？", 3, "保存")
          If msgreturn = 6 Then
           Call save
           End
           End If
        If msgreturn = 7 Then
           End
         End If
   End If
     savevalue = True
End Sub

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

Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   Call mnuanswer
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 mnuForHelpOn_Click()
  Load Form2
  Form2.Show
End Sub

Private Sub tbToolBar_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    Select Case Button.Key
        Case "重复"
           重复_Click
        Case "撤消"
           撒消_Click
        Case "左缩进"
            左缩进_Click
        Case "中央缩进"
            中央缩进_Click
        Case "右缩进"
            右缩进_Click
        Case "新建"
            LoadNewDoc
        Case "打开"
            mnuFileOpen_Click
        Case "保存"
            mnuFileSave_Click
        Case "打印"
            mnuFilePrint_Click
        Case "剪切"
            mnuEditCut_Click
        Case "复制"
            mnuEditCopy_Click
        Case "粘贴"
            mnuEditPaste_Click
        Case "查找"
           mnufind_Click
        Case "粗体"
            ActiveForm.rtfText.SelBold = Not ActiveForm.rtfText.SelBold
            Button.value = IIf(ActiveForm.rtfText.SelBold, tbrPressed, tbrUnpressed)
        Case "斜体"
            ActiveForm.rtfText.SelItalic = Not ActiveForm.rtfText.SelItalic
            Button.value = IIf(ActiveForm.rtfText.SelItalic, tbrPressed, tbrUnpressed)
        Case "下划线"
            ActiveForm.rtfText.SelUnderline = Not ActiveForm.rtfText.SelUnderline
            Button.value = IIf(ActiveForm.rtfText.SelUnderline, tbrPressed, tbrUnpressed)
        Case "左对齐"
            ActiveForm.rtfText.SelAlignment = rtfLeft
        Case "置中"
            ActiveForm.rtfText.SelAlignment = rtfCenter
        Case "右对齐"
            ActiveForm.rtfText.SelAlignment = rtfRight
        Case "color"
           dlgCommonDialog.Flags = &H2
           dlgCommonDialog.ShowColor
           ActiveForm.rtfText.SelColor = dlgCommonDialog.Color
        Case "字体"
         dlgCommonDialog.Flags = &H1
         dlgCommonDialog.ShowFont
         ActiveForm.rtfText.SelFontName = dlgCommonDialog.FontName
         ActiveForm.rtfText.SelFontSize = dlgCommonDialog.FontSize
    End Select
End Sub

Private Sub mnuHelpAbout_Click()
  Load Form1
  Form1.Show
   End Sub

Private Sub mnuHelpOn_Click()
 Dim frm2 As Integer
  Load Form2
  Form2.Show
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 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()
If ActiveForm.rtfText.Text = "" Then
End
End If
   Call mnuanswer
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 mnufind_Click()
Load searchandreplace
searchandreplace.Show
End Sub

Private Sub mnuFileSaveAs_Click()
    Dim sFile As String
        If ActiveForm Is Nothing Then Exit Sub
        With dlgCommonDialog
        .DialogTitle = "另存为"
        .CancelError = False
        .Filter = "RTF 格式文档|*.rtf|TXT 文本文档|*.txt"
        .ShowSave
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    ActiveForm.Caption = sFile
    ActiveForm.rtfText.SaveFile sFile

End Sub

Private Sub mnuFileSave_Click()
    Dim sFile As String
    If Left$(ActiveForm.Caption, 8) = "Document" Then
        With dlgCommonDialog
            .DialogTitle = "保存"
            .CancelError = False
            .Filter = "RTF 格式文档|*.rtf|TXT 文本文档|*.txt"
            .ShowSave
            If Len(.FileName) = 0 Then
                Exit Sub
            End If
            sFile = .FileName
        End With
        ActiveForm.rtfText.SaveFile sFile
        savevalue = True
    Else
        sFile = ActiveForm.Caption
        ActiveForm.rtfText.SaveFile sFile
    End If
End Sub

Private Sub mnuFileClose_Click()
    Call mnuanswer
End Sub

Private Sub mnuFileOpen_Click()
    Dim sFile As String
    If ActiveForm Is Nothing Then LoadNewDoc
        With dlgCommonDialog
        .DialogTitle = "打开"
        .CancelError = False
        .Filter = "RTF 格式文档|*.rtf|TXT 文本文档|*.txt|"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    ActiveForm.rtfText.LoadFile sFile
    ActiveForm.Caption = sFile
End Sub

Private Sub mnuFileNew_Click()
    LoadNewDoc
End Sub

Private Sub 撒消_Click()
Dim x
  Me.ActiveForm.rtfText.SetFocus
  x = SendMessage(Me.ActiveForm.rtfText.hwnd, EM_UNDO, 0, 0)
End Sub

Private Sub 上标_Click()
Me.ActiveForm.rtfText.SelCharOffset = 80
End Sub

Private Sub 下标_Click()
Me.ActiveForm.rtfText.SelCharOffset = -10
End Sub

Private Sub 项目符号_Click()
ActiveForm.ScaleMode = 6
ActiveForm.rtfText.BulletIndent = 0.5
ActiveForm.rtfText.SelBullet = True
End Sub

Private Sub 右缩进_Click()
ActiveForm.ScaleMode = 6
i = InputBox("请输入要缩进的值", "右缩进")
ActiveForm.rtfText.SelRightIndent = i
End Sub

Private Sub 中央缩进_Click()
ActiveForm.ScaleMode = 6
h = InputBox("请输入要缩进的值", "中央缩进")
ActiveForm.rtfText.SelHangingIndent = h
End Sub

Private Sub 重复_Click()
 Dim y
     Me.ActiveForm.rtfText.SetFocus
      y = SendMessage(Me.ActiveForm.rtfText.hwnd, EM_REDO, 0, 0)
End Sub

Private Sub 左缩进_Click()
ActiveForm.ScaleMode = 6
l = InputBox("请输入要缩进的值", "左缩进")
ActiveForm.rtfText.SelIndent = l
End Sub