7-1.frm

vb6.0编程实例详解,很详细的介绍,对学习VB有帮助

    
    CommonDialog1.Flags = cdlCFBoth '必须设置该资源
    '显示字体选择对话窗口
    CommonDialog1.ShowFont
    
    If Len(CommonDialog1.FontName) < 1 Then
        '没有选择字体
        Exit Sub
    End If
    
    '修改当前字体即字体风格
    RichTextBox1.SelFontName = CommonDialog1.FontName
    RichTextBox1.SelFontSize = CommonDialog1.FontSize
    RichTextBox1.SelBold = CommonDialog1.FontBold
    RichTextBox1.SelItalic = CommonDialog1.FontItalic
    RichTextBox1.SelStrikeThru = CommonDialog1.FontStrikethru
    RichTextBox1.SelUnderline = CommonDialog1.FontUnderline
    
Errstr:
End Sub

Private Sub Form_Load()
    RichTextBox1.OLEDropMode = rtfOLEDropManual
    RichTextBox1.AutoVerbMenu = False
    RichTextBox1.Text = ""
    
    '设置缺省字体
    RichTextBox1.SelFontName = "宋体"
    RichTextBox1.SelFontSize = 10.5
    RichTextBox1.SelBold = False
    RichTextBox1.SelItalic = False
    RichTextBox1.SelStrikeThru = False
    RichTextBox1.SelUnderline = False
    
    Cut.Enabled = False
    Copy.Enabled = False
    
    Toolbar1.Buttons("Cut").Enabled = False
    Toolbar1.Buttons("Copy").Enabled = False
    
    Cut_p.Enabled = False
    Copy_p.Enabled = False
    
    If Clipboard.GetFormat(vbCFText) Then
        Paste.Enabled = True
        Paste_p.Enabled = True
        Toolbar1.Buttons("Paste").Enabled = True
    Else
        Paste.Enabled = False
        Paste_p.Enabled = False
        Toolbar1.Buttons("Paste").Enabled = False
    End If
    
    '禁止“找下一个...”操作
    FindN.Enabled = False
    
    Caption = "Edit"
    
    TextChanged = False
    
    '从注册表中读取窗体大小
    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)
    
    '从注册表中读取最近打开的文件
    GetRecentFiles
End Sub

Private Sub Form_Resize()
    '修改文本框尺寸
    RichTextBox1.Top = Toolbar1.Top + Toolbar1.Height
    RichTextBox1.Left = Me.ScaleLeft
    RichTextBox1.Width = Me.ScaleWidth
    RichTextBox1.Height = Me.ScaleHeight - RichTextBox1.Top
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If Me.WindowState <> vbMinimized And Me.WindowState <> vbMaximized 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 Ita_Click()
    If Ita.Checked Then
        Ita.Checked = False
        RichTextBox1.SelItalic = False
    Else
        Ita.Checked = True
        RichTextBox1.SelItalic = True
    End If
    
End Sub

Private Sub New_Click()
    '初始化字体
    RichTextBox1.Text = ""
    RichTextBox1.SelFontName = "宋体"
    RichTextBox1.SelFontSize = 10.5
    RichTextBox1.SelBold = False
    RichTextBox1.SelItalic = False
    RichTextBox1.SelStrikeThru = False
    RichTextBox1.SelUnderline = False
    
    '清文件修改标志
    TextChanged = False
    Caption = "Edit"
End Sub

Private Sub Open_Click()
    Dim stat As Integer
    
    If TextChanged Then
        stat = MsgBox("文件已被修改，是否保存 ？", vbYesNo Or vbQuestion, "警告")
    End If
    
    If stat = 6 Then
    '用户选择保存文件
        Save_Click
    End If
    
    '清文件修改标志
    TextChanged = False
    Caption = "Edit"
    
    '设置文件类型过滤器
    CommonDialog1.Filter = "RTF文件 (*.RTF)|*.RTF" _
                & "|文本文件 （*.TXT）|*.txt"
    CommonDialog1.FileName = ""
    CommonDialog1.FilterIndex = 0
    
    '显示打开对话窗口
    CommonDialog1.ShowOpen
    
    '如果没有文件名则返回
    If Len(CommonDialog1.FileName) = 0 Then
        Exit Sub
    End If
    
    '保存文件名
    FileName = CommonDialog1.FileName
    
    OpenFile '打开文件
    
    WriteRecentFiles (FileName) '修改注册表
    GetRecentFiles '修改“文件”菜单显示
