vbAccelerator - Contents of code file: VBRichEdit.ctl

VERSION 5.00
Begin VB.UserControl vbalRichEdit 
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ControlContainer=   -1  'True
   ForwardFocus    =   -1  'True
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   ToolboxBitmap   =   "VBRichEdit.ctx":0000
   Begin VB.Label lblText 
      Caption         =   "vbAccelerator RichEdit Control"
      Height          =   255
      Left            =   60
      TabIndex        =   0
      Top             =   60
      Width           =   4635
   End
End
Attribute VB_Name = "vbalRichEdit"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit


' ======================================================================
' Visit vbAccelerator at www.vbaccelerator.com
' - the VB Programmer's Resource
' ======================================================================

' ======================================================================
' vbalRichEdit
' Copyright  1998 Steve McMahon (steve@vbaccelerator.com)
' 14 June 1998
'
' A lightweight RichEdit control all in VB with lots of great features
' Requires:
'  mRichEdit.Bas
'  mWinGeneral.Bas
'  SSubTmr.DLL
'
' ---------------------------------------------------------------------------
' vbAccelerator - free, advanced source code for VB programmers.
'     http://vbaccelerator.com
' ======================================================================

' ======================================================================
' Declares and types:
' ======================================================================
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lparam As
 Long) As Long
Private Declare Function SendMessageStr Lib "user32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lparam As
 String) As Long
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
Private Declare Function SendMessageUnicode Lib "user32" Alias "SendMessageW"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lparam As Any)
 As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA"
 (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As
 String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth
 As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long,
 ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long,
 lpPoint As POINTAPI) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal
 nCmdShow As Long) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x
 As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
 bRepaint As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal
 fEnable As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal
 hWndNewParent As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const SW_HIDE = 0
Private Const WS_TABSTOP = &H10000
Private Const WS_CHILD = &H40000000
Private Const WS_HSCROLL = &H100000
Private Const WS_VSCROLL = &H200000
Private Const WS_VISIBLE = &H10000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_BORDER = &H800000
Private Const WS_EX_CLIENTEDGE = &H200
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_STYLE = (-16)
Private Const WS_POPUP = &H80000000
Private Const WS_SYSMENU = &H80000
Private Const WS_THICKFRAME = &H40000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_DLGFRAME = &H400000
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hwnd
 As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal
 lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long)
 As Long
Private Const WM_GETTEXTLENGTH = &HE
Private Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(0 To 31) As Byte
End Type
Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint
 As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As
 PAINTSTRUCT) As Long

' ======================================================================
' Enums:
' ======================================================================
Public Enum ERECControlVersion
    eRICHED32
    eRICHED20
End Enum
Public Enum ERECFileTypes
    SF_TEXT = &H1
    SF_RTF = &H2
End Enum
Public Enum ERECSetFormatRange
   ercSetFormatAll = SCF_ALL
   ercSetFormatSelection = SCF_SELECTION
   ercSetFormatWord = SCF_WORD Or SCF_SELECTION
End Enum
Public Enum ERECTextTypes
   ercTextNormal
   ercTextSuperscript
   ercTextSubscript
End Enum
Public Enum ERECViewModes
   ercDefault = 0
   ercWordWrap = 1
   ercWYSIWYG = 2
End Enum
' /*  UndoName info */
Public Enum ERECUndoTypeConstants
    ercUID_UNKNOWN = 0
    ercUID_TYPING = 1
    ercUID_DELETE = 2
    ercUID_DRAGDROP = 3
    ercUID_CUT = 4
    ercUID_PASTE = 5
End Enum
Public Enum ERECSelectionTypeConstants
   SEL_EMPTY = &H0
   SEL_TEXT = &H1
   SEL_OBJECT = &H2
   SEL_MULTICHAR = &H4
   SEL_MULTIOBJECT = &H8
End Enum
Public Enum ERECFindTypeOptions
   FR_DEFAULT = &H0
   FR_DOWN = &H1
   FR_WHOLEWORD = &H2
   FR_MATCHCASE = &H4&
End Enum
Public Enum ERECOptionTypeConstants
' /* Edit control options */
   ECO_AUTOWORDSELECTION = &H1&
   ECO_AUTOVSCROLL = &H40&
   ECO_AUTOHSCROLL = &H80&
   ECO_NOHIDESEL = &H100&
   ECO_READONLY = &H800&
   ECO_WANTRETURN = &H1000&
   ECO_SAVESEL = &H8000&
   ECO_SELECTIONBAR = &H1000000
   ECO_VERTICAL = &H400000                  ' /* FE specific */
End Enum

Public Enum ERECInbuiltShortcutConstants
   [_First] = 1
   ' Inbuilt methods
   ercCut_CtrlX = 1
   ercCopy_CtrlC = 2
   ercPaste_CtrlV = 3
   ercUndo_CtrlZ = 4
   ercSelectAll_CtrlA = 5
   
   ' Supplied methods:
   ercBold_CtrlB = 6
   ercItalic_CtrlI = 7
   ercUnderline_CtrlU = 8
   ercPrint_CtrlP = 9
   ercRedo_CtrlY = 10
   
   ercSuperscript_CtrlPlus = 11
   ercSubscript_CtrlMinus = 12
   
   ercNew_CtrlN = 13
   [_Last] = 13
End Enum

Public Enum ERECProgressTypeConstants
   ercNone = 0
   ercLoad = 1
   ercSave = 2
   ercPrint = 3
End Enum

Public Enum ERECParagraphNumberingConstants
   ercParaNone = 0
   ercParaBullet = PFN_BULLET
   ercParaArabicNumbers_NS = 2
   ercParaLowerCaseLetters_NS = 3
   ercParaUpperCaseLetters_NS = 4
   ercParaLowerCaseRoman_NS = 5
   ercParaUpperCaseRoman_NS = 6
   ercParaCustomNumber_NS = 7
End Enum

Public Enum ERECParagraphAlignmentConstants
   ercParaLeft = PFA_LEFT
   ercParaCentre = PFA_CENTER
   ercParaRight = PFA_RIGHT
   ercParaJustify = PFA_JUSTIFY
End Enum

Public Enum ERECTabAlignmentConstants
   ercTabOrdinary = 0
   ercTabCentre_NS = 1
   ercTabRight_NS = 2
   ercTabDecimal_NS = 3
   ercTabWordBarTab_NS = 4
End Enum

Public Enum ERECTabLeaderConstants
   ercTabNoLeader = 0
   ercTabDottedLeader_NS = 1
   ercTabDashedLeader_NS = 2
   ercTabUnderlinedLeader_NS = 3
   ercTabThickLineLeader_NS = 4
   ercTabDoubleLineLeader_NS = 5
End Enum

Public Enum ERECParagraphLineSpacingConstants
   ercLineSpacingSingle = 0
   ercLineSpacingOneAndAHalf = 1
   ercLineSpacingDouble = 2
   ercLineSpacingTwips = 3
   ercLineSpacingTwipsAnyMinimum = 4
   ercLineSpacingTwentiethLine = 5
End Enum

' ======================================================================
' Internal Control Variables:
' ======================================================================
Private m_hWnd As Long
Private m_bSubclassing As Boolean
Private m_hLib As Long
Private m_eVersion As ERECControlVersion
Private m_eViewMode As ERECViewModes
Private m_bRedraw As Boolean
Private m_sText As String
Private m_bAllowMethod(ERECInbuiltShortcutConstants.[_First] To
 ERECInbuiltShortcutConstants.[_Last]) As Boolean
Private m_sFileName As String
Private m_eProgressType As ERECProgressTypeConstants
Private m_sLastFindText As String
Private m_eLastFindMode As ERECFindTypeOptions
Private m_bLastFindNext As Boolean
Private m_eCharFormatRange As ERECSetFormatRange
Private m_bBorder As Boolean
Private m_lLeftMargin As Long
Private m_lRightMargin As Long
Private m_lTopMargin As Long
Private m_lBottomMargin As Long

' ======================================================================
' Events:
' ======================================================================
Public Event SelectionChange(ByVal lMin As Long, ByVal lMax As Long, ByVal
 eSelType As ERECSelectionTypeConstants)
Public Event LinkOver(ByVal iType As Integer, ByVal lMin As Long, ByVal lMax As
 Long)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event DblClick(x As Single, y As Single)
Public Event MouseDown(x As Single, y As Single, Shift As Integer)
Public Event MouseMove(x As Single, y As Single, Shift As Integer)
Public Event MouseUp(x As Single, y As Single, Shift As Integer)
Public Event ProgressStatus(ByVal lAmount As Long, ByVal lTotal As Long)
Public Event ModifyProtected(ByRef bDoIt As Boolean, ByVal lMin As Long, ByVal
 lMax As Long)
Public Event VScroll()
Public Event HScroll()

' ======================================================================
' Subclassing:
' ======================================================================
Implements ISubclass
Private m_emr As EMsgResponse

Public Property Get MaxLength() As Long
   If (m_hWnd <> 0) Then
      MaxLength = SendMessageLong(m_hWnd, EM_GETLIMITTEXT, 0, 0)
   End If
End Property
Public Property Let MaxLength(ByVal lMax As Long)
   If (m_hWnd <> 0) Then
      SendMessageLong m_hWnd, EM_EXLIMITTEXT, 0, lMax
   End If
End Property

Public Property Get Border() As Boolean
   Border = m_bBorder
End Property
Public Property Let Border(ByVal bState As Boolean)
   m_bBorder = bState
End Property

Public Property Get ProgressType() As ERECProgressTypeConstants
   ProgressType = m_eProgressType
End Property

Public Function FindText( _
      ByVal sText As String, _
      Optional ByVal eOptions As ERECFindTypeOptions = FR_DEFAULT, _
      Optional ByVal bFindNext As Boolean = True, _
      Optional ByVal bFIndInSelection As Boolean = False, _
      Optional ByRef lMin As Long, _
      Optional ByRef lMax As Long _
   ) As Long
