home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD83797302000.psc / rtfBackColourTestForm1.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  2000-07-30  |  8.1 KB  |  227 lines
  1. VERSION 5.00
  2. Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
  3. Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
  4. Begin VB.Form Form1 
  5.    Caption         =   "Rtf - backcolour test"
  6.    ClientHeight    =   3900
  7.    ClientLeft      =   165
  8.    ClientTop       =   735
  9.    ClientWidth     =   4605
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   3900
  12.    ScaleWidth      =   4605
  13.    StartUpPosition =   3  'Windows Default
  14.    Begin VB.ComboBox cboZoom 
  15.       Height          =   315
  16.       Left            =   3120
  17.       TabIndex        =   2
  18.       Text            =   "Combo1"
  19.       Top             =   0
  20.       Width           =   1335
  21.    End
  22.    Begin MSComDlg.CommonDialog cDlg1 
  23.       Left            =   4680
  24.       Top             =   0
  25.       _ExtentX        =   847
  26.       _ExtentY        =   847
  27.       _Version        =   393216
  28.    End
  29.    Begin VB.TextBox Text1 
  30.       Height          =   855
  31.       Left            =   120
  32.       MultiLine       =   -1  'True
  33.       TabIndex        =   1
  34.       ToolTipText     =   "View and change  Rtf text here"
  35.       Top             =   2880
  36.       Width           =   4335
  37.    End
  38.    Begin RichTextLib.RichTextBox rtfText1 
  39.       Height          =   2415
  40.       Left            =   120
  41.       TabIndex        =   0
  42.       Top             =   360
  43.       Width           =   4335
  44.       _ExtentX        =   7646
  45.       _ExtentY        =   4260
  46.       _Version        =   393217
  47.       TextRTF         =   $"rtfBackColourTestForm1.frx":0000
  48.       BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
  49.          Name            =   "Times New Roman"
  50.          Size            =   8.25
  51.          Charset         =   0
  52.          Weight          =   400
  53.          Underline       =   0   'False
  54.          Italic          =   0   'False
  55.          Strikethrough   =   0   'False
  56.       EndProperty
  57.    End
  58.    Begin VB.Menu mnuFile 
  59.       Caption         =   "&File"
  60.       Begin VB.Menu mnuExit 
  61.          Caption         =   "&Exit"
  62.       End
  63.    End
  64.    Begin VB.Menu mnuFormat 
  65.       Caption         =   "&Format"
  66.       Begin VB.Menu mnuFont 
  67.          Caption         =   "&Font"
  68.          Begin VB.Menu mnuFontColour 
  69.             Caption         =   "&FontColour"
  70.          End
  71.          Begin VB.Menu mnuFontBackColour 
  72.             Caption         =   "&FontBackColour"
  73.          End
  74.       End
  75.    End
  76.    Begin VB.Menu mnuView 
  77.       Caption         =   "&View"
  78.       Begin VB.Menu mnuViewRtf 
  79.          Caption         =   "&View rtf"
  80.       End
  81.       Begin VB.Menu mnuSetRtf 
  82.          Caption         =   "&setRtf"
  83.       End
  84.    End
  85.    Begin VB.Menu mnuAbout 
  86.       Caption         =   "&About"
  87.       Begin VB.Menu mnuMe 
  88.          Caption         =   "&ME!"
  89.       End
  90.    End
  91. Attribute VB_Name = "Form1"
  92. Attribute VB_GlobalNameSpace = False
  93. Attribute VB_Creatable = False
  94. Attribute VB_PredeclaredId = True
  95. Attribute VB_Exposed = False
  96. Option Explicit
  97. '------------IMPORTANT INFORMATION-------------------------------
  98. 'This sample requires the Riched20.dll (version 3) look at the file properties
  99. 'This also requires Riched32.dll (5.00.2008.1)
  100. 'and probably the Richx32.ocx control (I've got version 6.00.8418)
  101. 'Based in part on the work of Steve McMahon (www.vbaccelarator.com)
  102. 'Font used in sample is Times New Roman 8pt (scales better that MS SansSerif)
  103. 'Delete/overwrite the riched20 and riched32.dll files
  104. 'You need to have vb6/5 not running to replace these files.
  105. 'By oigres P (Sergio Perciballi) Email:oigres@postmaster.co.uk
  106. 'new richtextbox and dll files can be found at www.vbaccelerator.com
  107. Dim charf As CHARFORMAT2 'character format type for extended information
  108. Private Sub Form_Load()
  109.     'MsgBox LenB(charf)
  110.     'MsgBox VarPtr(charf) & ":"
  111.     Dim lIdx
  112.     ''charf.crBackColor = &HFF& 'initially red background
  113.     charf.dwMask = CFM_BACKCOLOR
  114.     charf.cbSize = LenB(charf) 'setup the size of the character format
  115.     'setup zoom combo box - most from Steve McMahon
  116.     cboZoom.AddItem "10%" '1:10
  117.     cboZoom.ItemData(cboZoom.NewIndex) = 1 * &H10000 + 10
  118.     cboZoom.AddItem "25%" '1:4
  119.     cboZoom.ItemData(cboZoom.NewIndex) = 1 * &H10000 + 4
  120.     cboZoom.AddItem "50%" '1:2
  121.     cboZoom.ItemData(cboZoom.NewIndex) = 1 * &H10000 + 2
  122.     cboZoom.AddItem "75%" '3:4'
  123.     cboZoom.ItemData(cboZoom.NewIndex) = 3 * &H10000 + 4
  124.     cboZoom.AddItem "80%" '4:5
  125.     cboZoom.ItemData(cboZoom.NewIndex) = 4 * &H10000 + 5
  126.     cboZoom.AddItem "90%" '9:10
  127.     cboZoom.ItemData(cboZoom.NewIndex) = 9 * &H10000 + 10
  128.     cboZoom.AddItem "100%"
  129.     lIdx = cboZoom.NewIndex '1:1
  130.     cboZoom.ItemData(cboZoom.NewIndex) = 1 * &H10000 + 1
  131.     cboZoom.AddItem "150%" '3:2
  132.     cboZoom.ItemData(cboZoom.NewIndex) = 3 * &H10000 + 2
  133.     cboZoom.AddItem "200%" '2:1
  134.     cboZoom.ItemData(cboZoom.NewIndex) = 2 * &H10000 + 1
  135.     cboZoom.AddItem "250%" '5:2
  136.     cboZoom.ItemData(cboZoom.NewIndex) = 5 * &H10000 + 2
  137.     cboZoom.AddItem "300%"  '3:1'
  138.     cboZoom.ItemData(cboZoom.NewIndex) = 3 * &H10000 + 1
  139.     cboZoom.AddItem "350%"  '7:2'
  140.     cboZoom.ItemData(cboZoom.NewIndex) = 7 * &H10000 + 2
  141.     cboZoom.AddItem "400%"  '4:1'
  142.     cboZoom.ItemData(cboZoom.NewIndex) = 4 * &H10000 + 1
  143.     cboZoom.AddItem "450%"  '9:2'
  144.     cboZoom.ItemData(cboZoom.NewIndex) = 9 * &H10000 + 2
  145.     cboZoom.AddItem "500%"  '5:1'
  146.     cboZoom.ItemData(cboZoom.NewIndex) = 5 * &H10000 + 1
  147.     cboZoom.ListIndex = lIdx
  148.     Form1.Show
  149.     'had to show the form first or else invalid procedure call or argument
  150.     cboZoom.SetFocus
  151. End Sub
  152. Private Sub mnuExit_Click()
  153.     Unload Me
  154. End Sub
  155. Private Sub mnuFontBackColour_Click()
  156.     Dim ret As Long
  157.     On Error GoTo error_cancel
  158.     cDlg1.Flags = cdlCCRGBInit '+ cdlCancel
  159.     cDlg1.Color = vbRed
  160.     cDlg1.CancelError = True
  161.     cDlg1.ShowColor
  162.     'MsgBox "Colour = " & cDlg1.Color
  163.     'set the font colour
  164.     '''rtfText1.SelColor = cDlg1.Color
  165.     charf.crBackColor = cDlg1.Color
  166.     ret = SendMessageLong(rtfText1.hWnd, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(charf))
  167.     If ret = 0 Then
  168.     MsgBox "You probably have the wrong  files ->" & vbCrLf _
  169.     & "Riched20.dll Version 3.0 (File version 5.30.22.2300)" & vbCrLf _
  170.     & "Riched32.dll (file version 5.00.2008.1)" & vbCrLf _
  171.     & "Richtx32.ocx not so critical (my version is 6.00.8418)" & vbCrLf _
  172.     & "Get the files from www.vbacelerator.com , delete/backup old system files and replace"
  173.     ''MsgBox "ret= " & ret
  174.     End If
  175.     Exit Sub
  176. error_cancel:
  177.     ''MsgBox "cancel "
  178. End Sub
  179. Private Sub mnuFontColour_Click()
  180.     On Error GoTo error_cancel
  181.     cDlg1.Flags = cdlCCRGBInit '+ cdlCancel
  182.     cDlg1.Color = vbRed
  183.     cDlg1.CancelError = True
  184.     cDlg1.ShowColor
  185.     'MsgBox "Colour = " & cDlg1.Color
  186.     'set the font colour
  187.     rtfText1.SelColor = cDlg1.Color
  188.     Exit Sub
  189. error_cancel:
  190.     ''MsgBox "cancel "
  191. End Sub
  192. Private Sub mnuMe_Click()
  193.     MsgBox "Sample by oigres P " & vbCrLf & "Email: oigres@postmaster.co.uk", , "            About"
  194. End Sub
  195. Private Sub mnuSetRtf_Click()
  196.     rtfText1.TextRTF = Text1.Text
  197.     'reset zoom ratio
  198.     cboZoom_Click
  199. End Sub
  200. Private Sub mnuViewRtf_Click()
  201.     Text1.Text = rtfText1.TextRTF
  202. End Sub
  203. Private Sub cboZoom_Click()
  204. Dim lND As Long
  205. Dim lNum As Long
  206. Dim lDen As Long
  207. Dim dummyinum As Long, dummydenom As Long
  208.    If cboZoom.ListIndex > -1 Then
  209.       lND = cboZoom.ItemData(cboZoom.ListIndex)
  210.       lNum = lND \ &H10000
  211.       lDen = lND And &H7FFF&
  212.       SetZoom rtfText1.hWnd, lNum, lDen
  213.     ''GetZoom rtfText1.hWnd, dummyinum, dummydenom
  214.    End If
  215. End Sub
  216. Public Sub SetZoom(ByVal hWndRtf As Long, ByVal lNumerator As Long, ByVal lDenominator As Long)
  217. Dim lR As Long
  218.    If lNumerator > 64 Or lDenominator > 64 Or lNumerator < 0 Or lDenominator < 0 Then
  219.       Err.Raise 27110, App.EXEName & ".mRichEdit30", "Numerator and Denominator must be between 1 and 64"
  220.    End If
  221.    lR = SendMessageLong(hWndRtf, EM_SETZOOM, lNumerator, lDenominator)
  222. End Sub
  223. Public Sub GetZoom(ByVal hWndRtf As Long, ByRef lNumerator As Long, ByRef lDenominator As Long)
  224.    SendMessageRef hWndRtf, EM_GETZOOM, lNumerator, lDenominator
  225.     ''Label1.Caption = "Zoom Ratio " & lNumerator & ":" & lDenominator
  226. End Sub
  227.