End Sub

Private Sub Paste_Click()
    '粘贴字符串
    RichTextBox1.SelRTF = Clipboard.GetText
End Sub

Private Sub Paste_p_Click()
    Paste_Click
End Sub

Private Sub Print_Click()
    '设置打印标志
    CommonDialog1.Flags = cdlPDReturnDC + cdlPDNoPageNums
    
    If RichTextBox1.SelLength = 0 Then
        '打印所有文本
        CommonDialog1.Flags = CommonDialog1.Flags + cdlPDAllPages
    Else
        '打印选择的文本
        CommonDialog1.Flags = CommonDialog1.Flags + cdlPDSelection
    End If
    
    On Error GoTo Errstr
    CommonDialog1.CancelError = True
    
    '显示打印窗口
    CommonDialog1.ShowPrinter
    '初始化打印设备环境
    Printer.Print " "
    
    '开始打印
    RichTextBox1.SelPrint Printer.hDC
    
Errstr:

End Sub

Private Sub Recent_Click(Index As Integer)
    FileName = Recent(Index).Caption '取文件名
    OpenFile '打开文件
End Sub

Private Sub RichTextBox1_Change()
    If Not TextChanged Then
        TextChanged = True
        Caption = "Edit - （已编辑）"
    End If
End Sub

Private Sub RichTextBox1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
    '当按鼠标右键时，Button = 2
        PopupMenu Edit_p, vbPopupMenuRightButton
    End If
End Sub