Dim tEx1 As FINDTEXTEX_A
'Dim tEx2 As FINDTEXTEX_W
Dim tCR As CHARRANGE
Dim lR As Long
Dim lJunk As Long
Dim b() As Byte

   m_sLastFindText = sText
   m_eLastFindMode = eOptions
   m_bLastFindNext = bFindNext
   
   lMin = -1: lMax = -1
   If (bFIndInSelection) Then
      GetSelection tCR.cpMax, tCR.cpMax
   Else
      If (bFindNext) Then
         GetSelection tCR.cpMin, lJunk
         If (lJunk >= tCR.cpMin) Then
            tCR.cpMin = lJunk + 1
         End If
         tCR.cpMax = -1
      Else
         tCR.cpMin = 0
         tCR.cpMax = -1
      End If
   End If
   
   b = StrConv(sText, vbFromUnicode)
   ' VB won't do the terminating null for you!
   ReDim Preserve b(0 To UBound(b) + 1) As Byte
   b(UBound(b)) = 0
   tEx1.lpstrText = VarPtr(b(0))
   LSet tEx1.chrg = tCR
   
   lR = SendMessage(m_hWnd, EM_FINDTEXTEX, eOptions, tEx1)
   
   LSet tCR = tEx1.chrgText
   If (lR <> -1) Then
      lMax = tCR.cpMax
      lMin = lMax - Len(sText)
   End If
   FindText = lR
   
End Function
Public Property Get LastFindText() As String
   LastFindText = m_sLastFindText
End Property
Public Property Get LastFindMode() As ERECFindTypeOptions
   LastFindMode = m_eLastFindMode
End Property
Public Property Get LastFindNext() As Boolean
   LastFindNext = m_bLastFindNext
End Property

Public Property Get Font() As StdFont
   If (m_eCharFormatRange = ercSetFormatAll) Or (m_hWnd = 0) Then
      Set Font = UserControl.Font
   Else
      Dim sFnt As New StdFont
      Set Font = GetFont(True)
   End If
End Property
Public Property Set Font(ByRef sFnt As StdFont)
   With UserControl.Font
      .Name = sFnt.Name
      .Size = sFnt.Size
      .Bold = sFnt.Bold
      .Italic = sFnt.Italic
      .Underline = sFnt.Underline
      .Strikethrough = sFnt.Strikethrough
      .Charset = sFnt.Charset
   End With
   If (m_hWnd <> 0) Then
      SetFont sFnt, , , , m_eCharFormatRange
   End If
   PropertyChanged "Font"
End Property
Public Property Get BackColor() As OLE_COLOR
   BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal oColor As OLE_COLOR)
   UserControl.BackColor = oColor
   lblText.BackColor = oColor
   If (m_hWnd <> 0) Then
      SendMessageLong m_hWnd, EM_SETBKGNDCOLOR, 0, TranslateColor(oColor)
   End If
   PropertyChanged "BackColor"
End Property
Public Property Get ForeColor() As OLE_COLOR
   ForeColor = UserControl.ForeColor
End Property
Public Property Let ForeColor(ByVal oColor As OLE_COLOR)
   UserControl.ForeColor = oColor
   If (m_hWnd <> 0) Then
      SetFont UserControl.Font, TranslateColor(oColor), , , ercSetFormatAll
   End If
   PropertyChanged "ForeColor"
End Property
Public Property Get Text() As String
   If (m_hWnd = 0) Then
      Text = m_sText
      If (m_sText = "") Then
         'blText.Caption = "vbAccelerator Rich Edit Control"
      Else
         lblText.Caption = m_sText
      End If
   Else
      Text = Contents(SF_TEXT)
   End If
End Property
Public Property Let Text(ByRef sText As String)
   If (m_hWnd = 0) Then
      m_sText = sText
   Else
      Contents(SF_TEXT) = sText
   End If
End Property
Public Property Get Modified() As Boolean
   If (m_hWnd <> 0) Then
      Modified = (SendMessageLong(m_hWnd, EM_GETMODIFY, 0, 0) <> 0)
   End If
End Property
Public Property Let Modified(ByVal bModified As Boolean)
   If (m_hWnd <> 0) Then
      SendMessageLong m_hWnd, EM_SETMODIFY, Abs(bModified), 0
   End If
End Property

Public Property Get RichEditOption( _
      ByVal eOption As ERECOptionTypeConstants _
   ) As Boolean
Dim lR As Long
   lR = SendMessageLong(m_hWnd, EM_GETOPTIONS, 0, 0)
   RichEditOption = ((lR And eOption) = eOption)
End Property
Public Property Let RichEditOption( _
      ByVal eOption As ERECOptionTypeConstants, _
      ByVal bState As Boolean _
   )
Dim lOptions As Long
Dim lR As Long
   lOptions = SendMessageLong(m_hWnd, EM_GETOPTIONS, 0, 0)
   If (bState) Then
      lOptions = lOptions Or eOption
   Else
      lOptions = lOptions And Not eOption
   End If
   lR = SendMessageLong(m_hWnd, EM_SETOPTIONS, 0, lOptions)
End Property

Public Property Get LineForCharacterIndex(ByVal lIndex As Long) As Long
   LineForCharacterIndex = (SendMessageLong(m_hWnd, EM_EXLINEFROMCHAR, 0,
    lIndex))
End Property

Private Function Unsupported(Optional ByVal iType As Integer = 0)
   If UserControl.Ambient.UserMode Then
   If (iType = 0) Then
      Debug.Assert "Function not supported in eRICHED32 mode, use RICHED20" = ""
   ElseIf (iType = 1) Then
      Debug.Assert "Property is read-only at run-time" = ""
   End If
   End If
End Function

Public Property Get SelectedText() As String
Dim sBuff As String
Dim lStart As Long
Dim lEnd As Long
Dim lR As Long

   GetSelection lStart, lEnd
   If (lEnd > lStart) Then
      sBuff = String$(lEnd - lStart + 1, 0)
      lR = SendMessageStr(m_hWnd, EM_GETSELTEXT, 0, sBuff)
      If (lR > 0) Then
         SelectedText = Left$(sBuff, lR)
      End If
   End If
End Property

Public Property Get TextInRange(ByVal lStart As Long, ByVal lEnd As Long)
Dim tR As TEXTRANGE
Dim lR As Long
Dim sText As String
Dim b() As Byte
      
   tR.chrg.cpMin = lStart
   tR.chrg.cpMax = lEnd
   
   sText = String$(lEnd - lStart + 1, 0)
   b = StrConv(sText, vbFromUnicode)
   ' VB won't do the terminating null for you!
   ReDim Preserve b(0 To UBound(b) + 1) As Byte
   b(UBound(b)) = 0
   tR.lpstrText = VarPtr(b(0))

   lR = SendMessage(m_hWnd, EM_GETTEXTRANGE, 0, tR)
   If (lR > 0) Then
      sText = StrConv(b, vbUnicode)
      TextInRange = Left$(sText, lR)
   End If
End Property

Public Property Let AutoURLDetect(ByVal bState As Boolean)
Dim lR As Long
   If (m_eVersion = eRICHED20) Then
      lR = SendMessageLong(m_hWnd, EM_AUTOURLDETECT, Abs(bState), 0)
      Debug.Assert (lR = 0)
   Else
      Unsupported
   End If
End Property
Public Property Get AutoURLDetect() As Boolean
   
End Property

Public Property Let ReadOnly(ByVal bState As Boolean)
   SendMessageLong m_hWnd, EM_SETREADONLY, Abs(bState), 0
End Property
Public Property Get ReadOnly() As Boolean
Dim lStyle As Long
   If (m_hWnd <> 0) Then
      lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
      If (lStyle And ES_READONLY) = ES_READONLY Then
         ReadOnly = True
      End If
   End If
End Property

Public Property Get LineCount() As Long
   LineCount = SendMessageLong(m_hWnd, EM_GETLINECOUNT, 0, 0)
End Property

Public Property Get FirstVisibleLine() As Long
   FirstVisibleLine = SendMessageLong(m_hWnd, EM_GETFIRSTVISIBLELINE, 0, 0)
End Property
Public Property Get CurrentLine() As Long
Dim lStart As Long, lEnd As Long
   GetSelection lStart, lEnd
   ' Use EX to ensure we can cope with > 32k text
   CurrentLine = SendMessageLong(m_hWnd, EM_EXLINEFROMCHAR, 0, lStart)
End Property

Public Property Get LineForCharacter(ByVal lCharacter As Long)
   ' Use EX to ensure we can cope with > 32k text
   LineForCharacter = SendMessageLong(m_hWnd, EM_EXLINEFROMCHAR, lCharacter, 0)
End Property

Public Property Get CharFromPos(ByVal xPixels As Long, ByVal yPixels As Long)
Dim tP As POINTAPI
   tP.x = xPixels
   tP.y = yPixels
   CharFromPos = SendMessage(m_hWnd, EM_CHARFROMPOS, 0, tP)
End Property

Public Sub GetPosFromChar(ByVal lIndex As Long, ByRef xPixels As Long, ByRef
 yPixels As Long)
Dim lxy As Long
   lxy = SendMessageLong(m_hWnd, EM_POSFROMCHAR, lIndex, 0)
   xPixels = (lxy And &HFFFF&)
   yPixels = (lxy \ &H10000) And &HFFFF&
End Sub

Public Sub GetSelection(ByRef lStart As Long, ByRef lEnd As Long)
Dim tCR As CHARRANGE
   SendMessage m_hWnd, EM_EXGETSEL, 0, tCR
   lStart = tCR.cpMin
   lEnd = tCR.cpMax
End Sub

Public Sub SetSelection(ByVal lStart As Long, ByVal lEnd As Long)
Dim tCR As CHARRANGE
   tCR.cpMin = lStart
   tCR.cpMax = lEnd
   SendMessage m_hWnd, EM_EXSETSEL, 0, tCR
End Sub
Public Sub SelectAll()
   SetSelection 0, -1
End Sub

Public Property Get CanPaste() As Boolean
   CanPaste = SendMessageLong(m_hWnd, EM_CANPASTE, 0, 0)
End Property
Public Property Get CanCopy() As Boolean
Dim lStart As Long, lEnd As Long
   GetSelection lStart, lEnd
   If (lEnd > lStart) Then
      CanCopy = True
   End If
End Property
Public Property Get CanUndo() As Boolean
   CanUndo = SendMessageLong(m_hWnd, EM_CANUNDO, 0, 0)
