www.pudn.com > Super_richBoxall.zip > VBRichEdit.ctl
VERSION 5.00
Begin VB.UserControl vbalRichEdit
BackColor = &H80000005&
ClientHeight = 3600
ClientLeft = 0
ClientTop = 0
ClientWidth = 5055
ScaleHeight = 3600
ScaleWidth = 5055
ToolboxBitmap = "VBRichEdit.ctx":0000
Begin VB.Label lblText
BackStyle = 0 'Transparent
Caption = "vbAccelerator Rich Edit Control"
Height = 255
Left = 60
TabIndex = 0
Top = 60
Width = 4875
End
End
Attribute VB_Name = "vbalRichEdit"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
' ======================================================================
' Visit vbAccelerator at http://vbaccelerator.com/
' - the VB Programmer's Resource
' ======================================================================
' ======================================================================
' vbalRichEdit
' Copyright © 1998 Steve McMahon (steve@vbaccelerator.com)
' 14 June 1998
'
' An lightweight RichEdit control all in VB with lots of great features
' Requires:
' mRichEdit.Bas
' mWinGeneral.Bas
' SSUBTMR.DLL
' ======================================================================
' ======================================================================
' 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
Public Enum ERECLinkEventTypeCOnstants
ercLButtonDblClick = WM_LBUTTONDBLCLK
ercLButtonDown = WM_LBUTTONDOWN
ercLButtonUp = WM_LBUTTONUP
ercMouseMove = WM_MOUSEMOVE
ercRButtonDblClick = WM_RBUTTONDBLCLK
ercRButtonDown = WM_RBUTTONDOWN
ercRBUttonUp = WM_RBUTTONUP
ercSetCursor = WM_SETCURSOR
End Enum
Public Enum ERECScrollBarConstants
ercScrollBarsNone = 1
ercScrollBarsHorizontal
ercScrollBarsVertical
ercScrollBarsBoth
End Enum
' ======================================================================
' Internal Control Variables:
' ======================================================================
Private m_hWnd As Long
Private m_hWndParent As Long
Private m_hWndForm As Long
Private m_bRunTime As Boolean
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
Private m_lLeftMarginPixels As Long
Private m_lRightMarginPixels As Long
Private m_lLimit As Long
Private m_bTrapTab As Boolean
Private m_bAutoURLDetect As Boolean
Private m_bReadOnly As Boolean
Private m_bTextOnly As Boolean
Private m_bTransparent As Boolean
Private m_bSingleLine As Boolean
Private m_bDisableNoScroll As Boolean
Private m_bPassword As Boolean
Private m_sPasswordChar As String
Private m_eScrollBars As ERECScrollBarConstants
Private m_bHideSelection As Boolean
Private m_bEnabled As Boolean
' Over-riding VB UserControl's default IOLEInPlaceActivate:
Private m_IPAOHookStruct As IPAOHookStruct
' Tiling images
Private m_cTile As cTile
' ======================================================================
' Events:
' ======================================================================
Public Event SelectionChange(ByVal lMin As Long, ByVal lMax As Long, ByVal eSelType As ERECSelectionTypeConstants)
Attribute SelectionChange.VB_Description = "Raised when the current selection changes."
Public Event LinkOver(ByVal iType As ERECLinkEventTypeCOnstants, ByVal lMin As Long, ByVal lMax As Long)
Attribute LinkOver.VB_Description = "Raised when the user moves the mouse over a hyperlink."
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Attribute KeyDown.VB_Description = "Raised when the user depresses a key on the control."
Public Event KeyPress(KeyAscii As Integer)
Attribute KeyPress.VB_Description = "Raised when the user depresses a character key on the control and the key has been converted into an Ascii code."
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Attribute KeyUp.VB_Description = "Raised when the user releases a key on the control."
Public Event DblClick(x As Single, y As Single)
Attribute DblClick.VB_Description = "Raised when the control is double clicked."
Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
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)
Attribute ModifyProtected.VB_Description = "Raised when the user attempts to modify text marked as protected. Set bDoIt to True to accept the modification."
Public Event VScroll()
Attribute VScroll.VB_Description = "Raised when the control is scrolled vertically."
Public Event HScroll()
Attribute HScroll.VB_Description = "Raised when the control is scrolled horizontally."
Public Event Change()
' ======================================================================
' Subclassing:
' ======================================================================
Implements ISubclass
Private m_emr As EMsgResponse
Public Property Get ScrollBars() As ERECScrollBarConstants
ScrollBars = m_eScrollBars
End Property
Public Property Let ScrollBars(ByVal eBars As ERECScrollBarConstants)
If m_hWnd <> 0 Then
Select Case eBars
Case ercScrollBarsNone
If pSetStyle(WS_HSCROLL Or WS_VSCROLL, False) Then
m_eScrollBars = eBars
End If
Case ercScrollBarsVertical
If pSetStyle(WS_HSCROLL, False) Then
If pSetStyle(WS_VSCROLL, True) Then
m_eScrollBars = eBars
End If
End If
Case ercScrollBarsHorizontal
If pSetStyle(WS_HSCROLL, True) Then
If pSetStyle(WS_VSCROLL, False) Then
m_eScrollBars = eBars
End If
End If
Case ercScrollBarsBoth
If pSetStyle(WS_HSCROLL Or WS_VSCROLL, True) Then
m_eScrollBars = eBars
End If
End Select
Else
m_eScrollBars = eBars
End If
End Property
Public Property Get DisableNoScroll() As Boolean
DisableNoScroll = m_bDisableNoScroll
End Property
Public Property Let DisableNoScroll(ByVal bState As Boolean)
If m_hWnd <> 0 Then
If pSetStyle(ES_DISABLENOSCROLL, m_bDisableNoScroll) Then
m_bDisableNoScroll = bState
End If
Else
m_bDisableNoScroll = bState
End If
PropertyChanged "DisableNoScroll"
End Property
Public Property Get HideSelection() As Boolean
HideSelection = m_bHideSelection
End Property
Public Property Let HideSelection(ByVal bState As Boolean)
If m_hWnd <> 0 Then
If pSetStyle(ES_NOHIDESEL, Not (bState)) Then
m_bHideSelection = bState
End If
Else
m_bHideSelection = bState
End If
PropertyChanged "HideSelection"
End Property
Public Property Get SingleLine() As Boolean
SingleLine = m_bSingleLine
End Property
Public Property Let SingleLine(ByVal bState As Boolean)
If m_hWnd <> 0 Then
If pSetStyle(ES_MULTILINE, Not (bState)) Then
m_bSingleLine = bState
End If
Else
m_bSingleLine = bState
End If
PropertyChanged "SingleLine"
End Property
Public Property Get PasswordChar() As String
PasswordChar = m_sPasswordChar
End Property
Public Property Let PasswordChar(ByVal sChar As String)
' Validate
If Len(sChar) > 1 Then sChar = Left$(sChar, 1)
' set it:
If Len(sChar) > 0 Then
If m_hWnd <> 0 Then
If pSetStyle(ES_PASSWORD, True) Then
SendMessageLong m_hWnd, EM_SETPASSWORDCHAR, Asc(sChar), 0
m_bPassword = True
m_sPasswordChar = sChar
End If
Else
m_bPassword = True
m_sPasswordChar = sChar
End If
Else
If m_hWnd <> 0 Then
m_bPassword = False
m_sPasswordChar = ""
SendMessageLong m_hWnd, EM_SETPASSWORDCHAR, 0, 0
Else
m_bPassword = False
m_sPasswordChar = ""
End If
End If
PropertyChanged "PasswordChar"
End Property
Private Function pSetStyle(ByVal lStyle As Long, ByVal bState As Boolean) As Boolean
Dim lS As Long
' Get current style:
lS = GetWindowLong(m_hWnd, GWL_STYLE)
' Apply the flag:
If bState Then
lS = lS Or lStyle
Else
lS = lS And Not lStyle
End If
' Set the style:
SetWindowLong m_hWnd, GWL_STYLE, lS
' Force window to notice style change:
pStyleChanged
' Success?
pSetStyle = (GetWindowLong(m_hWnd, GWL_STYLE) = lS)
End Function
Public Property Get Enabled() As Boolean
Enabled = m_bEnabled
End Property
Public Property Let Enabled(ByVal bState As Boolean)
m_bEnabled = bState
UserControl.Enabled = bState
If Not m_hWnd = 0 Then
EnableWindow m_hWnd, Abs(bState)
End If
PropertyChanged "Enabled"
End Property
Public Property Set Picture(ByRef sPic As IPicture)
Attribute Picture.VB_Description = "Gets/sets the background picture tiled behind the control when Transparent is set to True."
If m_hWnd = 0 Then
Set UserControl.Picture = sPic
Else
m_cTile.Picture = sPic
End If
PropertyChanged "Picture"
End Property
Public Property Let Picture(ByRef sPic As IPicture)
If m_hWnd = 0 Then
Set UserControl.Picture = sPic
Else
m_cTile.Picture = sPic
End If
PropertyChanged "Picture"
End Property
Public Property Get Picture() As IPicture
Set Picture = UserControl.Picture
End Property
Public Property Get Transparent() As Boolean
Attribute Transparent.VB_Description = "Gets/sets whether the control is transparent and displays the Picture or not."
Transparent = m_bTransparent
End Property
Public Property Let Transparent(ByVal bState As Boolean)
Dim lS As Long
m_bTransparent = bState
If m_hWnd <> 0 Then
lS = GetWindowLong(m_hWnd, GWL_EXSTYLE)
If bState Then
lS = lS Or WS_EX_TRANSPARENT
Else
lS = lS And Not WS_EX_TRANSPARENT
End If
SetWindowLong m_hWnd, GWL_EXSTYLE, lS
pStyleChanged
End If
PropertyChanged "Transparent"
End Property
Private Sub pStyleChanged(Optional ByVal hwnd As Long = 0)
If hwnd = 0 Then hwnd = m_hWnd
SetWindowPos m_hWnd, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOOWNERZORDER Or SWP_NOZORDER Or SWP_NOACTIVATE
End Sub
Friend Function TranslateAccelerator(lpMsg As VBOleGuids.msg) As Long
TranslateAccelerator = S_FALSE
If m_hWnd <> 0 Then
' Here you can modify the response to the key down
' accelerator command using the values in lpMsg. This
' can be used to capture Tabs, Returns, Arrows etc.
' Just process the message as required and return S_OK.
If lpMsg.message = WM_KEYDOWN Or lpMsg.message = WM_CHAR Or lpMsg.message = WM_KEYUP Then
Select Case lpMsg.wParam And &HFFFF&
Case vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, vbKeyPageDown, vbKeyPageUp, vbKeyHome, vbKeyEnd, vbKeyReturn
SendMessageLong m_hWnd, lpMsg.message, lpMsg.wParam, lpMsg.lParam
TranslateAccelerator = S_OK
Case vbKeyTab
If Not ReadOnly Then
If m_bTrapTab Then
' Allow shift-tab to move out of control:
If GetAsyncKeyState(vbKeyShift) = 0 Then
' Default handling of tab:
If lpMsg.message = WM_KEYDOWN Then
SendMessageLong m_hWnd, WM_CHAR, lpMsg.wParam, lpMsg.lParam
End If
TranslateAccelerator = S_OK
End If
End If
End If
End Select
End If
End If
End Function
Public Property Get TrapTab() As Boolean
Attribute TrapTab.VB_Description = "Gets/sets whether the control traps the tab key or not."
TrapTab = m_bTrapTab
End Property
Public Property Let TrapTab(ByVal bState As Boolean)
m_bTrapTab = bState
PropertyChanged "TrapTab"
End Property
Public Property Get TextLimit() As Long
Attribute TextLimit.VB_Description = "Same as MaxLength (!)"
TextLimit = m_lLimit
End Property
Public Property Let TextLimit(ByVal lLimit As Long)
Dim lR As Long
m_lLimit = lLimit
If m_hWnd <> 0 Then
lR = SendMessageLong(m_hWnd, EM_EXLIMITTEXT, 0, lLimit)
End If
PropertyChanged "TextLimit"
End Property
Public Property Get MaxLength() As Long
Attribute MaxLength.VB_Description = "Gets/sets the maximum length of text or RTF loaded into the control."
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
Attribute Border.VB_Description = "Gets/sets whether the control has a 3D border."
Border = m_bBorder
End Property
Public Property Let Border(ByVal bState As Boolean)
Dim dwStyle As Long
Dim dwExStyle As Long
m_bBorder = bState
If m_hWnd <> 0 Then
' Make sure that the RichEdit never has a border:
dwStyle = GetWindowLong(m_hWnd, GWL_STYLE)
dwExStyle = GetWindowLong(m_hWnd, GWL_EXSTYLE)
dwStyle = dwStyle And Not ES_SUNKEN
dwExStyle = dwExStyle And Not WS_EX_CLIENTEDGE
SetWindowLong m_hWnd, GWL_STYLE, dwStyle
SetWindowLong m_hWnd, GWL_EXSTYLE, dwExStyle
pStyleChanged
End If
UserControl.BorderStyle() = Abs(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
Attribute FindText.VB_Description = "Finds the specified text in the control."
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
Attribute Font.VB_Description = "Gets/sets the font of the control or selection, depending on the setting of CharFormatRange."
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
Attribute BackColor.VB_Description = "Gets/sets the background colour of the control."
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
Attribute ForeColor.VB_Description = "Gets/sets the forecolour of the control."
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
Attribute Text.VB_Description = "Gets the text contained in the control."
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
Attribute Modified.VB_Description = "Gets/sets whether the contents of the control have been modified."
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 TextOnly() As Boolean
Attribute TextOnly.VB_Description = "Gets/sets whether the control acts as a text-only control or not."
If m_eVersion = eRICHED20 Then
TextOnly = m_bTextOnly
Else
Unsupported
End If
End Property
Public Property Let TextOnly(ByVal bTextOnly As Boolean)
Dim lStyle As Long
If m_eVersion = eRICHED20 Then
m_bTextOnly = bTextOnly
If m_hWnd <> 0 Then
If m_bTextOnly Then
lStyle = TM_PLAINTEXT Or TM_MULTILEVELUNDO Or TM_MULTICODEPAGE
Else
lStyle = TM_RICHTEXT Or TM_MULTILEVELUNDO Or TM_MULTICODEPAGE
End If
SendMessageLong m_hWnd, EM_SETTEXTMODE, lStyle, 0
End If
PropertyChanged "TextOnly"
Else
Unsupported
End If
End Property
Public Property Get RichEditOption( _
ByVal eOption As ERECOptionTypeConstants _
) As Boolean
Attribute RichEditOption.VB_Description = "Gets/sets various options affecting the operation of the RichEdit control."
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
Attribute LineForCharacterIndex.VB_Description = "Same as LineForCharacter (!)"
LineForCharacterIndex = (SendMessageLong(m_hWnd, EM_EXLINEFROMCHAR, 0, lIndex))
End Property
Private Function Unsupported(Optional ByVal iType As Integer = 0)
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 Function
Public Property Get SelectedText() As String
Attribute SelectedText.VB_Description = "Gets the selected text from the control."
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 SelectedContents(ByVal eType As ERECFileTypes) As String
Attribute SelectedContents.VB_Description = "Gets the text or RichText in the current selection in the control."
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
SelectedContents = StreamText()
m_eProgressType = ercNone
End Property
Public Property Get TextInRange(ByVal lStart As Long, ByVal lEnd As Long)
Attribute TextInRange.VB_Description = "Gets the text in a specified range without changing the selection."
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)
Attribute AutoURLDetect.VB_Description = "Gets/sets whether the control will automatically detect hyperlinks prefixed by certain URL identifiers (e.g. http:)"
Dim lR As Long
If (m_eVersion = eRICHED20) Then
m_bAutoURLDetect = bState
If m_hWnd <> 0 Then
lR = SendMessageLong(m_hWnd, EM_AUTOURLDETECT, Abs(bState), 0)
Debug.Assert (lR = 0)
End If
PropertyChanged m_bAutoURLDetect
Else
Unsupported
End If
End Property
Public Property Get AutoURLDetect() As Boolean
AutoURLDetect = m_bAutoURLDetect
End Property
Public Property Let ReadOnly(ByVal bState As Boolean)
Attribute ReadOnly.VB_Description = "Gets/sets whether the control is read-only."
m_bReadOnly = bState
If m_hWnd <> 0 Then
SendMessageLong m_hWnd, EM_SETREADONLY, Abs(bState), 0
End If
PropertyChanged "ReadOnly"
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
Attribute LineCount.VB_Description = "Returns the number of lines in the control."
LineCount = SendMessageLong(m_hWnd, EM_GETLINECOUNT, 0, 0)
End Property
Public Property Get FirstVisibleLine() As Long
Attribute FirstVisibleLine.VB_Description = "Gets the 0 based index of the first visible line within the control."
FirstVisibleLine = SendMessageLong(m_hWnd, EM_GETFIRSTVISIBLELINE, 0, 0)
End Property
Public Property Get CurrentLine() As Long
Attribute CurrentLine.VB_Description = "Gets the 0 based index of the line containing the cursor."
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)
Attribute LineForCharacter.VB_Description = "Gets the line containing the specified 0 based character index."
' Use EX to ensure we can cope with > 32k text
LineForCharacter = SendMessageLong(m_hWnd, EM_EXLINEFROMCHAR, 0, lCharacter)
End Property
Public Property Get CharFromPos(ByVal xPixels As Long, ByVal yPixels As Long)
Attribute CharFromPos.VB_Description = "Gets the 0 based index of the character at the specified position in pixels."
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)
Attribute GetPosFromChar.VB_Description = "Returns the position in pixels for a given 0 based character index."
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)
Attribute GetSelection.VB_Description = "Gets the start and end of the current position."
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)
Attribute SetSelection.VB_Description = "Sets the current selection."
Dim tCR As CHARRANGE
tCR.cpMin = lStart
tCR.cpMax = lEnd
SendMessage m_hWnd, EM_EXSETSEL, 0, tCR
End Sub
Public Sub SelectAll()
Attribute SelectAll.VB_Description = "Selects the contents of the control."
SetSelection 0, -1
End Sub
Public Sub SelectNone()
Attribute SelectNone.VB_Description = "Clears any selection in the control."
Dim tc As CHARRANGE
tc.cpMax = 0
tc.cpMin = 0
SendMessage m_hWnd, EM_EXSETSEL, 0, tc
End Sub
Public Property Get CanPaste() As Boolean
Attribute CanPaste.VB_Description = "Returns whether Pasting is possible."
CanPaste = SendMessageLong(m_hWnd, EM_CANPASTE, 0, 0)
End Property
Public Property Get CanCopy() As Boolean
Attribute CanCopy.VB_Description = "Returns whether the copying is possible."
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
Attribute CanUndo.VB_Description = "Returns whether an Undo operation is possible."
CanUndo = SendMessageLong(m_hWnd, EM_CANUNDO, 0, 0)
End Property
Public Property Get CanRedo() As Boolean
Attribute CanRedo.VB_Description = "Returns whether a Redo operation is possible."
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
Attribute UndoType.VB_Description = "Gets the type of action which will be undone."
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
Attribute RedoType.VB_Description = "Gets the type of action which will be redone."
If m_eVersion = eRICHED20 Then
RedoType = SendMessageLong(m_hWnd, EM_GETREDONAME, 0, 0)
Else
Unsupported
End If
End Property
Public Sub Cut()
Attribute Cut.VB_Description = "Performs the control's copy operation. Check CanCut to see if it is possible to cut."
SendMessageLong m_hWnd, WM_CUT, 0, 0
End Sub
Public Sub Copy()
Attribute Copy.VB_Description = "Performs the control's copy operation. Check CanCopy to see if it is possible to copy."
SendMessageLong m_hWnd, WM_COPY, 0, 0
End Sub
Public Sub Paste()
Attribute Paste.VB_Description = "Performs the control's Paste action. Use CanPaste to determine if the Paste action can be performed."
SendMessageLong m_hWnd, WM_PASTE, 0, 0
End Sub
Public Sub PasteSpecial()
Attribute PasteSpecial.VB_Description = ""
SendMessageLong m_hWnd, EM_PASTESPECIAL, 0, 0
End Sub
Public Sub Undo()
Attribute Undo.VB_Description = "Performs the control's Undo action. Check the CanUndo property to see if the Undo action can be performed."
SendMessageLong m_hWnd, EM_UNDO, 0, 0
End Sub
Public Sub Redo()
Attribute Redo.VB_Description = "Performs the control's Redo action. Check the CanRedo property to see if this action is available."
If (m_eVersion = eRICHED20) Then
SendMessageLong m_hWnd, EM_REDO, 0, 0
Else
Unsupported
End If
End Sub
Public Sub Delete()
Attribute Delete.VB_Description = "Performs the control's delete operation. Check CanCut to see if it is possible to delete."
' TODO
End Sub
Public Sub InsertContents(ByVal eType As ERECFileTypes, ByRef sText As String)
Attribute InsertContents.VB_Description = "Inserts a text or RTF string into the control."
Dim tStream As EDITSTREAM
Dim lR As Long
' Don't redraw:
Redraw = False
' 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)
' Redraw again:
Redraw = True
End Sub
Public Property Get ViewMode() As ERECViewModes
Attribute ViewMode.VB_Description = "Gets/sets who the control lays out the text on screen."
ViewMode = m_eViewMode
End Property
Public Property Let ViewMode(ByVal eViewMode As ERECViewModes)
If (eViewMode <> m_eViewMode) Then
m_eViewMode = eViewMode
pSetViewMode eViewMode
End If
End Property
Private Sub pSetViewMode(ByVal eViewMode As ERECViewModes)
Select Case m_eViewMode
Case ercWYSIWYG
On Error Resume Next
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 Sub
Public Property Get CharFormatRange() As ERECSetFormatRange
Attribute CharFormatRange.VB_Description = "Gets/sets the range to which font formatting will apply."
CharFormatRange = m_eCharFormatRange
End Property
Public Property Let CharFormatRange(ByVal eRange As ERECSetFormatRange)
m_eCharFormatRange = eRange
End Property
Public Property Get CharacterCount() As Long
Attribute CharacterCount.VB_Description = "Returns the number of characters of text in the control."
If m_eVersion = eRICHED20 Then
CharacterCount = SendMessageLong(m_hWnd, WM_GETTEXTLENGTH, 0, 0)
Else
CharacterCount = SendMessageLong(m_hWnd, EM_GETTEXTLENGTHEX, 0, 0)
End If
End Property
Public Property Get FontBold() As Boolean
Attribute FontBold.VB_Description = "Gets/sets whether the font is bold for the control or selection, depending on the setting of CharFormatRange."
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_Description = "Gets/sets whether the font is italic for the control or selection, depending on the setting of CharFormatRange."
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_Description = "Gets/sets whether the font is underlined for the control or selection, depending on the setting of CharFormatRange."
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_Description = "Gets/sets whether the font is struck out for the control or selection, depending on the setting of CharFormatRange."
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_Description = "Gets/sets the colour of the font for the control or selection, depending on the setting of CharFormatRange."
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
If oColour = -1 Then
tCF.dwMask = CFM_COLOR
tCF.dwEffects = CFE_AUTOCOLOR
tCF.crTextColor = -1
Else
tCF.crTextColor = TranslateColor(oColour)
tCF.dwMask = CFM_COLOR
End If
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_Description = "Gets/sets the background colour of the control or selection, depending on the setting of CharFormatRange."
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
If oColor = -1 Then
tCF2.dwMask = CFM_BACKCOLOR
tCF2.dwEffects = CFE_AUTOBACKCOLOR
tCF2.crBackColor = -1
Else
tCF2.dwMask = CFM_BACKCOLOR
tCF2.crBackColor = TranslateColor(oColor)
End If
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_Description = "Gets/sets whether the selection acts as a hyperlink. Set CharFormatRange to selection."
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_Description = "Gets/sets whether the selection is protected (raises the ModifyRequest event). Set CharFormatRange to selection."
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_Description = "Gets/sets whether the font is superscripted for the control or selection, depending on the setting of CharFormatRange."
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)
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_Description = "Gets/sets whether the font is subscripted for the control or selection, depending on the setting of CharFormatRange."
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)
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.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
sFnt.Name = sName
End If
Set GetFont = sFnt
End Function
Public Property Get ParagraphNumbering() As ERECParagraphNumberingConstants
Attribute ParagraphNumbering.VB_Description = "Gets/sets whether the selected paragraph has bullets or not."
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 _
)
Attribute GetParagraphOffsets.VB_Description = "Gets the paragraph offsets (left, right and initial line)."
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 _
)
Attribute SetParagraphOffsets.VB_Description = "Sets the offsets (left, right and initial line) for the current paragraph."
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
Attribute ParagraphAlignment.VB_Description = "Gets/Sets the alignment of the selected paragraph."
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 _
)
Attribute GetParagraphTabs.VB_Description = "Gets the tab stops for the current paragraph."
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 _
)
Attribute SetParagraphTabs.VB_Description = "Sets tab stops for the current paragraph."
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 _
)
Attribute GetParagraphLineSpacing.VB_Description = "Gets the line spacing for the current paragraph."
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 _
)
Attribute SetParagraphLineSpacing.VB_Description = "Sets the line spacing for the current paragraph."
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 _
)
Attribute GetParagraphSpacing.VB_Description = "Gets the spacing between paragraphs for the current paragraph."
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 _
)
Attribute SetParagraphSpacing.VB_Description = "Sets the spacing between paragraphs for the current paragraph."
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)
Attribute UseVersion.VB_Description = "Gets/sets which version of the RichEdit DLL to use: version 2/3 (RichEd20.DLL) or version 1 (RichEd32.DLL)"
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
Attribute IsRtf.VB_Description = "Returns whether the specified string contains RTF."
If (Left$(sFileText, 5) = "{\rtf") Then
IsRtf = True
End If
End Property
Public Property Get Redraw() As Boolean
Attribute Redraw.VB_Description = "Gets/sets whether the control will redraw or not."
Redraw = m_bRedraw
End Property
Public Property Let Redraw(ByVal bState As Boolean)
If (m_bRedraw <> bState) Then
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
End If
m_bRedraw = bState
PropertyChanged "Redraw"
End Property
Public Property Let Contents(ByVal eType As ERECFileTypes, ByRef sContents As String)
Attribute Contents.VB_Description = "Gets/sets the control's contents from a string in RichText or Text format."
Dim tStream As EDITSTREAM
Dim lR As Long
m_eProgressType = ercLoad
Redraw = False
' 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
Redraw = True
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
Attribute LoadFromFile.VB_Description = "Loads a text or RTF file into the control."
Dim hFile As Long
Dim tOF As OFSTRUCT
Dim tStream As EDITSTREAM
Dim lR As Long
m_eProgressType = ercLoad
Redraw = False
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
Redraw = True
m_eProgressType = ercNone
End Function
Public Function SaveToFile( _
ByVal sFile As String, _
ByVal eType As ERECFileTypes _
) As Boolean
Attribute SaveToFile.VB_Description = "Saves the contents of the control to a text or RichText file."
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 _
)
Attribute PrintDocDC.VB_Description = "Prints the current document to a specified DC."
Dim fr As FORMATRANGE
Dim lTextOut As Long, lTextAmt As Long
Dim lLastTextOut As Long
Dim hJob As Long
Dim lR As Long
Dim lMin As Long
Dim lWidth As Long, lHeight As Long
Dim lLeft As Long, lTop As Long
Dim lXOffset As Long, lYOffset As Long
Dim lPixelsX As Long, lPixelsY As Long
Dim iPage As Long
Dim rcPage As RECT, rcRender As RECT
Dim lSavedState As Long
m_eProgressType = ercPrint
'// Fill out the DOCINFO structure.
Dim b() As Byte
Dim di As DOCINFO
di.cbSize = Len(di)
di.lpszOutput = 0
' This need sorting out.
If (sDocTitle = "") Then
sDocTitle = "RTF Document (vbAccelerator RichEdit control)"
End If
b = StrConv(sDocTitle, vbFromUnicode)
ReDim Preserve b(0 To UBound(b) + 1) As Byte
di.lpszDocName = VarPtr(b(0))
'// 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:
lWidth = MulDiv(GetDeviceCaps(lPrinterHDC, PHYSICALWIDTH), 1440, lPixelsX)
' This is the number of pixels down:
lHeight = MulDiv(GetDeviceCaps(lPrinterHDC, PHYSICALHEIGHT), 1440, lPixelsY)
rcPage.Right = lWidth
rcPage.Bottom = lHeight
' Save DC so we can restore it later to the initial state:
lSavedState = SaveDC(fr.hdc)
' Ensure printer DC is in text mode:
SetMapMode fr.hdc, MM_TEXT
' Evaluate the left and right physical offsets:
lXOffset = -GetDeviceCaps(lPrinterHDC, PHYSICALOFFSETX)
lYOffset = -GetDeviceCaps(lPrinterHDC, PHYSICALOFFSETY)
lLeft = MulDiv(m_lLeftMargin, lPixelsX, 1440)
lLeft = lLeft + lXOffset
If lLeft < 0 Then lLeft = 0
lTop = MulDiv(m_lTopMargin, lPixelsY, 1440)
lTop = lTop + lYOffset
If lTop < 0 Then lTop = 0
rcRender.Right = lWidth - m_lRightMargin - m_lLeftMargin
rcRender.Bottom = lHeight - m_lBottomMargin - m_lTopMargin
' Adjust the DC left,top according to the x & y offset:
SetViewportOrgEx fr.hdc, lLeft, lTop, ByVal 0&
' Get the text out range:
lTextOut = 0
lTextAmt = CharacterCount()
' Clear the formatting buffer:
SendMessageLong m_hWnd, EM_FORMATRANGE, 0, 0
'
' Get each of the pages:
Dim tP() As FORMATRANGE
Dim lCount As Long
Dim bSkip As Boolean
If lTextAmt > 0 Then
fr.chrg.cpMin = 0
fr.chrg.cpMax = -1
lCount = 0
Do
' Work out the size of text to render:
LSet fr.rc = rcRender
LSet fr.rcPage = rcPage
lMin = fr.chrg.cpMin
lTextOut = SendMessage(m_hWnd, EM_FORMATRANGE, 0, fr)
fr.chrg.cpMin = lTextOut
If lCount > 0 Then
' This problem doesn't seem to get mentioned anywhere!
' If format range returns a smaller value than
' the last minimum, it has actually finished:
If lTextOut < lMin Then
fr.chrg.cpMin = lTextAmt
bSkip = True
End If
End If
If Not bSkip Then
' We cache the output rectangle and start &
' finish positions for subsequent printing:
lCount = lCount + 1
ReDim Preserve tP(1 To lCount) As FORMATRANGE
tP(lCount).chrg.cpMin = lMin
tP(lCount).chrg.cpMax = lTextOut - 1
LSet tP(lCount).rc = fr.rc
End If
Loop While fr.chrg.cpMin <> -1 And fr.chrg.cpMin < lTextAmt
End If
RestoreDC fr.hdc, -1
If nStartPage <= 0 Then
nStartPage = 1
ElseIf nStartPage > lCount Then
nStartPage = lCount
End If
If nEndPage <= 0 Then
nEndPage = lCount
ElseIf nEndPage > lCount Then
nEndPage = lCount
End If
RaiseEvent ProgressStatus(-1, -1)
hJob = StartDoc(lPrinterHDC, di)
If (hJob <> 0) Then
' Reset the output buffer:
SendMessage m_hWnd, EM_FORMATRANGE, 0, 0
For iPage = nStartPage To nEndPage
'If Not iPage = 1 Then
StartPage fr.hdc
'End If
' Return DC to printing condition:
lSavedState = SaveDC(fr.hdc)
SetMapMode fr.hdc, MM_TEXT
SetViewportOrgEx fr.hdc, lLeft, lTop, ByVal 0&
LSet fr.rc = tP(iPage).rc
LSet fr.rcPage = rcPage
LSet fr.chrg = tP(iPage).chrg
fr.chrg.cpMin = SendMessage(m_hWnd, EM_FORMATRANGE, 1, fr)
RestoreDC fr.hdc, -1
RaiseEvent ProgressStatus(lTextOut, lTextAmt)
EndPage fr.hdc
Next iPage
RaiseEvent ProgressStatus(lTextAmt, lTextAmt)
'// Reset the formatting of the rich edit control.
SendMessageLong m_hWnd, EM_FORMATRANGE, True, 0
EndDoc fr.hdc
Else
Debug.Print "Failed to start print job"
End If
End Sub
Public Sub PrintDoc( _
ByVal sDocTitle As String _
)
Attribute PrintDoc.VB_Description = "Prints the document after showing a Print Dialog."
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
Attribute hwnd.VB_Description = "Gets the Window handle of the control. If you want the handle of the RichEdit control itself, use RichEdithWnd instead."
hwnd = UserControl.hwnd
End Property
Public Property Get RichEdithWnd() As Long
Attribute RichEdithWnd.VB_Description = "Gets the Window Handle of the RichEdit control."
RichEdithWnd = m_hWnd
End Property
Public Sub SetFocus()
Attribute SetFocus.VB_Description = "Sets focus to the control."
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 And m_eVersion = eRICHED20 Then
' Fall back!
m_eVersion = eRICHED32
sLib = "RICHED32.DLL"
sClass = RICHEDIT_CLASS10A
m_hLib = LoadLibrary(sLib)
End If
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
If (m_bTransparent) Then
dwExStyle = dwExStyle Or WS_EX_TRANSPARENT
End If
'// Create the rich edit control.
Set m_cTile = New cTile
m_hWndParent = UserControl.hwnd
m_hWndForm = UserControl.Parent.hwnd
m_hWnd = CreateWindowEX( _
dwExStyle, _
sClass, _
"", _
dwStyle, _
0, 0, UserControl.ScaleWidth \ Screen.TwipsPerPixelX, UserControl.ScaleHeight \ Screen.TwipsPerPixelY, _
m_hWndParent, _
0, _
App.hInstance, _
0)
If (m_hWnd <> 0) Then
EnableWindow m_hWnd, 1
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
Set m_cTile = Nothing
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, m_hWndForm, WM_ACTIVATE
AttachMessage Me, m_hWndParent, WM_NOTIFY
AttachMessage Me, m_hWndParent, WM_SETFOCUS
AttachMessage Me, m_hWndParent, WM_PAINT
AttachMessage Me, m_hWndParent, WM_COMMAND
AttachMessage Me, m_hWnd, WM_ERASEBKGND
AttachMessage Me, m_hWnd, WM_SETFOCUS
AttachMessage Me, m_hWnd, WM_MOUSEACTIVATE
AttachMessage Me, m_hWnd, WM_VSCROLL
AttachMessage Me, m_hWnd, WM_HSCROLL
' 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
' Change:
dwMask = dwMask Or ENM_CHANGE
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, m_hWndForm, WM_ACTIVATE
DetachMessage Me, m_hWndParent, WM_NOTIFY
DetachMessage Me, m_hWndParent, WM_SETFOCUS
DetachMessage Me, m_hWndParent, WM_PAINT
DetachMessage Me, m_hWndParent, WM_COMMAND
DetachMessage Me, m_hWnd, WM_ERASEBKGND
DetachMessage Me, m_hWnd, WM_SETFOCUS
DetachMessage Me, m_hWnd, WM_MOUSEACTIVATE
DetachMessage Me, m_hWnd, WM_VSCROLL
DetachMessage Me, m_hWnd, WM_HSCROLL
m_bSubClassing = False
End If
End Sub
Public Property Get AllowShortCut(ByVal eShortCut As ERECInbuiltShortcutConstants) As Boolean
Attribute AllowShortCut.VB_Description = "Gets/sets whether the control will respond automatically to a keyboard accelerator."
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 _
)
Attribute GetPageMargins.VB_Description = "Gets the margins of the page when it is printed, in twips."
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 _
)
Attribute SetPageMargins.VB_Description = "Sets the margins for the printed page."
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
Public Property Let ControlRightMargin(ByVal lRightMarginPixels As Long)
Attribute ControlRightMargin.VB_Description = "Gets/sets the margin from the right hand edge of the control to the RichEdit control."
If (m_hWnd <> 0) Then
SendMessageLong m_hWnd, EM_SETMARGINS, EC_RIGHTMARGIN, lRightMarginPixels * &H10000
pSetViewMode m_eViewMode
End If
m_lRightMarginPixels = lRightMarginPixels
PropertyChanged "ControlRightMargin"
End Property
Public Property Get ControlRightMargin() As Long
ControlRightMargin = m_lRightMarginPixels
End Property
Public Property Let ControlLeftMargin(ByVal lLeftMarginPixels As Long)
Attribute ControlLeftMargin.VB_Description = "Gets/sets the margin from the left hand edge of the control to the RichEdit control."
If (m_hWnd <> 0) Then
SendMessageLong m_hWnd, EM_SETMARGINS, EC_LEFTMARGIN, lLeftMarginPixels
pSetViewMode m_eViewMode
End If
m_lLeftMarginPixels = lLeftMarginPixels
PropertyChanged "ControlLeftMargin"
End Property
Public Property Get ControlLeftMargin() As Long
ControlLeftMargin = m_lLeftMarginPixels
End Property
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 Sub pDrawBackground(ByVal lHDC As Long, ByRef tR As RECT)
Dim hBr As Long
If Not m_cTile.Picture Is Nothing Then
m_cTile.TileArea lHDC, tR.Left, tR.Top, tR.Right - tR.Left, tR.Bottom - tR.Top
Else
hBr = CreateSolidBrush(TranslateColor(BackColor))
FillRect lHDC, tR, hBr
DeleteObject hBr
End If
End Sub
Private Sub pClipScrollBars(ByRef tR As RECT)
Dim lS As Long
Dim bHorz As Boolean
Dim bVert As Boolean
Dim tWR As RECT
Dim lH As Long
Dim lW As Long
' This doesn't actually have the desired effect.
' Left in anyway in case I can work out how to do it
' properly. See pRedrawScrollBars
lS = GetWindowLong(m_hWnd, GWL_STYLE)
bHorz = ((lS And WS_HSCROLL) = WS_HSCROLL)
bVert = ((lS And WS_VSCROLL) = WS_VSCROLL)
If bHorz Or bVert Then
GetWindowRect m_hWnd, tWR
If bHorz Then
lH = GetSystemMetrics(SM_CYHSCROLL)
If tR.Bottom - tR.Top > tWR.Bottom - tWR.Top - lH Then
tR.Bottom = tR.Bottom - lH
End If
End If
If bVert Then
lW = GetSystemMetrics(SM_CXVSCROLL)
If tR.Right - tR.Left > tWR.Right - tWR.Left - lW Then
tR.Right = tR.Right - lW
End If
End If
End If
End Sub
Private Sub pRedrawScrollBars()
Dim lS As Long
Dim bHorz As Boolean
Dim bVert As Boolean
Dim tR As RECT
Dim lH As Long
Dim lW As Long
lS = GetWindowLong(m_hWnd, GWL_STYLE)
bHorz = ((lS And WS_HSCROLL) = WS_HSCROLL)
bVert = ((lS And WS_VSCROLL) = WS_VSCROLL)
If bHorz Or bVert Then
' unsubtle, but on deadline:
InvalidateRectAsNull m_hWndParent, 0&, 1
UpdateWindow m_hWndParent
InvalidateRectAsNull m_hWnd, 0&, 1
UpdateWindow m_hWnd
End If
End Sub
Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer.EMsgResponse)
'
End Property
Private Property Get ISubclass_MsgResponse() As SSubTimer.EMsgResponse
Select Case CurrentMessage
Case WM_MOUSEACTIVATE, WM_ERASEBKGND, WM_PAINT
ISubclass_MsgResponse = emrConsume
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 tR As RECT
Dim tPS As PAINTSTRUCT
Dim x As Single, y As Single
Dim iKeyCode As Integer, iKeyAscii As Integer, iShift As Integer
Dim iBtn As Integer
Dim bDefault As Boolean
Dim bDoIt As Boolean
Dim iD As Long
Dim bLock As Boolean
Dim iNotifyMsg As Long
Select Case iMsg
Case WM_COMMAND
iNotifyMsg = (wParam And &H7FFF0000) \ &H10000
Select Case iNotifyMsg
Case EN_CHANGE
RaiseEvent Change
End Select
Case WM_NOTIFY
CopyMemory tNMH, ByVal lParam, Len(tNMH)
If (tNMH.hwndFrom = m_hWnd) Then
Select Case tNMH.code
Case EN_UPDATE
Debug.Print "Update"
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 WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK
'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 WM_LBUTTONDOWN
iShift = giGetShiftState()
GetCursorPos tP
ScreenToClient m_hWnd, tP
x = tP.x * Screen.TwipsPerPixelX
y = tP.y * Screen.TwipsPerPixelY
RaiseEvent MouseDown(vbLeftButton, iShift, x, y)
Case WM_RBUTTONDOWN
iShift = giGetShiftState()
GetCursorPos tP
ScreenToClient m_hWnd, tP
x = tP.x * Screen.TwipsPerPixelX
y = tP.y * Screen.TwipsPerPixelY
RaiseEvent MouseDown(vbRightButton, iShift, x, y)
Case WM_MBUTTONDOWN
iShift = giGetShiftState()
GetCursorPos tP
ScreenToClient m_hWnd, tP
x = tP.x * Screen.TwipsPerPixelX
y = tP.y * Screen.TwipsPerPixelY
RaiseEvent MouseDown(vbMiddleButton, iShift, x, y)
Case WM_LBUTTONUP
iShift = giGetShiftState()
GetCursorPos tP
ScreenToClient m_hWnd, tP
x = tP.x * Screen.TwipsPerPixelX
y = tP.y * Screen.TwipsPerPixelY
RaiseEvent MouseUp(vbLeftButton, iShift, x, y)
Case WM_RBUTTONUP
iShift = giGetShiftState()
GetCursorPos tP
ScreenToClient m_hWnd, tP
x = tP.x * Screen.TwipsPerPixelX
y = tP.y * Screen.TwipsPerPixelY
RaiseEvent MouseUp(vbRightButton, iShift, x, y)
Case WM_MBUTTONUP
iShift = giGetShiftState()
GetCursorPos tP
ScreenToClient m_hWnd, tP
x = tP.x * Screen.TwipsPerPixelX
y = tP.y * Screen.TwipsPerPixelY
RaiseEvent MouseUp(vbMiddleButton, iShift, x, y)
Case WM_MOUSEMOVE
iShift = giGetShiftState()
iBtn = giGetMouseButton()
GetCursorPos tP
ScreenToClient m_hWnd, tP
x = tP.x * Screen.TwipsPerPixelX
y = tP.y * Screen.TwipsPerPixelY
RaiseEvent MouseMove(iBtn, iShift, x, y)
Case WM_KEYDOWN
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 WM_CHAR
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 WM_KEYUP
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
Case WM_VSCROLL
RaiseEvent VScroll
Case WM_HSCROLL
RaiseEvent HScroll
' ------------------------------------------------------------------------------
' Implement focus. Many many thanks to Mike Gainer for showing me this
' code.
Case WM_SETFOCUS
If (m_hWnd = hwnd) Then
' The RichEdit control:
Dim pOleObject As IOleObject
Dim pOleInPlaceSite As IOleInPlaceSite
Dim pOleInPlaceFrame As IOleInPlaceFrame
Dim pOleInPlaceUIWindow As IOleInPlaceUIWindow
Dim pOleInPlaceActiveObject As IOleInPlaceActiveObject
Dim PosRect As RECT
Dim ClipRect As RECT
Dim FrameInfo As OLEINPLACEFRAMEINFO
Dim grfModifiers As Long
Dim AcceleratorMsg As msg
'Get in-place frame and make sure it is set to our in-between
'implementation of IOleInPlaceActiveObject in order to catch
'TranslateAccelerator calls
Set pOleObject = Me
Set pOleInPlaceSite = pOleObject.GetClientSite
If Not pOleInPlaceSite Is Nothing Then
pOleInPlaceSite.GetWindowContext pOleInPlaceFrame, pOleInPlaceUIWindow, VarPtr(PosRect), VarPtr(ClipRect), VarPtr(FrameInfo)
If m_IPAOHookStruct.ThisPointer <> 0 Then
CopyMemory pOleInPlaceActiveObject, m_IPAOHookStruct.ThisPointer, 4
If Not pOleInPlaceActiveObject Is Nothing Then
If Not pOleInPlaceFrame Is Nothing Then
pOleInPlaceFrame.SetActiveObject pOleInPlaceActiveObject, vbNullString
If Not pOleInPlaceUIWindow Is Nothing Then
pOleInPlaceUIWindow.SetActiveObject pOleInPlaceActiveObject, vbNullString
End If
End If
End If
CopyMemory pOleInPlaceActiveObject, 0&, 4
End If
End If
Else
' THe user control:
SetFocusAPI m_hWnd
End If
Case WM_MOUSEACTIVATE
If GetFocus() <> m_hWnd Then
SetFocusAPI m_hWndParent
ISubclass_WindowProc = MA_NOACTIVATE
Else
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
End If
' End Implement focus.
' ------------------------------------------------------------------------------
Case WM_ERASEBKGND
If m_bTransparent Then
GetClientRect hwnd, tR
pClipScrollBars tR
pDrawBackground wParam, tR
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
Else
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
End If
Case WM_PAINT
If m_bTransparent Then
BeginPaint hwnd, tPS
pClipScrollBars tPS.rcPaint
pDrawBackground tPS.hdc, tPS.rcPaint
EndPaint hwnd, tPS
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
Else
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
End If
Case WM_ACTIVATE
If m_bTransparent Then
If wParam > 0 Then
pRedrawScrollBars
End If
End If
End Select
End Function
Private Sub UserControl_Initialize()
Dim i As Long
Debug.Print "RichEditControl:Initialise"
' Trap tab key:
m_bTrapTab = True
' Default printing margins for an RTF file:
m_lLeftMargin = 1800
m_lRightMargin = 1800
m_lTopMargin = 1440
m_lBottomMargin = 1440
' Default to the real version of RichEdit:
m_eVersion = eRICHED20
' 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"
' Default text limit
m_lLimit = 32767
' Enable!
m_bEnabled = True
' Attach custom IOleInPlaceActiveObject interface
Dim IPAO As IOleInPlaceActiveObject
With m_IPAOHookStruct
Set IPAO = Me
CopyMemory .IPAOReal, IPAO, 4
CopyMemory .TBEx, Me, 4
.lpVTable = IPAOVTable
.ThisPointer = VarPtr(m_IPAOHookStruct)
End With
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)
Dim eDefault As ERECScrollBarConstants
If (UserControl.Ambient.UserMode) Then
m_eVersion = PropBag.ReadProperty("Version", eRICHED32)
Else
UseVersion = PropBag.ReadProperty("Version", eRICHED32)
End If
SingleLine = PropBag.ReadProperty("SingleLine", False)
If m_bSingleLine Then
eDefault = ercScrollBarsNone
Else
eDefault = ercScrollBarsBoth
End If
ScrollBars = PropBag.ReadProperty("ScrollBars", eDefault)
DisableNoScroll = PropBag.ReadProperty("DisableNoScroll", False)
HideSelection = PropBag.ReadProperty("HideSelection", False)
PasswordChar = PropBag.ReadProperty("PasswordChar", "")
m_bBorder = PropBag.ReadProperty("Border", True)
Transparent = PropBag.ReadProperty("Transparent", False)
pInitialise
Border = m_bBorder
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)
ControlLeftMargin = PropBag.ReadProperty("ControlLightMargin", 0)
ControlRightMargin = PropBag.ReadProperty("ControlRightMargin", 0)
TextLimit = PropBag.ReadProperty("TextLimit", 32767)
TrapTab = PropBag.ReadProperty("TrapTab", True)
If (UserControl.Ambient.UserMode) Then
lblText.Visible = False
Else
lblText.Visible = True
End If
If m_eVersion = eRICHED20 Then
AutoURLDetect = PropBag.ReadProperty("AutoURLDetect", True)
TextOnly = PropBag.ReadProperty("TextOnly", False)
Else
m_bAutoURLDetect = PropBag.ReadProperty("AutoURLDetect", True)
m_bTextOnly = PropBag.ReadProperty("TextOnly", False)
End If
ReadOnly = PropBag.ReadProperty("ReadOnly", False)
End Sub
Private Sub UserControl_Resize()
Dim tR As RECT
If (m_hWnd <> 0) Then
GetClientRect m_hWndParent, tR
MoveWindow m_hWnd, 0, 0, tR.Right - tR.Left, tR.Bottom - tR.Top, Abs(m_bRedraw)
tR.Left = m_lLeftMarginPixels
tR.Right = UserControl.ScaleWidth \ Screen.TwipsPerPixelX - m_lRightMarginPixels
If (tR.Right < tR.Left) Then tR.Right = tR.Left
tR.Top = 2
tR.Bottom = UserControl.ScaleHeight \ Screen.TwipsPerPixelY
'Redraw = False
SendMessage m_hWnd, EM_SETRECT, 0, tR
ControlLeftMargin = m_lLeftMarginPixels
ControlRightMargin = m_lRightMarginPixels
'Redraw = True
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()
' Destroy the control & clear up:
pTerminate
' Detach the custom IOleInPlaceActiveObject interface
' pointers.
With m_IPAOHookStruct
CopyMemory .IPAOReal, 0&, 4
CopyMemory .TBEx, 0&, 4
End With
Debug.Print "RichEditControl:Terminate"
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Dim eDefault As ERECScrollBarConstants
' Write properties:
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
PropBag.WriteProperty "ControlLeftMargin", m_lLeftMarginPixels, 0
PropBag.WriteProperty "ControlRightMargin", m_lRightMarginPixels, 0
PropBag.WriteProperty "TextLimit", TextLimit, 32767
PropBag.WriteProperty "TrapTab", TrapTab, True
If m_eVersion = eRICHED20 Then
PropBag.WriteProperty "AutoURLDetect", AutoURLDetect, True
PropBag.WriteProperty "TextOnly", TextOnly, False
PropBag.WriteProperty "Transparent", Transparent, False
Else
PropBag.WriteProperty "AutoURLDetect", m_bAutoURLDetect, True
PropBag.WriteProperty "TextOnly", m_bTextOnly, False
PropBag.WriteProperty "Transparent", m_bTransparent, False
End If
PropBag.WriteProperty "ReadOnly", ReadOnly, False
PropBag.WriteProperty "Enabled", Enabled, True
PropBag.WriteProperty "SingleLine", SingleLine, False
PropBag.WriteProperty "DisableNoScroll", DisableNoScroll, False
PropBag.WriteProperty "PasswordChar", PasswordChar, ""
If m_bSingleLine Then
eDefault = ercScrollBarsNone
Else
eDefault = ercScrollBarsBoth
End If
PropBag.WriteProperty "ScrollBars", ScrollBars, eDefault
PropBag.WriteProperty "HideSelection", HideSelection, False
End Sub