home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1999 October / pcp156b.iso / handson / files / copyvbwk.exe / richtext / RichTextEdit.ctl (.txt) < prev   
Encoding:
Visual Basic Form  |  1999-03-31  |  4.9 KB  |  158 lines
  1. VERSION 5.00
  2. Begin VB.UserControl RTE 
  3.    ClientHeight    =   3390
  4.    ClientLeft      =   0
  5.    ClientTop       =   0
  6.    ClientWidth     =   4800
  7.    ScaleHeight     =   226
  8.    ScaleMode       =   3  'Pixel
  9.    ScaleWidth      =   320
  10. Attribute VB_Name = "RTE"
  11. Attribute VB_GlobalNameSpace = False
  12. Attribute VB_Creatable = True
  13. Attribute VB_PredeclaredId = False
  14. Attribute VB_Exposed = True
  15. Option Explicit
  16. Private Declare Function CreateWindowEx Lib "user32" _
  17. Alias "CreateWindowExA" (ByVal dwExStyle As Long, _
  18. ByVal lpClassName As String, _
  19. ByVal lpWindowName As String, _
  20. ByVal dwStyle As Long, _
  21. ByVal X As Long, ByVal Y As Long, _
  22. ByVal nWidth As Long, ByVal nHeight As Long, _
  23. ByVal hWndParent As Long, ByVal hMenu As Long, _
  24. ByVal hInstance As Long, lpParam As Any) As Long
  25. Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
  26. Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
  27. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, wParam As Any, lParam As Any) As Long
  28. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
  29. Private Declare Function MoveWindow Lib "user32" _
  30. (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, _
  31. ByVal nWidth As Long, ByVal nHeight As Long, _
  32. ByVal bRepaint As Long) As Long
  33. Private Declare Function SetFocusX Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
  34. Const WS_VISIBLE = &H10000000
  35. Const WS_CHILD = &H40000000
  36. Const WM_USER = &H400
  37. Const WM_SETTEXT = 12
  38. Const WM_GETTEXTLENGTH = &HE
  39. Const WS_TABSTOP = &H10000
  40. Const WS_BORDER = &H800000
  41. Const EM_GETTEXTEX = WM_USER + 94
  42. Const EM_GETSELTEXT = WM_USER + 62
  43. Const ES_MULTILINE = &H4&
  44. Const ES_NOHIDESEL = &H100&
  45. Const EN_SELCHANGE = &H702
  46. Const ENM_SELCHANGE = &H80000
  47. Const EM_SETBKGNDCOLOR = WM_USER + 67
  48. Const EM_EXSETSEL = WM_USER + 55
  49. Const ENM_MOUSEEVENTS = &H20000
  50. Const EM_SETEVENTMASK = WM_USER + 69
  51. Const ENM_KEYEVENTS = &H10000
  52. Const WS_VSCROLL = &H200000
  53. Const WS_HSCROLL = &H100000
  54. Const LOGPIXELSX = 88
  55. Const LOGPIXELSY = 90
  56. Const SCF_ALL = 4
  57. Const LF_FACESIZE = 32
  58. Private Type GETTEXTEX
  59.     cb As Long
  60.     flags As Long
  61.     CodePage As Integer
  62.     lpDefaultChar As Long
  63.     lpUsedDefChar As Long
  64. End Type
  65. Private Type CHARRANGE
  66.     cpMin As Long
  67.     cpMax As Long
  68. End Type
  69. 'Property Variables:
  70. Private m_hWnd As Long
  71. Public Property Get hWnd() As Long
  72. hWnd = m_hWnd
  73. End Property
  74. Public Property Let hWnd(ByVal New_hWnd As Long)
  75. m_hWnd = New_hWnd
  76. PropertyChanged "hWnd"
  77. End Property
  78. Public Property Let Font(s As String)
  79. Module1.faceName = MyFormat(hWnd, SCF_ALL)
  80. End Property
  81. Public Property Get Font() As String
  82. Font = Module1.faceName
  83. End Property
  84. Public Property Let Text(s As String)
  85. Dim r As Long
  86. r = SendMessage(m_hWnd, WM_SETTEXT, 0, ByVal s)
  87. End Property
  88. Public Property Get Text() As String
  89. Dim gtxx As GETTEXTEX
  90. Dim r As Long, s As Long, BufSize As Long
  91. Dim buf As String
  92. r = SendMessage(m_hWnd, WM_GETTEXTLENGTH, 0, 0)
  93. BufSize = 2 * (r + 1) ' allow for possible NULL
  94. buf = String$(BufSize, 0)
  95. gtxx.cb = BufSize
  96. gtxx.flags = 0
  97. gtxx.CodePage = 1200
  98. gtxx.lpDefaultChar = 0
  99. gtxx.lpUsedDefChar = 0
  100. s = StrPtr(buf)
  101. r = SendMessage(m_hWnd, EM_GETTEXTEX, gtxx, ByVal s)
  102. Text = Left$(buf, r)
  103. End Property
  104. Public Function HighlightText(offset As Long, Size As Long) As Long
  105. Dim cr As CHARRANGE
  106. Dim r As Long
  107. cr.cpMin = offset
  108. cr.cpMax = offset + Size
  109. r = SendMessage(m_hWnd, EM_EXSETSEL, 0, cr)
  110. HighlightText = r
  111. End Function
  112. Public Sub HandleMouse()
  113. Dim r As Long
  114. r = SendMessage(m_hWnd, EM_SETEVENTMASK, 0, _
  115.     ByVal (ENM_SELCHANGE Or ENM_MOUSEEVENTS))
  116. End Sub
  117. Private Sub UserControl_GotFocus()
  118. Dim r As Long
  119. ' note that we have to call the API SetFocus
  120. ' as SetFocusX to avoid a name class with the
  121. ' VB SetFocus
  122. r = SetFocusX(m_hWnd)
  123. End Sub
  124. Private Sub UserControl_Initialize()
  125. Dim X As Long, Y As Long, r As Long, i As Integer
  126. r = LoadLibrary("RICHED20.DLL")
  127. i = GetDeviceCaps(UserControl.hdc, LOGPIXELSX)
  128. X = Width / 1440 * i
  129. i = GetDeviceCaps(UserControl.hdc, LOGPIXELSY)
  130. Y = Height / 1440 * i
  131. Module1.yDpi = i
  132. m_hWnd = CreateWindowEx(0, "RichEdit20A", _
  133.     Name, _
  134.     WS_VISIBLE Or WS_BORDER Or WS_CHILD Or ES_MULTILINE Or ES_NOHIDESEL Or WS_VSCROLL, _
  135.     0, _
  136.     0, _
  137.     X, _
  138.     Y, _
  139.     UserControl.hWnd, _
  140.     0, _
  141.     0, _
  142.     0)
  143. If m_hWnd = 0 Then
  144.     MsgBox ("Can't create window!")
  145. End If
  146. Module1.rtehwnd = m_hWnd
  147. zap (UserControl.hWnd)
  148. End Sub
  149. Private Sub UserControl_Resize()
  150. Dim r As Boolean
  151. r = MoveWindow(m_hWnd, 0, 0, ScaleWidth, ScaleHeight, 1)
  152. End Sub
  153. Private Sub UserControl_Terminate()
  154. Dim r As Boolean
  155. unzap (UserControl.hWnd)
  156. r = DestroyWindow(m_hWnd)
  157. End Sub
  158.