End Property
Public Property Get CanRedo() As Boolean
   If m_eVersion = eRICHED20 Then
      CanRedo = SendMessageLong(m_hWnd, EM_CANREDO, 0, 0)
   Else
      Unsupported
   End If
End Property
Public Property Get UndoType() As ERECUndoTypeConstants
   If m_eVersion = eRICHED20 Then
      UndoType = SendMessageLong(m_hWnd, EM_GETUNDONAME, 0, 0)
   Else
      Unsupported
   End If
End Property
Public Property Get RedoType() As ERECUndoTypeConstants
   If m_eVersion = eRICHED20 Then
      RedoType = SendMessageLong(m_hWnd, EM_GETREDONAME, 0, 0)
   Else
      Unsupported
   End If
End Property
Public Sub Cut()
   SendMessageLong m_hWnd, WM_CUT, 0, 0
End Sub
Public Sub Copy()
   SendMessageLong m_hWnd, WM_COPY, 0, 0
End Sub
Public Sub Paste()
   SendMessageLong m_hWnd, WM_PASTE, 0, 0
End Sub
Public Sub PasteSpecial()
   SendMessageLong m_hWnd, EM_PASTESPECIAL, 0, 0
End Sub
Public Sub Undo()
   SendMessageLong m_hWnd, EM_UNDO, 0, 0
End Sub
Public Sub Redo()
   If (m_eVersion = eRICHED20) Then
      SendMessageLong m_hWnd, EM_REDO, 0, 0
   Else
      Unsupported
   End If
End Sub
Public Sub Delete()
   ' TODO
End Sub

Public Sub InsertContents(ByVal eType As ERECFileTypes, ByRef sText As String)
Dim tStream As EDITSTREAM
Dim lR As Long
   ' Insert the text:
   tStream.dwCookie = m_hWnd
   tStream.pfnCallback = plAddressOf(AddressOf LoadCallBack)
   tStream.dwError = 0
   StreamText = sText
   ' The text will be streamed in though the LoadCallback function:
   lR = SendMessage(m_hWnd, EM_STREAMIN, eType Or SFF_SELECTION, tStream)
   
End Sub

Public Property Get ViewMode() As ERECViewModes
   ViewMode = m_eViewMode
End Property

Public Property Let ViewMode(ByVal eViewMode As ERECViewModes)
   If (eViewMode <> m_eViewMode) Then
      m_eViewMode = eViewMode
      Select Case m_eViewMode
      Case ercWYSIWYG
         ' todo...
         SendMessageLong m_hWnd, EM_SETTARGETDEVICE, Printer.hdc, Printer.Width
      Case ercWordWrap
         SendMessageLong m_hWnd, EM_SETTARGETDEVICE, 0, 0
      Case ercDefault
         SendMessageLong m_hWnd, EM_SETTARGETDEVICE, 0, 1
      End Select
   End If
End Property

Public Property Get CharFormatRange() As ERECSetFormatRange
   CharFormatRange = m_eCharFormatRange
End Property
Public Property Let CharFormatRange(ByVal eRange As ERECSetFormatRange)
   m_eCharFormatRange = eRange
End Property
Public Property Get FontBold() As Boolean
' Attribute FontBold.VB_MemberFlags = "400"
Dim tCF As CHARFORMAT
Dim lR As Long
   tCF.dwMask = CFM_BOLD
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, m_eCharFormatRange, tCF)
   FontBold = ((tCF.dwEffects And CFE_BOLD) = CFE_BOLD)
End Property
Public Property Let FontBold(ByVal bBold As Boolean)
Dim tCF As CHARFORMAT
Dim lR As Long
   tCF.dwMask = CFM_BOLD
   If (bBold) Then
      tCF.dwEffects = CFE_BOLD
   End If
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, m_eCharFormatRange, tCF)
End Property
Public Property Get FontItalic() As Boolean
' Attribute FontItalic.VB_MemberFlags = "400"
Dim tCF As CHARFORMAT
Dim lR As Long
   tCF.dwMask = CFM_ITALIC
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, m_eCharFormatRange, tCF)
   FontItalic = ((tCF.dwEffects And CFE_ITALIC) = CFE_ITALIC)
End Property
Public Property Let FontItalic(ByVal bItalic As Boolean)
Dim tCF As CHARFORMAT
Dim lR As Long
   tCF.dwMask = CFM_ITALIC
   If (bItalic) Then
      tCF.dwEffects = CFE_ITALIC
   End If
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, m_eCharFormatRange, tCF)
End Property
Public Property Get FontUnderline() As Boolean
' Attribute FontUnderline.VB_MemberFlags = "400"
Dim tCF As CHARFORMAT
Dim lR As Long
   tCF.dwMask = CFM_UNDERLINE
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, m_eCharFormatRange, tCF)
   FontUnderline = ((tCF.dwEffects And CFE_UNDERLINE) = CFE_UNDERLINE)
End Property
Public Property Let FontUnderline(ByVal bUnderline As Boolean)
Dim tCF As CHARFORMAT
Dim lR As Long
   tCF.dwMask = CFM_UNDERLINE
   If (bUnderline) Then
      tCF.dwEffects = CFE_UNDERLINE
   End If
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, m_eCharFormatRange, tCF)
End Property
Public Property Get FontStrikeOut() As Boolean
' Attribute FontStrikeOut.VB_MemberFlags = "400"
Dim tCF As CHARFORMAT
Dim lR As Long
   tCF.dwMask = CFM_STRIKEOUT
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, m_eCharFormatRange, tCF)
   FontStrikeOut = ((tCF.dwEffects And CFE_STRIKEOUT) = CFE_STRIKEOUT)
End Property
Public Property Let FontStrikeOut(ByVal bStrikeOut As Boolean)
Dim tCF As CHARFORMAT
Dim lR As Long
   tCF.dwMask = CFM_STRIKEOUT
   If (bStrikeOut) Then
      tCF.dwEffects = CFE_STRIKEOUT
   End If
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, m_eCharFormatRange, tCF)
End Property

Public Property Get FontColour() As OLE_COLOR
' Attribute FontColour.VB_MemberFlags = "400"
Dim tCF As CHARFORMAT
Dim lR As Long
Dim lColour As Long
   tCF.dwMask = CFM_COLOR
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, m_eCharFormatRange, tCF)
   FontColour = tCF.crTextColor
End Property
Public Property Let FontColour(ByVal oColour As OLE_COLOR)
Dim tCF As CHARFORMAT
Dim lR As Long
Dim lColour As Long
   tCF.crTextColor = TranslateColor(oColour)
   tCF.dwMask = CFM_COLOR
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, m_eCharFormatRange, tCF)
End Property
Public Property Get FontBackColour() As OLE_COLOR
' Attribute FontBackColour.VB_MemberFlags = "400"
Dim tCF2 As CHARFORMAT2
Dim lR As Long
   If (m_eVersion = eRICHED20) Then
      tCF2.dwMask = CFM_BACKCOLOR
      tCF2.cbSize = Len(tCF2)
      lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, m_eCharFormatRange, tCF2)
      FontBackColour = tCF2.crBackColor
   Else
      Unsupported
   End If
End Property
Public Property Let FontBackColour(ByVal oColor As OLE_COLOR)
Dim tCF2 As CHARFORMAT2
Dim lR As Long
   If (m_eVersion = eRICHED20) Then
      tCF2.dwMask = CFM_BACKCOLOR
      tCF2.crBackColor = TranslateColor(oColor)
      tCF2.cbSize = Len(tCF2)
      lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, m_eCharFormatRange, tCF2)
   Else
      Unsupported
   End If
End Property
Public Property Get FontLink() As Boolean
' Attribute FontLink.VB_MemberFlags = "400"
Dim tCF2 As CHARFORMAT2
Dim lR As Long
   If (m_eVersion = eRICHED20) Then
      tCF2.dwMask = CFM_LINK
      tCF2.cbSize = Len(tCF2)
      lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, m_eCharFormatRange, tCF2)
      FontLink = ((tCF2.dwEffects And CFE_LINK) = CFE_LINK)
   Else
      Unsupported
   End If
End Property
Public Property Let FontLink(ByVal bState As Boolean)
Dim tCF2 As CHARFORMAT2
Dim lR As Long
   If (m_eVersion = eRICHED20) Then
      tCF2.dwMask = CFM_LINK
      If (bState) Then
         tCF2.dwEffects = CFE_LINK
      End If
      tCF2.cbSize = Len(tCF2)
      lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, m_eCharFormatRange, tCF2)
   Else
      Unsupported
   End If
End Property
Public Property Get FontProtected() As Boolean
' Attribute FontProtected.VB_MemberFlags = "400"
Dim tCF2 As CHARFORMAT2
Dim lR As Long
   If (m_eVersion = eRICHED20) Then
      tCF2.dwMask = CFM_PROTECTED
      tCF2.cbSize = Len(tCF2)
      lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, m_eCharFormatRange, tCF2)
      FontProtected = ((tCF2.dwEffects And CFE_PROTECTED) = CFE_PROTECTED)
   Else
      Unsupported
   End If
End Property
Public Property Let FontProtected(ByVal bState As Boolean)
Dim tCF2 As CHARFORMAT2
Dim lR As Long
   If (m_eVersion = eRICHED20) Then
      tCF2.dwMask = CFM_PROTECTED
      If (bState) Then
         tCF2.dwEffects = CFE_PROTECTED
      End If
      tCF2.cbSize = Len(tCF2)
      lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, m_eCharFormatRange, tCF2)
   Else
      Unsupported
   End If
End Property

Public Property Get FontSuperScript() As Boolean
' Attribute FontSuperScript.VB_MemberFlags = "400"
Dim tCF As CHARFORMAT
Dim tCF2 As CHARFORMAT2
Dim lR As Long
   If (m_eVersion = eRICHED32) Then
      tCF.dwMask = CFM_OFFSET
      tCF.cbSize = Len(tCF)
      lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, m_eCharFormatRange, tCF)
      'Debug.Print tCF.yOffset
      FontSuperScript = (tCF.yOffset > 0)
   Else
      tCF2.dwMask = CFM_SUPERSCRIPT
      tCF2.cbSize = Len(tCF2)
      lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, m_eCharFormatRange, tCF2)
      FontSuperScript = ((tCF2.dwEffects And CFE_SUPERSCRIPT) = CFE_SUPERSCRIPT)
   End If
