home *** CD-ROM | disk | FTP | other *** search
Wrap
Attribute VB_Name = "modRichText" Option Explicit Private m_rtxt As RichTextBox Public Const FONT_NAME = 1 Public Const FONT_SIZE = 2 Public Const FONT_BOLD = 3 Public Const FONT_UNDERLINE = 4 Public Const FONT_ITALIC = 5 Public Const FONT_STRIKETHRU = 6 Public Const FONT_COLOR = 7 Public Const FONT_ALIGN = 8 Public Const FONT_BULLET = 9 Public Const FONT_CHAROFFSET = 10 Public Const FONT_INDENT = 11 Public Const FONT_HANGINGINDENT = 12 Public Const FONT_RIGHTINDENT = 13 Public Sub SetControl(rtxt As RichTextBox) '==================== ' store reference to RichTextBox control ' used as default control by other functions if control is not passed '------------------------ ' created: March 97 ' by: Rick McCallion ' Copyright 1997 Eclipse Software and Consulting Inc. '------------------------------ On Error GoTo SetControl_Err: Set m_rtxt = rtxt SetControl_Exit: Exit Sub SetControl_Err: MsgBox Error$, vbInformation, "SetControl Error: " & Err.Number GoTo SetControl_Exit: End Sub Public Sub AddLine(ByVal strLine As String, Optional rtxt As Variant, Optional ByVal vBreak As Variant, Optional ByVal vFontInfo As Variant) Attribute AddLine.VB_Description = "Pass a RichTextbox, the text to be add, and optional Font information. Text will be formatted and added at cursor position. New line by default (vBreak:=True)" '=================== ' append the passed string to rtxt.text ' if rtxt not passed, must have passed default control to SetControl ' adds cr/lf by default; override by passing false for vBreak ' ' vFontInfo - collection containing: FontName, FontSize, FontBold, FontItalic, FontUnderline '------------------------- ' examples: ' SIMPLE CALL, no font settings, automatic new line, text added at end of existing text ' Addline rtxt:=rtxtTest, strLine:="this is a new line" ' ------------------------- ' SIMPLE CALL, no font settings, NO new line, text inserted at current cursor position ' Addline rtxt:=rtxtTest, strLine:="this is a new line", vBreak:=false ' ------------------------- ' ' DETAILED CALL, sets FontName, Size, Underline, Bold, and Italic ' Dim cFont As New Collection ' ' NOTE: only add items you want to change from their current setting ' cFont.Add "Arial", "SelFontName" ' cFont.Add 12, "SelFontSize" ' cFont.Add True, "SelBold" ' cFont.Add False, "SelItalic" ' cFont.Add False, "SelUnderline" ' AddLine rtxt:=rtxtTest, strLine:="this is a new line in Arial 12 Bold", vFontInfo:=cFont '------------------------- ' Other properties you can add to collection: ' SelAlignment Property ' SelBullet Property ' SelCharOffset Property ' SelColor Property ' SelHangingIndent Property ' SelIndent Property ' SelRightIndent Property '------------------------ ' created: March 97 ' by: Rick McCallion ' Copyright 1997 Eclipse Software and Consulting Inc. '------------------------------ On Error Resume Next 'don't sweat it Dim vSetting As Variant 'set up default value for missing parameters If IsMissing(rtxt) Then Set rtxt = m_rtxt End If If IsMissing(vBreak) Then vBreak = True ' add cr/lf if not specified End If If vBreak Then If rtxt.Text <> "" Then ' add new line if text exists strLine = vbCrLf & strLine 'move insertion point to end of text rtxt.SelStart = Len(rtxt.Text) Else 'creating first line End If End If '----------- retained for backwards compatibility -------------- ' set font properties if vFontInfo passed If Not IsMissing(vFontInfo) Then 'do it the old way SetFontTheOldWay vFontInfo End If '----------- END retained for backwards compatibility -------------- rtxt.SelText = strLine End Sub Public Sub SelectAll(ctrl As Control) Attribute SelectAll.VB_Description = "Selects all text in passed textboxe, richtextbox, or any control that has SelStart and SelLenght properties." '=================== ' select all text in passed control '------------------------ ' created: March 97 ' by: Rick McCallion ' Copyright 1997 Eclipse Software and Consulting Inc. '------------------------------ On Error Resume Next ctrl.SelStart = 0 ctrl.SelLength = Len(ctrl.Text) End Sub Private Sub SetFontTheOldWay(ByVal vFontInfo As Variant) ' ' obsolete... retained for backwards compatiblity ' On Error Resume Next Dim vValue As Variant vValue = vFontInfo("SelFontName") If Err = 0 Then m_rtxt.SelFontName = vValue Else 'this setting not passed, no worries Err.Clear End If vValue = vFontInfo("SelFontSize") If Err = 0 Then m_rtxt.SelFontSize = vValue Else 'this setting not passed, no worries Err.Clear End If vValue = vFontInfo("SelBold") If Err = 0 Then m_rtxt.SelBold = vValue Else 'this setting not passed, no worries Err.Clear End If vValue = vFontInfo("SelItalic") If Err = 0 Then m_rtxt.SelItalic = vValue Else 'this setting not passed, no worries Err.Clear End If vValue = vFontInfo("SelStrikeThru") If Err = 0 Then m_rtxt.SelStrikeThru = vValue Else 'this setting not passed, no worries Err.Clear End If vValue = vFontInfo("SelUnderline") If Err = 0 Then m_rtxt.SelUnderline = vValue Else 'this setting not passed, no worries Err.Clear End If vValue = vFontInfo("SelColor") If Err = 0 Then m_rtxt.SelColor = vValue Else 'this setting not passed, no worries Err.Clear End If vValue = vFontInfo("SelAlignment") If Err = 0 Then m_rtxt.SelAlignment = vValue Else 'this setting not passed, no worries Err.Clear End If vValue = vFontInfo("SelCharOffset") If Err = 0 Then m_rtxt.SelCharOffset = vValue Else 'this setting not passed, no worries Err.Clear End If vValue = vFontInfo("SelBullet") If Err = 0 Then m_rtxt.SelBullet = vValue Else 'this setting not passed, no worries Err.Clear End If vValue = vFontInfo("SelIndent") If Err = 0 Then m_rtxt.SelIndent = vValue Else 'this setting not passed, no worries Err.Clear End If vValue = vFontInfo("SelHangingIndent") If Err = 0 Then m_rtxt.SelHangingIndent = vValue Else 'this setting not passed, no worries Err.Clear End If vValue = vFontInfo("SelRightIndent") If Err = 0 Then m_rtxt.SelRightIndent = vValue Else 'this setting not passed, no worries Err.Clear End If End Sub Public Sub SetFont(intProperty As Integer, vValue As Variant) ' ' set requested font property in richtext control ' at current insertion point ' On Error Resume Next Select Case intProperty Case FONT_NAME m_rtxt.SelFontName = vValue Case FONT_SIZE m_rtxt.SelFontSize = vValue Case FONT_BOLD m_rtxt.SelBold = vValue Case FONT_UNDERLINE m_rtxt.SelUnderline = vValue Case FONT_ITALIC m_rtxt.SelItalic = vValue Case FONT_STRIKETHRU m_rtxt.SelStrikeThru = vValue Case FONT_COLOR m_rtxt.SelColor = vValue Case FONT_ALIGN m_rtxt.SelAlignment = vValue Case FONT_BULLET m_rtxt.SelBullet = vValue Case FONT_CHAROFFSET m_rtxt.SelCharOffset = vValue Case FONT_INDENT m_rtxt.SelIndent = vValue Case FONT_HANGINGINDENT m_rtxt.SelHangingIndent = vValue Case FONT_RIGHTINDENT m_rtxt.SelRightIndent = vValue Case Else MsgBox "Unknown Font Property" End Select End Sub