home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 Special / chip-cd_2001_spec_05.zip / spec_05 / apps / crystal / disk18 / Xvb236._ / Xvb236.
Text File  |  1999-08-23  |  8KB  |  288 lines
  1. Attribute VB_Name = "modRichText"
  2. Option Explicit
  3. Private m_rtxt As RichTextBox
  4.  
  5. Public Const FONT_NAME = 1
  6. Public Const FONT_SIZE = 2
  7. Public Const FONT_BOLD = 3
  8. Public Const FONT_UNDERLINE = 4
  9. Public Const FONT_ITALIC = 5
  10. Public Const FONT_STRIKETHRU = 6
  11. Public Const FONT_COLOR = 7
  12. Public Const FONT_ALIGN = 8
  13. Public Const FONT_BULLET = 9
  14. Public Const FONT_CHAROFFSET = 10
  15. Public Const FONT_INDENT = 11
  16. Public Const FONT_HANGINGINDENT = 12
  17. Public Const FONT_RIGHTINDENT = 13
  18.  
  19. Public Sub SetControl(rtxt As RichTextBox)
  20. '====================
  21. ' store reference to RichTextBox control
  22. '   used as default control by other functions if control is not passed
  23. '------------------------
  24. ' created: March 97
  25. ' by: Rick McCallion
  26. ' Copyright 1997 Eclipse Software and Consulting Inc.
  27. '------------------------------
  28.   
  29.   On Error GoTo SetControl_Err:
  30.   
  31.   Set m_rtxt = rtxt
  32.   
  33. SetControl_Exit:
  34.   Exit Sub
  35. SetControl_Err:
  36.   MsgBox Error$, vbInformation, "SetControl Error: " & Err.Number
  37.   GoTo SetControl_Exit:
  38.  
  39. End Sub
  40.  
  41. Public Sub AddLine(ByVal strLine As String, Optional rtxt As Variant, Optional ByVal vBreak As Variant, Optional ByVal vFontInfo As Variant)
  42. 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)"
  43. '===================
  44. ' append the passed string to rtxt.text
  45. '    if rtxt not passed, must have passed default control to SetControl
  46. '    adds cr/lf by default; override by passing false for vBreak
  47. '
  48. '    vFontInfo - collection containing: FontName, FontSize, FontBold, FontItalic, FontUnderline
  49. '-------------------------
  50. '    examples:
  51. '     SIMPLE CALL, no font settings, automatic new line, text added at end of existing text
  52. '       Addline rtxt:=rtxtTest, strLine:="this is a new line"
  53. '     -------------------------
  54. '     SIMPLE CALL, no font settings, NO new line, text inserted at current cursor position
  55. '       Addline rtxt:=rtxtTest, strLine:="this is a new line", vBreak:=false
  56. '     -------------------------
  57. '
  58. '     DETAILED CALL, sets FontName, Size, Underline, Bold, and Italic
  59. '        Dim cFont As New Collection
  60. '        ' NOTE: only add items you want to change from their current setting
  61. '        cFont.Add "Arial", "SelFontName"
  62. '        cFont.Add 12, "SelFontSize"
  63. '        cFont.Add True, "SelBold"
  64. '        cFont.Add False, "SelItalic"
  65. '        cFont.Add False, "SelUnderline"
  66. '        AddLine rtxt:=rtxtTest, strLine:="this is a new line in Arial 12 Bold", vFontInfo:=cFont
  67. '-------------------------
  68. '    Other properties you can add to collection:
  69. '       SelAlignment Property
  70. '       SelBullet Property
  71. '       SelCharOffset Property
  72. '       SelColor Property
  73. '       SelHangingIndent Property
  74. '       SelIndent Property
  75. '       SelRightIndent Property
  76. '------------------------
  77. ' created: March 97
  78. ' by: Rick McCallion
  79. ' Copyright 1997 Eclipse Software and Consulting Inc.
  80. '------------------------------
  81.  
  82.   On Error Resume Next 'don't sweat it
  83.   Dim vSetting As Variant
  84.   
  85.   'set up default value for missing parameters
  86.   
  87.   If IsMissing(rtxt) Then
  88.     Set rtxt = m_rtxt
  89.   End If
  90.   
  91.   If IsMissing(vBreak) Then
  92.     vBreak = True ' add cr/lf if not specified
  93.   End If
  94.   
  95.   If vBreak Then
  96.     If rtxt.Text <> "" Then
  97.       ' add new line if text exists
  98.       strLine = vbCrLf & strLine
  99.       
  100.       'move insertion point to end of text
  101.       rtxt.SelStart = Len(rtxt.Text)
  102.     Else
  103.       'creating first line
  104.     End If
  105.   End If
  106.   
  107.   '----------- retained for backwards compatibility --------------
  108.   ' set font properties if vFontInfo passed
  109.   If Not IsMissing(vFontInfo) Then
  110.       'do it the old way
  111.       SetFontTheOldWay vFontInfo
  112.   End If
  113.   '----------- END retained for backwards compatibility --------------
  114.   
  115.   rtxt.SelText = strLine
  116.   
  117. End Sub
  118.  
  119. Public Sub SelectAll(ctrl As Control)
  120. Attribute SelectAll.VB_Description = "Selects all text in passed textboxe, richtextbox, or any control that has SelStart and SelLenght properties."
  121. '===================
  122. ' select all text in passed control
  123. '------------------------
  124. ' created: March 97
  125. ' by: Rick McCallion
  126. ' Copyright 1997 Eclipse Software and Consulting Inc.
  127. '------------------------------
  128.  
  129.   On Error Resume Next
  130.   ctrl.SelStart = 0
  131.   ctrl.SelLength = Len(ctrl.Text)
  132.  
  133. End Sub
  134.  
  135. Private Sub SetFontTheOldWay(ByVal vFontInfo As Variant)
  136. '
  137. ' obsolete... retained for backwards compatiblity
  138. '
  139.  
  140.   On Error Resume Next
  141.   Dim vValue As Variant
  142.   
  143.   vValue = vFontInfo("SelFontName")
  144.   If Err = 0 Then
  145.     m_rtxt.SelFontName = vValue
  146.   Else
  147.     'this setting not passed, no worries
  148.     Err.Clear
  149.   End If
  150.   
  151.   vValue = vFontInfo("SelFontSize")
  152.   If Err = 0 Then
  153.     m_rtxt.SelFontSize = vValue
  154.   Else
  155.     'this setting not passed, no worries
  156.     Err.Clear
  157.   End If
  158.  
  159.   vValue = vFontInfo("SelBold")
  160.   If Err = 0 Then
  161.     m_rtxt.SelBold = vValue
  162.   Else
  163.     'this setting not passed, no worries
  164.     Err.Clear
  165.   End If
  166.  
  167.   vValue = vFontInfo("SelItalic")
  168.   If Err = 0 Then
  169.     m_rtxt.SelItalic = vValue
  170.   Else
  171.     'this setting not passed, no worries
  172.     Err.Clear
  173.   End If
  174.  
  175.   vValue = vFontInfo("SelStrikeThru")
  176.   If Err = 0 Then
  177.     m_rtxt.SelStrikeThru = vValue
  178.   Else
  179.     'this setting not passed, no worries
  180.     Err.Clear
  181.   End If
  182.  
  183.   vValue = vFontInfo("SelUnderline")
  184.   If Err = 0 Then
  185.     m_rtxt.SelUnderline = vValue
  186.   Else
  187.     'this setting not passed, no worries
  188.     Err.Clear
  189.   End If
  190.  
  191.   vValue = vFontInfo("SelColor")
  192.   If Err = 0 Then
  193.     m_rtxt.SelColor = vValue
  194.   Else
  195.     'this setting not passed, no worries
  196.     Err.Clear
  197.   End If
  198.  
  199.   vValue = vFontInfo("SelAlignment")
  200.   If Err = 0 Then
  201.     m_rtxt.SelAlignment = vValue
  202.   Else
  203.     'this setting not passed, no worries
  204.     Err.Clear
  205.   End If
  206.  
  207.   vValue = vFontInfo("SelCharOffset")
  208.   If Err = 0 Then
  209.     m_rtxt.SelCharOffset = vValue
  210.   Else
  211.     'this setting not passed, no worries
  212.     Err.Clear
  213.   End If
  214.  
  215.   vValue = vFontInfo("SelBullet")
  216.   If Err = 0 Then
  217.      m_rtxt.SelBullet = vValue
  218.   Else
  219.     'this setting not passed, no worries
  220.     Err.Clear
  221.   End If
  222.  
  223.   vValue = vFontInfo("SelIndent")
  224.   If Err = 0 Then
  225.     m_rtxt.SelIndent = vValue
  226.   Else
  227.     'this setting not passed, no worries
  228.     Err.Clear
  229.   End If
  230.  
  231.   vValue = vFontInfo("SelHangingIndent")
  232.   If Err = 0 Then
  233.     m_rtxt.SelHangingIndent = vValue
  234.   Else
  235.     'this setting not passed, no worries
  236.     Err.Clear
  237.   End If
  238.  
  239.   vValue = vFontInfo("SelRightIndent")
  240.   If Err = 0 Then
  241.     m_rtxt.SelRightIndent = vValue
  242.   Else
  243.     'this setting not passed, no worries
  244.     Err.Clear
  245.   End If
  246.   
  247. End Sub
  248.  
  249. Public Sub SetFont(intProperty As Integer, vValue As Variant)
  250. '
  251. ' set requested font property in richtext control
  252. '   at current insertion point
  253. '
  254.  
  255.   On Error Resume Next
  256.   Select Case intProperty
  257.     Case FONT_NAME
  258.         m_rtxt.SelFontName = vValue
  259.     Case FONT_SIZE
  260.         m_rtxt.SelFontSize = vValue
  261.     Case FONT_BOLD
  262.         m_rtxt.SelBold = vValue
  263.     Case FONT_UNDERLINE
  264.         m_rtxt.SelUnderline = vValue
  265.     Case FONT_ITALIC
  266.         m_rtxt.SelItalic = vValue
  267.     Case FONT_STRIKETHRU
  268.         m_rtxt.SelStrikeThru = vValue
  269.     Case FONT_COLOR
  270.         m_rtxt.SelColor = vValue
  271.     Case FONT_ALIGN
  272.         m_rtxt.SelAlignment = vValue
  273.     Case FONT_BULLET
  274.         m_rtxt.SelBullet = vValue
  275.     Case FONT_CHAROFFSET
  276.         m_rtxt.SelCharOffset = vValue
  277.     Case FONT_INDENT
  278.         m_rtxt.SelIndent = vValue
  279.     Case FONT_HANGINGINDENT
  280.         m_rtxt.SelHangingIndent = vValue
  281.     Case FONT_RIGHTINDENT
  282.         m_rtxt.SelRightIndent = vValue
  283.     Case Else
  284.         MsgBox "Unknown Font Property"
  285.   End Select
  286.  
  287. End Sub
  288.