End Property
Public Property Get FontSubScript() As Boolean
' Attribute FontSubScript.VB_MemberFlags = "400"
Dim tCF As CHARFORMAT
Dim tCF2 As CHARFORMAT2
Dim lR As Long
   If (m_eVersion = eRICHED32) Then
      tCF.dwMask = CFM_OFFSET
      tCF.cbSize = Len(tCF)
      lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, m_eCharFormatRange, tCF)
      'Debug.Print tCF.yOffset
   Else
      tCF2.dwMask = CFM_SUBSCRIPT
      tCF2.cbSize = Len(tCF2)
      lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, m_eCharFormatRange, tCF2)
      FontSuperScript = ((tCF2.dwEffects And CFE_SUBSCRIPT) = CFE_SUBSCRIPT)
   End If
End Property
Public Property Let FontSuperScript(ByVal bState As Boolean)
Dim tCF As CHARFORMAT
Dim tCF2 As CHARFORMAT2
Dim lR As Long
Dim y As Long

   If (m_eVersion = eRICHED32) Then
      ' Get the current font size in twips:
      tCF.dwMask = CFM_SIZE
      tCF.cbSize = Len(tCF)
      lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, ercSetFormatSelection, tCF)
      y = tCF.yHeight \ 2
      
      ' Set the offset:
      tCF.dwMask = CFM_OFFSET
      tCF.cbSize = Len(tCF)
      If (bState) Then
         tCF.yOffset = y
      Else
         tCF.yOffset = 0
      End If
      lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, m_eCharFormatRange, tCF)
   Else
      tCF2.dwMask = CFM_SUPERSCRIPT
      If (bState) Then
         tCF2.dwEffects = CFE_SUPERSCRIPT
      End If
      tCF2.cbSize = Len(tCF2)
      lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, m_eCharFormatRange, tCF2)
   End If
End Property
Public Property Let FontSubScript(ByVal bState As Boolean)
Dim tCF As CHARFORMAT
Dim tCF2 As CHARFORMAT2
Dim lR As Long
Dim y As Long

   If (m_eVersion = eRICHED32) Then
      ' Get the current font size in twips:
      tCF.dwMask = CFM_SIZE
      tCF.cbSize = Len(tCF)
      lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, ercSetFormatSelection, tCF)
      y = tCF.yHeight \ -2
      
      ' Set the offset:
      tCF.dwMask = CFM_OFFSET
      tCF.cbSize = Len(tCF)
      If (bState) Then
         tCF.yOffset = y
      Else
         tCF.yOffset = 0
      End If
      lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, m_eCharFormatRange, tCF)
   Else
      tCF2.dwMask = CFM_SUBSCRIPT
      If (bState) Then
         tCF2.dwEffects = CFE_SUBSCRIPT
      End If
      tCF2.cbSize = Len(tCF2)
      lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, m_eCharFormatRange, tCF2)
   End If
End Property
Public Sub SetFont( _
      ByRef fntThis As StdFont, _
      Optional ByVal oColor As OLE_COLOR = vbWindowText, _
      Optional ByVal eType As ERECTextTypes = ercTextNormal, _
      Optional ByVal bHyperLink As Boolean = False, _
      Optional ByVal eRange As ERECSetFormatRange = ercSetFormatSelection _
   )
Dim tCF As CHARFORMAT
Dim tCF2 As CHARFORMAT2
Dim dwEffects As Long
Dim dwMask As Long
Dim i As Long
   
   tCF.cbSize = Len(tCF)
   tCF.crTextColor = TranslateColor(oColor)
   dwMask = CFM_COLOR
   If fntThis.Bold Then
      dwEffects = dwEffects Or CFE_BOLD
   End If
   dwMask = dwMask Or CFM_BOLD
   If fntThis.Italic Then
      dwEffects = dwEffects Or CFE_ITALIC
   End If
   dwMask = dwMask Or CFM_ITALIC
   If fntThis.Strikethrough Then
      dwEffects = dwEffects Or CFE_STRIKEOUT
   End If
   dwMask = dwMask Or CFM_STRIKEOUT
   If fntThis.Underline Then
      dwEffects = dwEffects Or CFE_UNDERLINE
   End If
   dwMask = dwMask Or CFM_UNDERLINE

   If bHyperLink Then
      dwEffects = dwEffects Or CFE_LINK
   End If
   dwMask = dwMask Or CFM_LINK
   
   tCF.dwEffects = dwEffects
   tCF.dwMask = dwMask Or CFM_FACE Or CFM_SIZE
   
   For i = 1 To Len(fntThis.Name)
      tCF.szFaceName(i - 1) = Asc(Mid$(fntThis.Name, i, 1))
   Next i
   tCF.yHeight = (fntThis.Size * 20)
   If (eType = ercTextSubscript) Then
      tCF.yOffset = -tCF.yHeight \ 2
   End If
   If (eType = ercTextSuperscript) Then
      tCF.yOffset = tCF.yHeight \ 2
   End If
   
   If (m_eVersion = eRICHED32) Then
      SendMessage m_hWnd, EM_SETCHARFORMAT, eRange, tCF
   Else
      CopyMemory tCF2, tCF, Len(tCF)
      tCF2.cbSize = Len(tCF2)
      tCF.yOffset = 0
      If (eType = ercTextSubscript) Then
         tCF.dwEffects = tCF.dwEffects Or CFE_SUBSCRIPT
         tCF.dwMask = tCF.dwMask Or CFM_SUBSCRIPT
      End If
      If (eType = ercTextSuperscript) Then
         tCF.dwEffects = tCF.dwEffects Or CFE_SUPERSCRIPT
         tCF.dwMask = tCF.dwMask Or CFM_SUPERSCRIPT
      End If
      SendMessage m_hWnd, EM_SETCHARFORMAT, eRange, tCF2
   End If
   
End Sub
Public Function GetFont( _
      Optional ByVal bForSelection As Boolean = False, _
      Optional ByRef oColor As OLE_COLOR, _
      Optional ByRef bHyperLink As Boolean, _
      Optional ByVal eType As ERECTextTypes = ercTextNormal _
   ) As StdFont
Dim sFnt As New StdFont
Dim tCF As CHARFORMAT
Dim tCF2 As CHARFORMAT2
Dim dwEffects As Long
Dim dwMask As Long
Dim i As Long
Dim sName As String
   
   tCF.cbSize = Len(tCF)
   dwMask = dwMask Or CFM_COLOR

   dwMask = dwMask Or CFM_BOLD
   dwMask = dwMask Or CFM_ITALIC
   dwMask = dwMask Or CFM_STRIKEOUT
   dwMask = dwMask Or CFM_UNDERLINE
   dwMask = dwMask Or CFM_LINK
   If (m_eVersion = eRICHED32) Then
      tCF.dwEffects = dwEffects
      tCF.dwMask = dwMask Or CFM_FACE Or CFM_SIZE
      SendMessage m_hWnd, EM_GETCHARFORMAT, Abs(bForSelection), tCF
   Else
      CopyMemory tCF2, tCF, Len(tCF)
      tCF2.cbSize = Len(tCF2)
      SendMessage m_hWnd, EM_GETCHARFORMAT, Abs(bForSelection), tCF2
   End If
      
   If (m_eVersion = eRICHED32) Then
      'tCF.crTextColor = TranslateColor(oColor)
      oColor = tCF.crTextColor
      For i = 1 To LF_FACESIZE
         sName = sName & Chr$(tCF.szFaceName(i - 1))
      Next i
      sFnt.Name = sName
      sFnt.Size = tCF.yHeight \ 20
      sFnt.Bold = ((tCF.dwEffects And CFE_BOLD) = CFE_BOLD)
      sFnt.Italic = ((tCF.dwEffects And CFE_ITALIC) = CFE_ITALIC)
      sFnt.Underline = ((tCF.dwEffects And CFE_UNDERLINE) = CFE_UNDERLINE)
      sFnt.Strikethrough = ((tCF.dwEffects And CFE_STRIKEOUT) = CFE_STRIKEOUT)
      bHyperLink = ((tCF.dwEffects And CFE_LINK) = CFE_LINK)
      If (tCF.yOffset = 0) Then
         eType = ercTextNormal
      ElseIf (tCF.yOffset < 0) Then
         eType = ercTextSubscript
      Else
         eType = ercTextSuperscript
      End If
   Else
      oColor = tCF2.crTextColor
      For i = 1 To LF_FACESIZE
         sName = sName & Chr$(tCF2.szFaceName(i - 1))
      Next i
      sFnt.Name = sName
      sFnt.Size = tCF2.yHeight \ 20
      sFnt.Bold = ((tCF2.dwEffects And CFE_BOLD) = CFE_BOLD)
      sFnt.Italic = ((tCF2.dwEffects And CFE_ITALIC) = CFE_ITALIC)
      sFnt.Underline = ((tCF2.dwEffects And CFE_UNDERLINE) = CFE_UNDERLINE)
      sFnt.Strikethrough = ((tCF2.dwEffects And CFE_STRIKEOUT) = CFE_STRIKEOUT)
      bHyperLink = ((tCF2.dwEffects And CFE_LINK) = CFE_LINK)
      eType = ercTextNormal
      If ((tCF2.dwEffects And CFE_SUPERSCRIPT) = CFE_SUPERSCRIPT) Then
         eType = ercTextSuperscript
      End If
      If ((tCF2.dwEffects And CFE_SUBSCRIPT) = CFE_SUBSCRIPT) Then
         eType = ercTextSubscript
      End If
   End If
   Set GetFont = sFnt
End Function

Public Property Get ParagraphNumbering() As ERECParagraphNumberingConstants
Dim tP As PARAFORMAT
Dim tP2 As PARAFORMAT2
Dim lR As Long

   If (m_eVersion = eRICHED32) Then
      tP.dwMask = PFM_NUMBERING
      tP.cbSize = Len(tP)
      lR = SendMessage(m_hWnd, EM_GETPARAFORMAT, 0, tP)
      ParagraphNumbering = tP.wNumbering
   Else
      tP2.dwMask = PFM_NUMBERING
      tP2.cbSize = Len(tP2)
      lR = SendMessage(m_hWnd, EM_GETPARAFORMAT, 0, tP2)
      ParagraphNumbering = tP2.wNumbering
   End If
