www.pudn.com > Super_richBoxall.zip > fTest.frm
VERSION 5.00
Object = "{EF59A10B-9BC4-11D3-8E24-44910FC10000}#10.0#0"; "vbalEdit.ocx"
Begin VB.Form frmRichEdit
Caption = "Form1"
ClientHeight = 5970
ClientLeft = 3885
ClientTop = 2880
ClientWidth = 12315
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "fTest.frx":0000
LinkTopic = "Form1"
ScaleHeight = 5970
ScaleWidth = 12315
Begin vbalEdit.vbalRichEdit edtMain
Height = 4995
Left = 60
TabIndex = 13
Top = 480
Width = 11595
_ExtentX = 20452
_ExtentY = 8811
Version = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = -2147483630
ViewMode = 0
AutoURLDetect = 0 'False
ScrollBars = 0
End
Begin VB.PictureBox picStatus
Align = 2 'Align Bottom
Height = 315
Left = 0
ScaleHeight = 255
ScaleWidth = 12255
TabIndex = 11
Top = 5655
Width = 12315
Begin VB.Label lblStatus
Height = 255
Left = 60
TabIndex = 12
Top = 0
Width = 12135
End
End
Begin VB.PictureBox picToolbar
Align = 1 'Align Top
BorderStyle = 0 'None
Height = 435
Left = 0
ScaleHeight = 435
ScaleWidth = 12315
TabIndex = 1
Top = 0
Width = 12315
Begin VB.CommandButton cmdFind
Caption = "&Find..."
Height = 375
Left = 60
TabIndex = 9
Top = 60
Width = 1035
End
Begin VB.CommandButton cmdTabs
Caption = "&Test Tabs"
Height = 375
Left = 1140
TabIndex = 8
Top = 60
Width = 1035
End
Begin VB.PictureBox picHighlight
BackColor = &H00FFFF80&
Height = 315
Index = 3
Left = 6945
ScaleHeight = 255
ScaleWidth = 255
TabIndex = 7
Top = 90
Width = 315
End
Begin VB.PictureBox picHighlight
BackColor = &H00FF80FF&
Height = 315
Index = 2
Left = 6585
ScaleHeight = 255
ScaleWidth = 255
TabIndex = 6
Top = 90
Width = 315
End
Begin VB.PictureBox picHighlight
BackColor = &H0080FF80&
Height = 315
Index = 1
Left = 6225
ScaleHeight = 255
ScaleWidth = 255
TabIndex = 5
Top = 90
Width = 315
End
Begin VB.PictureBox picHighlight
BackColor = &H0000FFFF&
Height = 315
Index = 0
Left = 5865
ScaleHeight = 255
ScaleWidth = 255
TabIndex = 4
Top = 90
Width = 315
End
Begin VB.ComboBox cboStyle
Height = 315
Left = 2190
Style = 2 'Dropdown List
TabIndex = 3
Top = 90
Width = 1995
End
Begin VB.CheckBox chkBackground
Caption = "&Background Bitmap"
Height = 255
Left = 7320
TabIndex = 2
Top = 120
Width = 1815
End
Begin VB.Image imgTick
Height = 480
Left = 0
Picture = "fTest.frx":014A
Top = 0
Visible = 0 'False
Width = 480
End
Begin VB.Label lblLoadStatus
Caption = "Label1"
Height = 375
Left = 4200
TabIndex = 10
Top = 105
Width = 1620
End
End
Begin VB.PictureBox picBack
AutoSize = -1 'True
Height = 1980
Left = 10260
Picture = "fTest.frx":0454
ScaleHeight = 1920
ScaleWidth = 1920
TabIndex = 0
Top = 3780
Visible = 0 'False
Width = 1980
End
Begin VB.Menu mnuFileTOP
Caption = "&File"
Begin VB.Menu mnuFile
Caption = "&New"
Index = 0
Shortcut = ^N
End
Begin VB.Menu mnuFile
Caption = "&Open..."
Index = 1
Shortcut = ^O
End
Begin VB.Menu mnuFile
Caption = "&Save"
Index = 2
Shortcut = ^S
End
Begin VB.Menu mnuFile
Caption = "Save &As..."
Index = 3
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 4
End
Begin VB.Menu mnuFile
Caption = "&Print"
Index = 5
Shortcut = ^P
End
Begin VB.Menu mnuFile
Caption = "Print Pre&view"
Index = 6
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 7
End
Begin VB.Menu mnuFile
Caption = "E&xit"
Index = 8
End
End
Begin VB.Menu mnuEditTOP
Caption = "&Edit"
Begin VB.Menu mnuEdit
Caption = "&Undo"
Index = 0
Shortcut = ^Z
End
Begin VB.Menu mnuEdit
Caption = "&Redo"
Index = 1
Shortcut = ^Y
End
Begin VB.Menu mnuEdit
Caption = "-"
Index = 2
End
Begin VB.Menu mnuEdit
Caption = "Cu&t"
Index = 3
Shortcut = ^X
End
Begin VB.Menu mnuEdit
Caption = "&Copy"
Index = 4
Shortcut = ^C
End
Begin VB.Menu mnuEdit
Caption = "&Paste"
Index = 5
Shortcut = ^V
End
Begin VB.Menu mnuEdit
Caption = "&Clear"
Index = 6
Shortcut = {DEL}
End
Begin VB.Menu mnuEdit
Caption = "-"
Index = 7
End
Begin VB.Menu mnuEdit
Caption = "Select &All"
Index = 8
End
Begin VB.Menu mnuEdit
Caption = "-"
Index = 9
End
Begin VB.Menu mnuEdit
Caption = "&Find..."
Index = 10
Shortcut = ^F
End
Begin VB.Menu mnuEdit
Caption = "Find &Next"
Index = 11
Shortcut = {F3}
End
Begin VB.Menu mnuEdit
Caption = "&Replace..."
Index = 12
Shortcut = ^H
End
End
Begin VB.Menu mnuViewTOP
Caption = "&View"
Begin VB.Menu mnuView
Caption = "&Toolbar"
Checked = -1 'True
Index = 0
End
Begin VB.Menu mnuView
Caption = "&Status Bar"
Checked = -1 'True
Index = 1
End
Begin VB.Menu mnuView
Caption = "-"
Index = 2
End
Begin VB.Menu mnuView
Caption = "&Options..."
Index = 3
End
End
Begin VB.Menu mnuFormatTOP
Caption = "&Format"
Begin VB.Menu mnuFormat
Caption = "&Font..."
Index = 0
End
Begin VB.Menu mnuFormat
Caption = "&Numbering"
Index = 1
End
Begin VB.Menu mnuFormat
Caption = "&Paragraph..."
Index = 2
End
Begin VB.Menu mnuFormat
Caption = "&Tabs..."
Index = 3
End
Begin VB.Menu mnuFormat
Caption = "&Hyperlink..."
Index = 4
End
Begin VB.Menu mnuFormat
Caption = "&Protect"
Index = 5
End
End
Begin VB.Menu mnuHelpTOP
Caption = "&Help"
Begin VB.Menu mnuHelp
Caption = "&About"
Index = 0
End
End
End
Attribute VB_Name = "frmRichEdit"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private WithEvents fFindReplace As frmFindReplace
Attribute fFindReplace.VB_VarHelpID = -1
Private m_sFileName As String
Private Function LoadDoc(ByVal sFile As String) As Boolean
Dim eType As ERECFileTypes
If sFile = "" Then
If Not VBGetOpenFileName(sFile, , , , , , "RichText Documents (*.RTF)|*.RTF|Text Documents (*.TXT)|*.TXT|All Files (*.*)|*.*", 1, , "Choose File To Open", "RTF", Me.hWnd) Then
Exit Function
End If
End If
If pbDetectFileType(sFile, eType) Then
If edtMain.LoadFromFile(sFile, eType) Then
edtMain.Modified = False
m_sFileName = sFile
LoadDoc = True
End If
End If
End Function
Private Function SaveDoc(ByVal sFile As String) As Boolean
Dim eType As ERECFileTypes
If sFile = "" Then
If Not VBGetSaveFileName(sFile, , , "RichText Documents (*.RTF)|*.RTF|Text Documents (*.TXT)|*.TXT|All Files (*.*)|*.*", 1, , "Choose File To Save As", "RTF", Me.hWnd) Then
Exit Function
End If
End If
If Not (sFile = "") Then
eType = SF_TEXT
If Right$(UCase$(sFile), 3) = "RTF" Then
eType = SF_RTF
End If
If edtMain.SaveToFile(sFile, eType) Then
m_sFileName = sFile
edtMain.Modified = False
SaveDoc = True
End If
End If
End Function
Private Function pbDetectFileType(ByVal sFile As String, ByRef eType As ERECFileTypes) As Boolean
Dim iFile As Integer
Dim sRtfID As String
On Error GoTo ErrorHandler
iFile = FreeFile
Open sFile For Binary Access Read Lock Write As #iFile
sRtfID = Space$(10)
Get #iFile, , sRtfID
Close #iFile
iFile = 0
If edtMain.IsRtf(sRtfID) Then
eType = SF_RTF
Else
eType = SF_TEXT
End If
pbDetectFileType = True
Exit Function
ErrorHandler:
MsgBox "Error! " & Err.Description & " [" & Err.Number & "]", vbExclamation
If iFile <> 0 Then
Close #iFile
End If
Exit Function
End Function
Private Function DirtyFlagCleared() As Boolean
Dim eR As VbMsgBoxResult
If edtMain.Modified Then
eR = MsgBox("Do you want to save changes to this document?", vbYesNoCancel Or vbQuestion)
Select Case eR
Case vbNo
DirtyFlagCleared = True
Case vbCancel
'
Case vbYes
If SaveDoc(m_sFileName) Then
DirtyFlagCleared = True
End If
End Select
Else
DirtyFlagCleared = True
End If
End Function
Private Sub cboStyle_Click()
edtMain.ViewMode = cboStyle.ListIndex
End Sub
Private Sub chkBackground_Click()
Dim sPic As StdPicture
If chkBackground.Value = Checked Then
Set edtMain.Picture = picBack.Picture 'sPic
Else
Set edtMain.Picture = Nothing
End If
edtMain.Transparent = (chkBackground.Value = Checked)
End Sub
Private Sub cmdFind_Click()
fFindReplace.Show , Me
End Sub
Private Sub cmdTabs_Click()
Dim lTabs() As Long
Dim iCount As Integer
Dim i As Integer
iCount = 4
ReDim lTabs(1 To 4) As Long
For i = 1 To 4
lTabs(i) = 1440 * i
Next i
edtMain.SetParagraphTabs iCount, lTabs()
iCount = 0
Erase lTabs
edtMain.GetParagraphTabs iCount, lTabs()
For i = 1 To iCount
Debug.Print lTabs(i)
Next i
End Sub
Private Sub edtMain_Change()
Debug.Print "Change"
End Sub
Private Sub edtMain_LinkOver(ByVal iType As ERECLinkEventTypeCOnstants, ByVal lMin As Long, ByVal lMax As Long)
If (iType = ercLButtonUp) Then
MsgBox "Use ShellEx to run this shortcut: " & edtMain.TextInRange(lMin, lMax), vbInformation
Else
lblStatus.Caption = "LinkOver: " & edtMain.TextInRange(lMin, lMax)
End If
End Sub
Private Sub edtMain_ModifyProtected(bDoIt As Boolean, ByVal lMin As Long, ByVal lMax As Long)
If vbYes = (MsgBox("Are you sure you want to edit this modified text?", vbYesNo Or vbQuestion)) Then
bDoIt = True
End If
End Sub
Private Sub edtMain_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Debug.Print "MouseDown ", Button, Shift, x, y
End Sub
Private Sub edtMain_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Debug.Print "MouseUp ", Button, Shift, x, y
End Sub
Private Sub edtMain_ProgressStatus(ByVal lAmount As Long, ByVal lTotal As Long)
Dim sType As String
Select Case edtMain.ProgressType
Case ercLoad
sType = "Load"
Case ercSave
sType = "Save"
Case ercPrint
sType = "Print"
End Select
lblLoadStatus.Caption = sType & ": " & lAmount & " of " & lTotal
lblLoadStatus.Refresh
End Sub
Private Sub edtMain_SelectionChange(ByVal lMin As Long, ByVal lMax As Long, ByVal eSelType As vbalEdit.ERECSelectionTypeConstants)
Select Case eSelType
Case SEL_TEXT
lblStatus.Caption = "selection: " & lMax - lMin & " Chars (" & lMin & ")"
Case SEL_EMPTY
lblStatus.Caption = "Char: " & lMin
Case Else
lblStatus.Caption = "Char: " & lMin
End Select
lblStatus.Caption = lblStatus.Caption & " Line " & edtMain.LineForCharacter(lMin) & " of " & edtMain.LineCount
Select Case edtMain.FontBackColour
Case picHighlight(0).BackColor
Set imgTick.Container = picHighlight(0)
imgTick.Visible = True
Case picHighlight(1).BackColor
Set imgTick.Container = picHighlight(1)
imgTick.Visible = True
Case picHighlight(2).BackColor
Set imgTick.Container = picHighlight(2)
imgTick.Visible = True
Case picHighlight(3).BackColor
Set imgTick.Container = picHighlight(3)
imgTick.Visible = True
Case Else
imgTick.Visible = False
End Select
If (imgTick.Visible) Then
imgTick.Move 0, 0
End If
If (Right$(Me.Caption, 1) <> "*") Then
If (edtMain.Modified) Then
Me.Caption = Me.Caption & " (Modifed) *"
End If
End If
End Sub
Private Sub fFindReplace_DoFind(ByVal sWhat As String, ByVal eOptions As vbalEdit.ERECFindTypeOptions, ByVal bFindNext As Boolean, ByVal bSelection As Boolean)
Dim lMin As Long
Dim lMax As Long
Dim lPos As Long
lPos = edtMain.FindText(sWhat, eOptions, bFindNext, bSelection, lMin, lMax)
If (lPos > 0) Then
edtMain.SetSelection lMin, lMax
fFindReplace.AddFindHistory sWhat
Else
MsgBox "Finished searching document.", vbInformation
End If
End Sub
Private Sub fFindReplace_DoReplace(ByVal sWhat As String, ByVal sWith As String, ByVal eOptions As vbalEdit.ERECFindTypeOptions, ByVal bFindNext As Boolean, ByVal bSelection As Boolean, ByVal bReplaceAll As Boolean)
Dim lMin As Long
Dim lMax As Long
Dim lPos As Long
If Not (bReplaceAll) Then
lPos = edtMain.FindText(sWhat, eOptions, bFindNext, bSelection, lMin, lMax)
If (lPos > 0) Then
edtMain.SetSelection lMin, lMax
edtMain.InsertContents SF_TEXT, sWith
fFindReplace.AddFindHistory sWhat
Else
MsgBox "Finished searching document.", vbInformation
End If
End If
End Sub
Private Sub Form_Load()
' Disable short cut keys we have set up
' in the menu to prevent them being called
' twice (once by the control, then by the
' menu!)
With edtMain
.AllowShortCut(ercCopy_CtrlC) = False
.AllowShortCut(ercCut_CtrlX) = False
.AllowShortCut(ercPaste_CtrlV) = False
.AllowShortCut(ercSelectAll_CtrlA) = False
.AllowShortCut(ercUndo_CtrlZ) = False
.AllowShortCut(ercRedo_CtrlY) = False
.AllowShortCut(ercPrint_CtrlP) = False
.AllowShortCut(ercNew_CtrlN) = False
End With
Set fFindReplace = New frmFindReplace
fFindReplace.Mode = efrFind
Me.Show
Me.Refresh
' Load a sample doc
edtMain.MaxLength = &H7FFFFFFF
edtMain.AutoURLDetect = True
LoadDoc App.Path & "\toptips.rtf"
Me.Caption = "Editing " & App.Path & "\toptips.rtf"
' styles:
cboStyle.AddItem "Default (no wrap)"
cboStyle.AddItem "Wrap to Window"
cboStyle.AddItem "WYSIWYG"
cboStyle.ListIndex = edtMain.ViewMode
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If Not (UnloadMode = vbAppTaskManager Or UnloadMode = vbAppWindows) Then
If Not DirtyFlagCleared() Then
Cancel = True
End If
End If
Unload fFindReplace
End Sub
Private Sub Form_Resize()
Dim lT As Long
Dim lH As Long
On Error Resume Next
lT = picToolbar.Height * picToolbar.Visible * -1
lH = Me.ScaleHeight - lT - picStatus.Height * picStatus.Visible * -1
edtMain.Move Screen.TwipsPerPixelX, lT, Me.ScaleWidth - 2 * Screen.TwipsPerPixelX, lH
End Sub
Private Sub imgTick_Click()
' send on to pic:
picHighlight_Click imgTick.Container.Index
End Sub
Private Sub mnuEdit_Click(Index As Integer)
Select Case Index
Case 0
edtMain.Undo
Case 1
edtMain.Redo
Case 3
edtMain.Cut
Case 4
edtMain.Copy
Case 5
edtMain.Paste
Case 6
edtMain.Delete
Case 8
edtMain.SelectAll
Case 10
fFindReplace.Mode = efrFind
fFindReplace.Show , Me
Case 11
'
Case 12
fFindReplace.Mode = efrReplace
fFindReplace.Show , Me
End Select
End Sub
Private Sub mnuEditTOP_Click()
Dim bCanUndo As Boolean
' Undo/Redo options:
bCanUndo = edtMain.CanUndo
mnuEdit(0).Enabled = bCanUndo
' Note: Bug in VB.
' Changing the caption of an item with an accelerator here causes
' the accelerator to draw at the left of the menu
If (bCanUndo) Then
mnuEdit(0).Caption = "&Undo " & TranslateUndoType(edtMain.UndoType)
Else
mnuEdit(0).Caption = "&Undo"
End If
If (edtMain.UseVersion = eRICHED20) Then
bCanUndo = edtMain.CanRedo
If (bCanUndo) Then
mnuEdit(1).Caption = "&Undo " & TranslateUndoType(edtMain.RedoType)
Else
mnuEdit(1).Caption = "&Undo"
End If
End If
mnuEdit(1).Enabled = bCanUndo
' Cut/Copy/Paste/Clear options
mnuEdit(3).Enabled = (edtMain.CanCopy And Not (edtMain.ReadOnly))
mnuEdit(4).Enabled = edtMain.CanCopy
mnuEdit(5).Enabled = edtMain.CanPaste
mnuEdit(6).Enabled = mnuEdit(3).Enabled
End Sub
Private Function TranslateUndoType(ByVal eType As ERECUndoTypeConstants) As String
Select Case eType
Case ercUID_UNKNOWN
TranslateUndoType = "Last Action"
Case ercUID_TYPING
TranslateUndoType = "Typing"
Case ercUID_PASTE
TranslateUndoType = "Paste"
Case ercUID_DRAGDROP
TranslateUndoType = "Drag Drop"
Case ercUID_DELETE
TranslateUndoType = "Delete"
Case ercUID_CUT
TranslateUndoType = "Cut"
End Select
End Function
Private Sub mnuFile_Click(Index As Integer)
Select Case Index
Case 0
' New
If DirtyFlagCleared() Then
edtMain.Contents(SF_TEXT) = ""
edtMain.Modified = False
Me.Caption = "New Document"
End If
Case 1
' Open
If DirtyFlagCleared() Then
LoadDoc ""
End If
Case 2
' Save
SaveDoc m_sFileName
Case 3
' Save As
SaveDoc ""
Case 5
' Print
edtMain.PrintDoc "Test"
Case 6
' Print Preview
MsgBox "To be completed: See the forthcoming RichEdit Print Preview Control from vbAccelerator.com !", vbInformation
Case 8
' Exit
Unload Me
End Select
End Sub
Private Sub mnuFormat_Click(Index As Integer)
Dim bS As Boolean
Dim lColour As Long
Select Case Index
Case 0
' Font:
Dim sFnt As New StdFont
Set sFnt = edtMain.Font
lColour = edtMain.FontColour
If VBChooseFont(sFnt, , Me.hWnd, lColour, 8, 72, CF_ScreenFonts Or CF_EFFECTS) Then
Set edtMain.Font = sFnt
edtMain.FontColour = lColour
End If
Case 1
' Paragraph numbering. Note there are more numbering styles
' available in RichEdit 3.0
bS = Not (mnuFormat(1).Checked)
mnuFormat(1).Checked = bS
If (bS) Then
edtMain.ParagraphNumbering = ercParaBullet
Else
edtMain.ParagraphNumbering = ercParaNone
End If
Case 2
' Paragraph settings:
Dim fP As New frmParagraph
fP.RichEdit = edtMain
fP.Show vbModal, Me
Case 3
' Tab settings:
Dim iCount As Integer
Dim lTabs() As Long
Dim i As Long
edtMain.GetParagraphTabs iCount, lTabs()
Dim fT As New frmTabs
For i = 1 To iCount
fT.AddTab lTabs(i)
Next i
fT.Show vbModal, Me
If Not (fT.Cancelled) Then
iCount = fT.TabCount
If (iCount > 0) Then
ReDim lTabs(1 To iCount) As Long
For i = 1 To iCount
lTabs(i) = fT.TabWidth(i)
Next i
End If
edtMain.SetParagraphTabs iCount, lTabs()
End If
Case 4
' Hyperlink:
edtMain.FontLink = True
Case 5
bS = Not (mnuFormat(5).Checked)
mnuFormat(5).Checked = bS
' Just so you can see it:
edtMain.FontColour = &H669999
' Set the protection
edtMain.FontProtected = bS
End Select
End Sub
Private Sub mnuFormatTOP_Click()
If (edtMain.ParagraphNumbering = ercParaBullet) Then
mnuFormat(1).Checked = True
Else
mnuFormat(1).Checked = False
End If
End Sub
Private Sub mnuView_Click(Index As Integer)
Dim bS As Boolean
Select Case Index
Case 0
bS = Not (mnuView(Index).Checked)
mnuView(Index).Checked = bS
picToolbar.Visible = bS
Form_Resize
Case 1
bS = Not (mnuView(Index).Checked)
mnuView(Index).Checked = bS
picStatus.Visible = bS
Form_Resize
Case 3
MsgBox "Show Options Dialog Here.", vbInformation
End Select
End Sub
Private Sub picHighlight_Click(Index As Integer)
Dim lS As Long, lE As Long
If (imgTick.Container Is picHighlight(Index)) Then
If edtMain.FontBackColour = picHighlight(Index).BackColor Then
edtMain.FontBackColour = -1
imgTick.Visible = False
Exit Sub
End If
End If
edtMain.FontBackColour = picHighlight(Index).BackColor
edtMain.GetSelection lS, lE
edtMain_SelectionChange lS, lE, SEL_TEXT
edtMain.SetFocus
End Sub