Private Sub RichTextBox1_OLEDragDrop(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Data.GetFormat(vbCFRTF) Then
        'OLE数据是RTF文本
        RichTextBox1.SelRTF = Data.GetData(vbCFRTF)
        Exit Sub
    End If

    If Data.GetFormat(vbCFText) Then
        'OLE数据是普通文本
        RichTextBox1.SelText = Data.GetData(vbCFText)
        Exit Sub
    End If
    
    If Data.GetFormat(vbCFFiles) Then
        'OLE数据是文件名
        Call New_Click
        RichTextBox1.LoadFile Data.Files(1)
    End If
End Sub

Private Sub RichTextBox1_SelChange()
    '当光标移动后，修改格式菜单显示
    
    If RichTextBox1.SelBold Then
        '如果等于True（真）
        Bord.Checked = True
    Else
        '如果等于False（假）或Null（空）
        Bord.Checked = False
    End If
    
    If RichTextBox1.SelBold Then
        Ita.Checked = True
    Else
        Ita.Checked = False
    End If
    
    If RichTextBox1.SelBold Then
        Del.Checked = True
    Else
        Del.Checked = False
    End If
    
    If RichTextBox1.SelBold Then
        Und.Checked = True
    Else
        Und.Checked = False
    End If

    '修改查找位置
    FindPos = RichTextBox1.SelStart

    '修改编辑菜单显示
    If Len(RichTextBox1.SelText) > 0 Then
    '如果选择了文本
        Cut.Enabled = True '菜单项
        Copy.Enabled = True
        
        Cut_p.Enabled = True '弹出菜单
        Copy_p.Enabled = True
        
        Toolbar1.Buttons("Cut").Enabled = True '工具条
        Toolbar1.Buttons("Copy").Enabled = True
        
        FindStr = RichTextBox1.SelText '查找文本字符串
        FindPos = FindPos + 1 '新查找位置
        FindN.Enabled = True
    Else
        Cut.Enabled = False '菜单项
        Copy.Enabled = False
        
        Cut_p.Enabled = False '弹出菜单
        Copy_p.Enabled = False
        
        Toolbar1.Buttons("Cut").Enabled = False  '工具条
        Toolbar1.Buttons("Copy").Enabled = False
    End If
End Sub

Private Sub Save_Click()
    CommonDialog1.Filter = "RTF文件 (*.RTF)|*.RTF" _
                & "|文本文件 （*.TXT）|*.txt"
    CommonDialog1.FileName = FileName
    
    '显示保存对话窗口
    CommonDialog1.ShowSave
    
    '如果没有文件名则返回
    If Len(CommonDialog1.FileName) = 0 Then
        Exit Sub
    End If
    
    '判断文件格式
    If CommonDialog1.FilterIndex = 1 Then
        'RTF格式文件
        RichTextBox1.SaveFile CommonDialog1.FileName, rtfRTF
    Else
        '文本格式文件
        RichTextBox1.SaveFile CommonDialog1.FileName, rtfText
    End If
    
    '清文件修改标志
    TextChanged = False
    Caption = "Edit"
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Key
        Case "New"
            New_Click
        Case "Open"
            Open_Click
        Case "Save"
            Save_Click
        Case "Print"
            Print_Click
        Case "Cut"
            Cut_Click
        Case "Copy"
            Copy_Click
        Case "Paste"
            Paste_Click
    End Select
End Sub

Private Sub Und_Click()
    If Und.Checked Then
        Und.Checked = False
        RichTextBox1.SelUnderline = False
    Else
        Und.Checked = True
        RichTextBox1.SelUnderline = True
    End If
End Sub

Private Sub OpenFile()
    On Error GoTo OpenErr:
    '判断文件格式
    If InStr(1, UCase(FileName), ".RTF") > 0 Then
        'RTF格式文件
        RichTextBox1.LoadFile FileName, rtfRTF
    ElseIf InStr(1, UCase(FileName), ".TXT") > 0 Then
        '文本格式文件
        RichTextBox1.LoadFile FileName, rtfText
    End If

    '清文件修改标志
    TextChanged = False
    Caption = "Edit"
    
    Exit Sub '退出子程序
OpenErr:
'打开文件时错
    MsgBox "打开文件错 ！", vbOKOnly, "警告"
End Sub

Sub GetRecentFiles()
' 本过程演示 GetAllSettings 函数的用法，它从 Windows 注册表中返回值的数组。
' 在这种情况下，注册表包含最近打开的文件列表。使用 SaveSetting 语句记下最近使用的文件名。
' 该语句在 WriteRecentFiles 过程中使用
    Dim i As Integer
    Dim varFiles As Variant ' 存储返回的数组的变量
    
    ' 用 GetAllSettings 语句从注册表中返回最近使用的文件。
    '  ThisApp 和 ThisKey是模块中定义的常数
   
   '判断是否存有文件
    If GetSetting(App.Title, "Recent", "RecentFile1") = Empty Then Exit Sub
    
     '获得“Recent”主键中的全部键值
    varFiles = GetAllSettings(App.Title, "Recent")
    
    separate0.Visible = True '显示分割符
    
    For i = 0 To UBound(varFiles, 1)
    '显示各文件名菜单
        Recent(i).Caption = varFiles(i, 1)
        Recent(i).Visible = True
    Next i
End Sub

Sub WriteRecentFiles(OpenFileName)
' 本过程使用 SaveSettings 语句将最近打开的文件名写入系统注册表。
' SaveSettings 语句要求三个参数其中两个存储为常数并在本模块内定义。
' GetRecentFiles 过程中使用 GetAllSettings 函数来检索这个过程中存储的文件名。
    Dim i As Integer
    Dim strFile As String
    Dim strKey As String

    ' 将文件 RecentFile1 复制给 RecentFile2，等等
    For i = 3 To 1 Step -1
        strKey = "RecentFile" & i '获得键值字符串
        strFile = GetSetting(App.Title, "Recent", strKey)
        If strFile <> "" Then '有文件名
        '另存该文件名
            strKey = "RecentFile" & (i + 1)
            SaveSetting App.Title, "Recent", strKey, strFile
        End If
    Next i
  
    ' 将正在打开的文件写到最近使用文件列表的第一项
    SaveSetting App.Title, "Recent", "RecentFile1", OpenFileName
End Sub