End Property
Public Property Let ParagraphNumbering(ByVal eStyle As
 ERECParagraphNumberingConstants)
Dim tP As PARAFORMAT
Dim tP2 As PARAFORMAT2
Dim lR As Long

   If (m_eVersion = eRICHED32) Then
      tP.dwMask = PFM_NUMBERING
      tP.cbSize = Len(tP)
      tP.wNumbering = eStyle
      lR = SendMessage(m_hWnd, EM_SETPARAFORMAT, 0, tP)
   Else
      tP2.dwMask = PFM_NUMBERING
      tP2.wNumbering = eStyle
      tP2.cbSize = Len(tP2)
      lR = SendMessage(m_hWnd, EM_SETPARAFORMAT, 0, tP2)
   End If
End Property
Public Sub GetParagraphOffsets( _
      ByRef lStartIndent As Long, _
      ByRef lLeftOffset As Long, _
      ByRef lRightOffset As Long _
   )
Dim tP As PARAFORMAT
Dim tP2 As PARAFORMAT2
Dim lR As Long

   If (m_eVersion = eRICHED32) Then
      tP.dwMask = PFM_STARTINDENT Or PFM_RIGHTINDENT Or PFM_OFFSET
      tP.cbSize = Len(tP)
      lR = SendMessage(m_hWnd, EM_GETPARAFORMAT, 0, tP)
      lStartIndent = tP.dxStartIndent
      lLeftOffset = tP.dxOffset
      lRightOffset = tP.dxRightIndent
   Else
      tP2.dwMask = PFM_STARTINDENT Or PFM_RIGHTINDENT Or PFM_OFFSET
      tP2.cbSize = Len(tP2)
      lR = SendMessage(m_hWnd, EM_GETPARAFORMAT, 0, tP2)
      lStartIndent = tP2.dxStartIndent
      lLeftOffset = tP2.dxOffset
      lRightOffset = tP2.dxRightIndent
   End If
End Sub
Public Sub SetParagraphOffsets( _
      ByVal lStartIndent As Long, _
      ByVal lLeftOffset As Long, _
      ByVal lRightOffset As Long _
   )
Dim tP As PARAFORMAT
Dim tP2 As PARAFORMAT2
Dim lR As Long

   If (m_eVersion = eRICHED32) Then
      tP.dwMask = PFM_STARTINDENT Or PFM_RIGHTINDENT Or PFM_OFFSET
      tP.dxStartIndent = lStartIndent
      tP.dxOffset = lLeftOffset
      tP.dxRightIndent = lRightOffset
      tP.cbSize = Len(tP)
      lR = SendMessage(m_hWnd, EM_SETPARAFORMAT, 0, tP)
   Else
      tP2.dwMask = PFM_STARTINDENT Or PFM_RIGHTINDENT Or PFM_OFFSET
      tP2.dxStartIndent = lStartIndent
      tP2.dxOffset = lLeftOffset
      tP2.dxRightIndent = lRightOffset
      tP2.cbSize = Len(tP2)
      lR = SendMessage(m_hWnd, EM_SETPARAFORMAT, 0, tP2)
   End If
      
End Sub
Public Property Get ParagraphAlignment() As ERECParagraphAlignmentConstants
Dim tP As PARAFORMAT
Dim tP2 As PARAFORMAT2
Dim lR As Long

   If (m_eVersion = eRICHED32) Then
      tP.dwMask = PFM_ALIGNMENT
      tP.cbSize = Len(tP)
      lR = SendMessage(m_hWnd, EM_GETPARAFORMAT, 0, tP)
      ParagraphAlignment = tP.wAlignment
   Else
      tP2.dwMask = PFM_ALIGNMENT
      tP2.cbSize = Len(tP2)
      lR = SendMessage(m_hWnd, EM_GETPARAFORMAT, 0, tP2)
      ParagraphAlignment = tP2.wAlignment
   End If

End Property
Public Property Let ParagraphAlignment(ByVal eAlign As
 ERECParagraphAlignmentConstants)
Dim tP As PARAFORMAT
Dim tP2 As PARAFORMAT2
Dim lR As Long

   If (m_eVersion = eRICHED32) Then
      If (eAlign = ercParaJustify) Then
         Unsupported
      Else
         tP.dwMask = PFM_ALIGNMENT
         tP.cbSize = Len(tP)
         tP.wAlignment = eAlign
         lR = SendMessage(m_hWnd, EM_SETPARAFORMAT, 0, tP)
      End If
   Else
      tP2.dwMask = PFM_ALIGNMENT
      tP2.cbSize = Len(tP2)
      tP2.wAlignment = eAlign
      lR = SendMessage(m_hWnd, EM_SETPARAFORMAT, 0, tP2)
   End If

End Property
Public Sub GetParagraphTabs( _
      ByRef iCount As Integer, _
      ByRef lTabSize() As Long, _
      Optional ByRef eTabAlignment As Variant, _
      Optional ByRef eTabLeader As Variant _
   )
Dim tP As PARAFORMAT
Dim tP2 As PARAFORMAT2
Dim lR As Long
Dim lNumTabs As Long
Dim lPtrTabs As Long
Dim lTabs() As Long
Dim i As Long
Dim lAlign() As Long
Dim lLeader() As Long


   Erase lTabSize
   eTabAlignment = 0
   eTabLeader = 0
   iCount = 0
   
   If (m_eVersion = eRICHED32) Then
      tP.dwMask = PFM_TABSTOPS
      tP.cbSize = Len(tP)
      lR = SendMessage(m_hWnd, EM_GETPARAFORMAT, 0, tP)
      lNumTabs = tP.cTabCount
      If (lNumTabs > 0) Then
         iCount = tP.cTabCount
         ReDim lTabSize(1 To lNumTabs) As Long
         For i = 0 To lNumTabs - 1
            lTabSize(i + 1) = tP.lTabStops(i)
         Next i
      End If
   Else
      tP2.dwMask = PFM_TABSTOPS
      tP2.cbSize = Len(tP2)
      lR = SendMessage(m_hWnd, EM_GETPARAFORMAT, 0, tP2)
      lNumTabs = tP2.cTabCount
      If (lNumTabs > 0) Then
         iCount = tP2.cTabCount
         ReDim lTabSize(1 To lNumTabs) As Long
         ReDim lAlign(1 To lNumTabs) As Long
         ReDim lLeader(1 To lNumTabs) As Long
         For i = 0 To lNumTabs - 1
            ' First 24 bits are size:
            lTabSize(i + 1) = (tP2.lTabStops(i) And &HFFFFFF)
            ' Bits 24-27 are alignment:
            lAlign(i + 1) = (tP2.lTabStops(i) And &HF000000) \ &H1000000
            ' Bits 28-31 are leader:
            lLeader(i + 1) = (tP2.lTabStops(i) And &H70000000) \ &H10000000
         Next i
         eTabAlignment = lAlign
         eTabLeader = lLeader
      End If
   End If
        
End Sub
Public Sub SetParagraphTabs( _
      ByVal iCount As Integer, _
      ByRef lTabSize() As Long, _
      Optional ByRef eTabAlignment As Variant, _
      Optional ByRef eTabLeader As Variant _
   )
Dim tP As PARAFORMAT
Dim tP2 As PARAFORMAT2
Dim lR As Long
Dim lNumTabs As Long
Dim lPtrTabs As Long
Dim i As Long
   
   
   If (m_eVersion = eRICHED32) Then
      tP.dwMask = PFM_TABSTOPS
      tP.cbSize = Len(tP)
      tP.cTabCount = iCount
      If (iCount > 0) Then
         For i = 0 To iCount - 1
            tP.lTabStops(i) = lTabSize(i + 1)
         Next i
      End If
      lR = SendMessage(m_hWnd, EM_SETPARAFORMAT, 0, tP)
   Else
      tP2.dwMask = PFM_TABSTOPS
      tP2.cbSize = Len(tP2)
      tP2.cTabCount = iCount
      If (iCount > 0) Then
         For i = 0 To iCount - 1
            tP2.lTabStops(i) = lTabSize(i + 1)
         Next i
      End If
      lR = SendMessage(m_hWnd, EM_SETPARAFORMAT, 0, tP2)
   End If
   
End Sub
Public Sub GetParagraphLineSpacing( _
      ByRef eLineSpacingStyle As ERECParagraphLineSpacingConstants, _
      ByRef ySpacing As Long _
   )
Dim tCF2 As PARAFORMAT2
Dim lR As Long
   If (m_eVersion = eRICHED32) Then
      Unsupported
   Else
      tCF2.dwMask = PFM_LINESPACING
      tCF2.cbSize = Len(tCF2)
      lR = SendMessage(m_hWnd, EM_GETPARAFORMAT, 0, tCF2)
      eLineSpacingStyle = tCF2.bLineSpacingRule
      ySpacing = tCF2.dyLineSpacing
   End If
End Sub
Public Sub SetParagraphLineSpacing( _
      ByVal eLineSpacingStyle As ERECParagraphLineSpacingConstants, _
      ByVal ySpacing As Long _
   )
Dim tCF2 As PARAFORMAT2
Dim lR As Long
   If (m_eVersion = eRICHED32) Then
      Unsupported
   Else
      tCF2.dwMask = PFM_LINESPACING
      tCF2.cbSize = Len(tCF2)
      tCF2.bLineSpacingRule = eLineSpacingStyle
      tCF2.dyLineSpacing = ySpacing
      lR = SendMessage(m_hWnd, EM_SETPARAFORMAT, 0, tCF2)
   End If
End Sub
Public Sub GetParagraphSpacing( _
      ByRef lSpaceAfter As Long, _
      ByRef lSpaceBefore As Long _
   )
Dim tCF2 As PARAFORMAT2
Dim lR As Long
   If (m_eVersion = eRICHED32) Then
      Unsupported
   Else
      tCF2.dwMask = PFM_SPACEBEFORE Or PFM_SPACEAFTER
      tCF2.cbSize = Len(tCF2)
      lR = SendMessage(m_hWnd, EM_GETPARAFORMAT, 0, tCF2)
      lSpaceAfter = tCF2.dySpaceAfter
      lSpaceBefore = tCF2.dySpaceBefore
   End If
End Sub
Public Sub SetParagraphSpacing( _
      ByVal lSpaceAfter As Long, _
      ByVal lSpaceBefore As Long _
   )
Dim tCF2 As PARAFORMAT2
Dim lR As Long
   If (m_eVersion = eRICHED32) Then
      Unsupported
   Else
      tCF2.dwMask = PFM_SPACEBEFORE Or PFM_SPACEAFTER
      tCF2.cbSize = Len(tCF2)
      tCF2.dySpaceAfter = lSpaceAfter
      tCF2.dySpaceBefore = lSpaceBefore
      lR = SendMessage(m_hWnd, EM_SETPARAFORMAT, 0, tCF2)
   End If
   
End Sub

Public Property Let UseVersion(ByVal eVersion As ERECControlVersion)
    If (UserControl.Ambient.UserMode) Then
        ' can't set at run time in this implementation.
        Unsupported 1
    Else
        m_eVersion = eVersion
    End If
End Property
Public Property Get UseVersion() As ERECControlVersion
    UseVersion = m_eVersion
End Property
Public Property Get IsRtf(ByRef sFileText As String) As Boolean
   If (Left$(sFileText, 5) = "{\rtf") Then
      IsRtf = True
   End If
End Property
Public Property Get Redraw() As Boolean
   Redraw = m_bRedraw
End Property
Public Property Let Redraw(ByVal bState As Boolean)
   If (m_hWnd <> 0) Then
      If Not (bState) Then
         ' Don't redraw:
         SendMessageLong m_hWnd, WM_SETREDRAW, 0, 0
      Else
         ' Redraw again:
         SendMessageLong m_hWnd, WM_SETREDRAW, 1, 0
         InvalidateRectAsNull m_hWnd, 0, 1
         UpdateWindow m_hWnd
      End If
   End If
   m_bRedraw = bState
   PropertyChanged "Redraw"
End Property
Public Property Let Contents(ByVal eType As ERECFileTypes, ByRef sContents As
 String)
Dim tStream As EDITSTREAM
Dim lR As Long
   
   m_eProgressType = ercLoad
   
   ' Load the text:
   tStream.dwCookie = m_hWnd
   tStream.pfnCallback = plAddressOf(AddressOf LoadCallBack)
   tStream.dwError = 0
   StreamText = sContents
   RichEdit = Me
   ' The text will be streamed in though the LoadCallback function:
   lR = SendMessage(m_hWnd, EM_STREAMIN, eType, tStream)
   ClearRichEdit
   ' Set unmodified flag
   SendMessageLong m_hWnd, EM_SETMODIFY, 0, 0
      
   m_eProgressType = ercNone
   
End Property
Public Property Get Contents(ByVal eType As ERECFileTypes) As String
Dim tStream As EDITSTREAM
        
   m_eProgressType = ercSave
        
   tStream.dwCookie = m_hWnd
   tStream.pfnCallback = plAddressOf(AddressOf SaveCallBack)
   tStream.dwError = 0
   ' The text will be streamed out though the SaveCallback function:
   ClearStreamText
   RichEdit = Me
   SendMessage m_hWnd, EM_STREAMOUT, eType, tStream
   ClearRichEdit
   
   Contents = StreamText()
    
   m_eProgressType = ercNone
    
End Property
Public Function LoadFromFile( _
      ByVal sFile As String, _
      ByVal eType As ERECFileTypes _
   ) As Boolean
Dim hFile As Long
Dim tOF As OFSTRUCT
Dim tStream As EDITSTREAM
Dim lR As Long

   m_eProgressType = ercLoad
   
   hFile = OpenFile(sFile, tOF, OF_READ)
   If (hFile <> 0) Then
      tStream.dwCookie = hFile
      tStream.pfnCallback = plAddressOf(AddressOf LoadCallBack)
      tStream.dwError = 0
      
      RichEdit = Me
      FileMode = True
      
      ' The text will be streamed in though the LoadCallback function:
      lR = SendMessage(m_hWnd, EM_STREAMIN, eType, tStream)
      
      LoadFromFile = (lR <> 0)
      
      FileMode = False
      ClearRichEdit
      
      CloseHandle hFile
   End If
   
   m_eProgressType = ercNone
End Function
Public Function SaveToFile( _
      ByVal sFile As String, _
      ByVal eType As ERECFileTypes _
   ) As Boolean
Dim tStream As EDITSTREAM
Dim tOF As OFSTRUCT
Dim hFile As Long
Dim lR As Long
        
   m_eProgressType = ercSave
        
   hFile = OpenFile(sFile, tOF, OF_CREATE)
   If (hFile <> 0) Then
      tStream.dwCookie = hFile
      tStream.pfnCallback = plAddressOf(AddressOf SaveCallBack)
      tStream.dwError = 0
      FileMode = True
      RichEdit = Me
      
      lR = SendMessage(m_hWnd, EM_STREAMOUT, eType, tStream)
      
      SaveToFile = (lR <> 0)
      
      FileMode = False
      ClearRichEdit
   
      CloseHandle hFile
   End If
    
   m_eProgressType = ercNone
       
End Function

Public Sub RaiseLoadStatus(ByVal lAmount As Long, ByVal lTotalAmount As Long)
   RaiseEvent ProgressStatus(lAmount, lTotalAmount)
End Sub

Public Sub PrintDocDC( _
      ByVal lPrinterHDC As Long, _
      ByVal sDocTitle As String, _
      Optional ByVal nStartPage As Long, _
      Optional ByVal nEndPage As Long _
   )
Dim fr As FORMATRANGE
Dim di As DOCINFO
Dim lTextOut As Long, lTextAmt As Long
Dim lLastTextOut As Long
Dim b() As Byte
Dim hJob As Long
Dim lR As Long
Dim lWidthTwips As Long, lHeightTwips As Long
Dim lLeftTwips As Long, lTopTwips As Long
Dim lPixelsX As Long, lPixelsY As Long
Dim lRightMargin As Long, lBottomMargin As Long
Dim bPage As Boolean, bNoNewPage As Boolean
Dim lPage As Long
   
   m_eProgressType = ercPrint
   
    '// Be sure that the printer DC is in text mode.
    SetMapMode lPrinterHDC, MM_TEXT

    '// Fill out the FORMATRANGE structure for the RTF output.
    fr.hdc = lPrinterHDC '; // HDC
    fr.hdcTarget = fr.hdc
    fr.chrg.cpMin = 0 '; // print
    fr.chrg.cpMax = -1 '; // entire contents
    
    ' Get information about the physically printable page on the
    ' printer:
    
    ' This is the number of Pixels per inch:
    lPixelsX = GetDeviceCaps(lPrinterHDC, LOGPIXELSX)
    lPixelsY = GetDeviceCaps(lPrinterHDC, LOGPIXELSY)
    
    ' This is the number of pixels across:
    lWidthTwips = (GetDeviceCaps(lPrinterHDC, PHYSICALWIDTH) * 1440) / lPixelsX
    
    ' This is the number of pixels down:
    lHeightTwips = (GetDeviceCaps(lPrinterHDC, PHYSICALHEIGHT) * 1440) /
     lPixelsY
    
    ' Evaluate the left and right physical offsets:
    lLeftTwips = (GetDeviceCaps(lPrinterHDC, PHYSICALOFFSETX) * 1440) / lPixelsX
    lTopTwips = (GetDeviceCaps(lPrinterHDC, PHYSICALOFFSETY) * 1440) / lPixelsY
    
   ' Add in the required margins taking into account the physical offsets
    (assuming
   ' left and top are mirrored left & bottom):
   If (m_lLeftMargin > lLeftTwips) Then
      fr.rc.Left = m_lLeftMargin - lLeftTwips
   End If
   If (m_lTopMargin > lTopTwips) Then
      fr.rc.Top = m_lTopMargin - lTopTwips
   End If
   lRightMargin = m_lRightMargin + lLeftTwips
   lBottomMargin = m_lBottomMargin + lTopTwips
   fr.rc.Right = lWidthTwips - lRightMargin
   If (fr.rc.Right < 1440) Then fr.rc.Right = 1440
   fr.rc.Bottom = lHeightTwips - lBottomMargin
   If (fr.rc.Bottom < 1440) Then fr.rc.Bottom = 1440
   fr.rcPage.Right = lWidthTwips
   fr.rcPage.Bottom = lHeightTwips

    '// Fill out the DOCINFO structure.
    di.cbSize = Len(di)
    If (sDocTitle = "") Then
        sDocTitle = "RTF Document"
    End If
    ReDim b(0 To Len(sDocTitle) - 1) As Byte
    b = StrConv(sDocTitle, vbFromUnicode)
    di.lpszDocName = VarPtr(b(0))
    di.lpszOutput = 0

    lPage = 1
    RaiseEvent ProgressStatus(-1, -1)
    hJob = StartDoc(lPrinterHDC, di)
    If (hJob <> 0) Then
    
        lTextOut = 0
        lTextAmt = SendMessage(m_hWnd, WM_GETTEXTLENGTH, 0, 0)
    
        Do While (lTextOut < lTextAmt)
            ' Work out the size of text to render:
            lTextOut = SendMessage(m_hWnd, EM_FORMATRANGE, 0, fr)
            
            If (lTextOut <= lLastTextOut) Then
               ' Problem! - for some reason some prints
               ' get stuck in a loop on the last page!
               ' causes an extra page to be printed...
               Debug.Assert lTextOut <> lLastTextOut
               ' Force a terminate
               If (lTextOut < lLastTextOut) Then
                  bNoNewPage = True
               End If
               lTextOut = lTextAmt
            End If
            lLastTextOut = lTextOut
            
            If Not (bNoNewPage) Then
               RaiseEvent ProgressStatus(lTextOut, lTextAmt)
            End If
            
            If (lTextOut <= lTextAmt) Then
               ' Print it
               If (bPage) Then
                  EndPage lPrinterHDC
                  bPage = False
               End If
               If Not (bNoNewPage) Then
                  StartPage lPrinterHDC
                  SendMessage m_hWnd, EM_DISPLAYBAND, 0, fr.rc
                  bPage = True
                  fr.chrg.cpMin = lTextOut
                  fr.chrg.cpMax = -1
               End If
            End If
        Loop
    
        RaiseEvent ProgressStatus(lTextAmt, lTextAmt)

        '// Reset the formatting of the rich edit control.
        SendMessageLong m_hWnd, EM_FORMATRANGE, True, 0
    
        '// Finish the document.
         If (bPage) Then
            EndPage lPrinterHDC
         End If
         EndDoc lPrinterHDC
    Else
        Debug.Print "Failed to start print job"
    End If
   
End Sub


Public Sub PrintDoc( _
      ByVal sDocTitle As String _
   )
Dim pd As PrintDlg

   '// Initialize the PRINTDLG structure.
   pd.lStructSize = Len(pd)
   pd.hWndOwner = m_hWnd
   pd.hDevMode = 0
   pd.hDevNames = 0
   pd.nFromPage = 0
   pd.nToPage = 0
   pd.nMinPage = 0
   pd.nMaxPage = 0
   pd.nCopies = 0
   pd.hInstance = App.hInstance
   pd.flags = PD_RETURNDC Or PD_NOSELECTION Or PD_PRINTSETUP
   pd.lpfnSetupHook = 0
   pd.lpSetupTemplateName = 0
   pd.lpfnPrintHook = 0
   pd.lpPrintTemplateName = 0
   
   '// Get the printer DC.
   If (PrintDlg(pd) <> 0) Then
      
      PrintDocDC pd.hdc, sDocTitle
       '// Delete the printer DC.
       DeleteDC pd.hdc
       
       m_eProgressType = ercNone
   End If

End Sub

Private Function plAddressOf(ByVal lAddr As Long) As Long
    ' Why do we have to write nonsense like this?
    plAddressOf = lAddr
End Function
Public Property Get hwnd() As Long
   hwnd = UserControl.hwnd
End Property

Public Property Get RichEdithWnd() As Long
   RichEdithWnd = m_hWnd
End Property

Public Sub SetFocus()
   SetFocusAPI m_hWnd
End Sub

Private Sub pInitialise()
Dim dwStyle As Long
Dim dwExStyle As Long
Dim lS As Long
Dim hP As Long
Dim sLib As String
Dim sClass As String

    pTerminate

    If (UserControl.Ambient.UserMode) Then
        If (m_eVersion = eRICHED20) Then
            sLib = "RICHED20.DLL"
            sClass = RICHEDIT_CLASSA
        Else
            sLib = "RICHED32.DLL"
            sClass = RICHEDIT_CLASS10A
        End If
        m_hLib = LoadLibrary(sLib)
        If m_hLib <> 0 Then
            dwStyle = WS_CHILD Or WS_CLIPCHILDREN Or WS_CLIPSIBLINGS
            dwStyle = dwStyle Or WS_HSCROLL Or WS_VSCROLL
            dwStyle = dwStyle Or WS_TABSTOP
            dwStyle = dwStyle Or ES_MULTILINE Or ES_SAVESEL
            dwStyle = dwStyle Or ES_AUTOVSCROLL Or ES_AUTOHSCROLL
            dwStyle = dwStyle Or ES_SELECTIONBAR Or ES_NOHIDESEL
         
         If (m_bBorder) Then
            dwStyle = dwStyle Or ES_SUNKEN
            dwExStyle = WS_EX_CLIENTEDGE
         End If
         'dwExStyle = dwExStyle Or WS_EX_TRANSPARENT
            
        '// Create the rich edit control.
            m_hWnd = CreateWindowEx( _
                dwExStyle, _
                sClass, _
                "", _
                dwStyle, _
                0, 0, UserControl.ScaleWidth \ Screen.TwipsPerPixelX,
                 UserControl.ScaleHeight \ Screen.TwipsPerPixelY, _
                UserControl.hwnd, _
                0, _
                App.hInstance, _
                0)
            If (m_hWnd <> 0) Then
                EnableWindow m_hWnd, 1
                ShowWindow m_hWnd, SW_SHOW
                pAttachMessages
            End If
        End If
    End If
End Sub
Private Function pTerminate()
   If (m_hWnd <> 0) Then
      ' Remove printer DC from the
      ViewMode = ercDefault
      ' Stop subclassing:
      pDetachMessages
      ' Destroy the window:
      ShowWindow m_hWnd, SW_HIDE
      SetParent m_hWnd, 0
      DestroyWindow m_hWnd
      ' store that we haven't a window:
      m_hWnd = 0
   End If
   If (m_hLib <> 0) Then
       FreeLibrary m_hLib
       m_hLib = 0
   End If
End Function
Private Sub pAttachMessages()
Dim dwMask As Long
    m_emr = emrPreprocess
    AttachMessage Me, UserControl.hwnd, WM_NOTIFY
    AttachMessage Me, UserControl.hwnd, WM_SETFOCUS
    AttachMessage Me, m_hWnd, WM_VSCROLL
    AttachMessage Me, m_hWnd, WM_HSCROLL
    AttachMessage Me, m_hWnd, WM_DESTROY
    'AttachMessage Me, UserControl.hwnd, WM_PAINT
    ' Key And Mouse Events
    dwMask = ENM_KEYEVENTS Or ENM_MOUSEEVENTS
    ' Selection change
    dwMask = dwMask Or ENM_SELCHANGE
    ' Update
    dwMask = dwMask Or ENM_DROPFILES
    ' Scrolling
    dwMask = dwMask Or ENM_SCROLL
    ' Update:
    dwMask = dwMask Or ENM_UPDATE
    If (m_eVersion = eRICHED20) Then
      ' Link over messages:
      dwMask = dwMask Or ENM_LINK
      ' Protected messages:
      dwMask = dwMask Or ENM_PROTECTED
    End If
    SendMessageLong m_hWnd, EM_SETEVENTMASK, 0, dwMask
    m_bSubclassing = True
End Sub
Private Sub pDetachMessages()
    If (m_bSubclassing) Then
        DetachMessage Me, UserControl.hwnd, WM_NOTIFY
        DetachMessage Me, UserControl.hwnd, WM_SETFOCUS
        DetachMessage Me, m_hWnd, WM_VSCROLL
        DetachMessage Me, m_hWnd, WM_HSCROLL
        DetachMessage Me, m_hWnd, WM_DESTROY
        'DetachMessage Me, UserControl.hwnd, WM_PAINT
        m_bSubclassing = False
    End If
End Sub
Public Property Get AllowShortCut(ByVal eShortCut As
 ERECInbuiltShortcutConstants) As Boolean
   AllowShortCut = m_bAllowMethod(eShortCut)
End Property
Public Property Let AllowShortCut(ByVal eShortCut As
 ERECInbuiltShortcutConstants, ByVal bState As Boolean)
   m_bAllowMethod(eShortCut) = bState
End Property
Public Sub GetPageMargins( _
      ByRef lLeftMargin As Long, _
      ByRef lTopMargin As Long, _
      ByRef lRightMargin As Long, _
      ByRef lBottomMargin As Long _
   )
   lLeftMargin = m_lLeftMargin
   lTopMargin = m_lTopMargin
   lRightMargin = m_lRightMargin
   lBottomMargin = m_lBottomMargin
End Sub
Public Sub SetPageMargins( _
      Optional ByVal lLeftMargin As Long = 1800, _
      Optional ByVal lTopMargin As Long = 1800, _
      Optional ByVal lRightMargin As Long = 1440, _
      Optional ByVal lBottomMargin As Long = 1440 _
   )
   m_lLeftMargin = lLeftMargin
   m_lTopMargin = lTopMargin
   m_lRightMargin = lRightMargin
   m_lBottomMargin = lBottomMargin
   If (m_eViewMode = ercWYSIWYG) Then
      ' Reset the view to account for
      ' left & right margins:
      ViewMode = ercWordWrap
      ViewMode = ercWYSIWYG
   End If
End Sub
Private Function pDoDefault( _
      ByRef iKeyCode As Integer, _
      ByRef iShift As Integer, _
      ByRef bDefault As Boolean _
   )
Dim tCF As CHARFORMAT

   ' Debug.Print iKeyCode
   If (iShift And vbCtrlMask) = vbCtrlMask Then
      Select Case iKeyCode
      
      ' Inbuilt methods:
      Case vbKeyC
         If Not (AllowShortCut(ercCopy_CtrlC)) Then
            bDefault = False
         End If
      Case vbKeyV
         If Not (AllowShortCut(ercPaste_CtrlV)) Then
            bDefault = False
         End If
      Case vbKeyX
         If Not (AllowShortCut(ercCut_CtrlX)) Then
            bDefault = False
         End If
      Case vbKeyA
         If Not (AllowShortCut(ercSelectAll_CtrlA)) Then
            bDefault = False
         End If
      Case vbKeyZ
         If Not (AllowShortCut(ercUndo_CtrlZ)) Then
            bDefault = False
         End If
      
      ' Supplied methods:
      Case vbKeyY
         If AllowShortCut(ercRedo_CtrlY) Then
            Redo
            bDefault = False
         End If
      Case vbKeyB
         If AllowShortCut(ercBold_CtrlB) Then
            pInvertFontOption CFM_BOLD, CFE_BOLD
            bDefault = False
         End If
      Case vbKeyI
         If AllowShortCut(ercItalic_CtrlI) Then
            pInvertFontOption CFM_ITALIC, CFE_ITALIC
            bDefault = False
         End If
      Case vbKeyU
         If AllowShortCut(ercUnderline_CtrlU) Then
            pInvertFontOption CFM_UNDERLINE, CFE_UNDERLINE
            bDefault = False
         End If
      Case vbKeyAdd, 187
         If AllowShortCut(ercSubscript_CtrlMinus) Then
            ' Debug.Print "Add"
            pInvertSubScriptOption 1
            bDefault = False
         End If
      Case vbKeySubtract, 189
         If AllowShortCut(ercSuperscript_CtrlPlus) Then
            ' Debug.Print "Subtract"
            pInvertSubScriptOption -1
            bDefault = False
         End If
      Case vbKeyP
         If AllowShortCut(ercPrint_CtrlP) Then
            PrintDoc m_sFileName
            bDefault = False
         End If
      Case vbKeyN
         If AllowShortCut(ercNew_CtrlN) Then
            Contents(SF_TEXT) = ""
         End If
      
      End Select
   End If

End Function
Private Sub pInvertSubScriptOption(ByVal lSelItem As Long)
Dim tCF As CHARFORMAT
Dim lR As Long

   tCF.dwMask = CFM_OFFSET
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, 1, tCF)
      ' Debug.Print lR
   If (Abs(tCF.yOffset) = Abs(lSelItem)) Then
      tCF.yOffset = 0
   Else
      tCF.yOffset = Sgn(lSelItem)
   End If
   tCF.dwMask = CFM_OFFSET
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, 1, tCF)
      ' Debug.Print lR
      
End Sub
Private Sub pInvertFontOption(ByVal lEffect As Long, ByVal lMask As Long)
Dim tCF As CHARFORMAT
Dim lR As Long

   tCF.dwEffects = lEffect
   tCF.dwMask = lMask
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_GETCHARFORMAT, (SCF_WORD Or SCF_SELECTION), tCF)
   If ((tCF.dwEffects And lEffect) = lEffect) Then
      tCF.dwEffects = 0
   Else
      tCF.dwEffects = lEffect
   End If
   tCF.dwMask = lMask
   tCF.cbSize = Len(tCF)
   lR = SendMessage(m_hWnd, EM_SETCHARFORMAT, (SCF_WORD Or SCF_SELECTION), tCF)
      ' Debug.Print lR
   
End Sub
Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)
    '
End Property

Private Property Get ISubclass_MsgResponse() As EMsgResponse
   Select Case CurrentMessage
   Case WM_SETFOCUS
      ISubclass_MsgResponse = emrConsume
   Case WM_PAINT, WM_HSCROLL, WM_VSCROLL
      ISubclass_MsgResponse = emrPostProcess
   Case Else
      ISubclass_MsgResponse = emrPreprocess
   End Select
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long,
 ByVal wParam As Long, ByVal lparam As Long) As Long
Dim tNMH As NMHDR_RICHEDIT
Dim tSC As SELCHANGE
Dim tEN As ENLINK
Dim tMF As MSGFILTER
Dim tPR As ENPROTECTED
Dim tP As POINTAPI
Dim x As Single, y As Single
Dim iKeyCode As Integer, iKeyAscii As Integer, iShift As Integer
Dim bDefault As Boolean
Dim bDoIt As Boolean
Dim ID As Long

   If (iMsg = WM_NOTIFY) Then
      CopyMemory tNMH, ByVal lparam, Len(tNMH)
      If (tNMH.hwndFrom = m_hWnd) Then
         
         Select Case tNMH.code
         Case EN_SELCHANGE
            CopyMemory tSC, ByVal lparam, Len(tSC)
            RaiseEvent SelectionChange(tSC.chrg.cpMin, tSC.chrg.cpMax,
             tSC.seltyp)
            
         Case EN_LINK
            CopyMemory tEN, ByVal lparam, Len(tEN)
            RaiseEvent LinkOver(tEN.msg, tEN.chrg.cpMin, tEN.chrg.cpMax)
         
         Case EN_PROTECTED
            CopyMemory tPR, ByVal lparam, Len(tPR)
            bDoIt = False
            RaiseEvent ModifyProtected(bDoIt, tPR.chrg.cpMin, tPR.chrg.cpMax)
            If (bDoIt) Then
               ISubclass_WindowProc = 0
            Else
               ISubclass_WindowProc = 1
            End If
            
         Case EN_MSGFILTER
            bDefault = True
            CopyMemory tMF, ByVal lparam, Len(tMF)
            Select Case tMF.msg
            Case 515
               'Debug.Print "Double click", tMF.lParam, tMF.wPad2
               GetCursorPos tP
               ScreenToClient m_hWnd, tP
               x = tP.x * Screen.TwipsPerPixelX
               y = tP.y * Screen.TwipsPerPixelY
               RaiseEvent DblClick(x, y)
            Case 33
               iShift = giGetShiftState()
               GetCursorPos tP
               ScreenToClient m_hWnd, tP
               x = tP.x * Screen.TwipsPerPixelX
               y = tP.y * Screen.TwipsPerPixelY
               RaiseEvent MouseDown(x, y, iShift)
            Case 514
               iShift = giGetShiftState()
               GetCursorPos tP
               ScreenToClient m_hWnd, tP
               x = tP.x * Screen.TwipsPerPixelX
               y = tP.y * Screen.TwipsPerPixelY
               RaiseEvent MouseUp(x, y, iShift)
            Case 512
               iShift = giGetShiftState()
               GetCursorPos tP
               ScreenToClient m_hWnd, tP
               x = tP.x * Screen.TwipsPerPixelX
               y = tP.y * Screen.TwipsPerPixelY
               RaiseEvent MouseMove(x, y, iShift)
            Case 256
               'Debug.Print "KEYDOWN", tMF.wParam
               iShift = giGetShiftState()
               iKeyCode = tMF.wParam
               RaiseEvent KeyDown(iKeyCode, iShift)
               If Not (pDoDefault(iKeyCode, iShift, bDefault)) Then
                  If (iKeyCode <> tMF.wParam) Then
                     bDefault = False
                  End If
               End If
            Case 258
               iShift = giGetShiftState()
               iKeyAscii = tMF.wParam
               ' Debug.Print iKeyAscii, iShift
               If Not (pDoDefault(iKeyAscii, iShift, bDefault)) Then
                  RaiseEvent KeyPress(iKeyAscii)
                  If (iKeyAscii <> tMF.wParam) Then
                     bDefault = False
                  End If
               End If
            Case 257
               iShift = giGetShiftState()
               iKeyCode = tMF.wParam
               RaiseEvent KeyUp(iKeyCode, iShift)
            Case Else
               ' Debug.Print "Something Different:", tMF.msg, tMF.wParam,
                tMF.lParam, tMF.wPad1, tMF.wPad2
            End Select
            If Not bDefault Then
               ' Debug.Print "No default.."
               ISubclass_WindowProc = 1&
            End If
         End Select
         
      End If
      
   ElseIf (iMsg = WM_VSCROLL) Then
      RaiseEvent VScroll
      
   ElseIf (iMsg = WM_HSCROLL) Then
      RaiseEvent HScroll
      
   ElseIf (iMsg = WM_SETFOCUS) Then
      ' Debug.Print lParam, wParam
      UserControl.SetFocus
      If (wParam <> 0) Then
         SendMessageLong wParam, WM_KILLFOCUS, m_hWnd, 0
      End If
      SetFocusAPI m_hWnd
      
   ElseIf (iMsg = WM_PAINT) Then
      ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lparam)
      
   ElseIf (iMsg = WM_DESTROY) Then
      pTerminate
      
   End If
      
End Function


Private Sub UserControl_Initialize()
Dim i As Long
   Debug.Print "RichEditControl:Initialise"
   ' Default printing margins for an RTF file:
   m_lLeftMargin = 1800
   m_lRightMargin = 1800
   m_lTopMargin = 1440
   m_lBottomMargin = 1440
   ' Default to the simplistic version of RichEdti:
   m_eVersion = eRICHED32
   ' Redraw the control:
   m_bRedraw = True
   ' Allow all in-built shortcuts:
   For i = ERECInbuiltShortcutConstants.[_First] To
    ERECInbuiltShortcutConstants.[_Last]
      m_bAllowMethod(i) = True
   Next i
   lblText.Caption = "vbAccelerator Rich Edit Control"
End Sub

Private Sub UserControl_InitProperties()
    pInitialise
    m_eCharFormatRange = ercSetFormatAll
    Set Font = UserControl.Ambient.Font
    m_eCharFormatRange = ercSetFormatSelection
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
   ' Debug.Print KeyCode
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   If (UserControl.Ambient.UserMode) Then
      m_eVersion = PropBag.ReadProperty("Version", eRICHED32)
   Else
      UseVersion = PropBag.ReadProperty("Version", eRICHED32)
   End If
   Border = PropBag.ReadProperty("Border", True)
   pInitialise
   m_eCharFormatRange = ercSetFormatSelection
   Dim sFnt As New StdFont
   On Error Resume Next
   Set Font = PropBag.ReadProperty("Font")
   Err.Clear
   On Error GoTo 0
   m_eCharFormatRange = ercSetFormatSelection

   BackColor = PropBag.ReadProperty("BackColor", vbWindowBackground)
   ForeColor = PropBag.ReadProperty("ForeColor", vbWindowText)
   Text = PropBag.ReadProperty("Text", "")
   ViewMode = PropBag.ReadProperty("ViewMode", ercWordWrap)
   If (UserControl.Ambient.UserMode) Then
      lblText.Visible = False
   Else
      lblText.Visible = True
   End If
End Sub

Private Sub UserControl_Resize()
Dim tR As RECT
   If (m_hWnd <> 0) Then
      MoveWindow m_hWnd, 0, 0, UserControl.ScaleWidth \ Screen.TwipsPerPixelX,
       UserControl.ScaleHeight \ Screen.TwipsPerPixelY, Abs(m_bRedraw)
      tR.Left = 4
      tR.Right = UserControl.ScaleWidth \ Screen.TwipsPerPixelX - 4
      If (tR.Right < tR.Left) Then tR.Right = tR.Left
      tR.Top = 4
      tR.Bottom = UserControl.ScaleHeight \ Screen.TwipsPerPixelY
      SendMessage m_hWnd, EM_SETRECT, 0, tR
   Else
      lblText.Move 4 * Screen.TwipsPerPixelX, 4 * Screen.TwipsPerPixelY,
       UserControl.ScaleWidth - 4 * Screen.TwipsPerPixelX,
       UserControl.ScaleHeight - 4 * Screen.TwipsPerPixelY
   End If
End Sub

Private Sub UserControl_Terminate()
    Debug.Print "RichEditControl:Terminate"
    pTerminate
End Sub


Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   PropBag.WriteProperty "Version", UseVersion, eRICHED32
   m_eCharFormatRange = ercSetFormatAll
   PropBag.WriteProperty "Font", Font
   PropBag.WriteProperty "BackColor", BackColor, vbWindowBackground
   PropBag.WriteProperty "ForeColor", ForeColor, vbWindowText
   PropBag.WriteProperty "Text", m_sText, ""
   PropBag.WriteProperty "ViewMode", ViewMode
   PropBag.WriteProperty "Border", Border, True
End Sub