home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1999 October / pcp156b.iso / handson / files / vbwkshp / richtext / Module1.bas next >
Encoding:
BASIC Source File  |  1999-03-30  |  6.1 KB  |  222 lines
  1. Attribute VB_Name = "Module1"
  2. Option Explicit
  3.  
  4. Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONTX) As Long
  5. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  6. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
  7.  
  8.  
  9. Const LF_FACESIZE = 32
  10. Const LOGPIXELSX = 88
  11. Const LOGPIXELSY = 90
  12. Const HORZRES = 8
  13. Const HORZSIZE = 4
  14. Const VERTRES = 10
  15. Const VERTSIZE = 6
  16.  
  17. ' size = 60
  18. Private Type LOGFONT
  19.         lfHeight As Long
  20.         lfWidth As Long
  21.         lfEscapement As Long
  22.         lfOrientation As Long
  23.         lfWeight As Long
  24.         lfItalic As Byte
  25.         lfUnderline As Byte
  26.         lfStrikeOut As Byte
  27.         lfCharSet As Byte
  28.         lfOutPrecision As Byte
  29.         lfClipPrecision As Byte
  30.         lfQuality As Byte
  31.         lfPitchAndFamily As Byte
  32. '        lfFaceName As String * 32
  33.         lfFaceName(LF_FACESIZE) As Byte
  34. End Type
  35.  
  36. ' size = 60
  37. Private Type CHOOSEFONTX
  38.         lStructSize As Long
  39.         hwndOwner As Long           '  caller's window handle
  40.         hdc As Long                 '  printer DC/IC or NULL
  41.         lpLogFont As Long           '  ptr. to a LOGFONT struct
  42.         iPointSize As Long          '  10 * size in points of selected font
  43.         flags As Long               '  enum. type flags
  44.         rgbColors As Long           '  returned text color
  45.         lCustData As Long           '  data passed to hook fn.
  46.         lpfnHook As Long            '  ptr. to hook function
  47.         lpTemplateName As String    '  custom template name
  48.         hInstance As Long           '  instance handle of.EXE that
  49.                                     '  contains cust. dlg. template
  50.         lpszStyle As String         '  return the style field here
  51.                                     '  must be LF_FACESIZE or bigger
  52.         nFontType As Integer        '  same value reported to the EnumFonts
  53.                                     '  call back with the extra FONTTYPE_
  54.                                     '  bits added
  55.         MISSING_ALIGNMENT As Integer
  56.         nSizeMin As Long            ' minimum pt size allowed &
  57.         nSizeMax As Long            ' max pt size allowed if
  58.                                     ' CF_LIMITSIZE is used
  59. End Type
  60.  
  61.  
  62. Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
  63. (ByVal lpPrevWndFunc As Long, _
  64. ByVal hwnd As Long, ByVal Msg As Long, _
  65. ByVal wParam As Long, ByVal lParam As Long) As Long
  66.  
  67. Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
  68. hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
  69.          
  70. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
  71. (ByVal hwnd As Long, ByVal nIndex As Long, _
  72. ByVal dwNewLong As Long) As Long
  73.  
  74. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  75.  
  76. Const GWL_WNDPROC = (-4)
  77.  
  78. Const WM_MOUSEMOVE = &H200
  79. Const WM_MOUSEACTIVATE = &H21
  80. Const WM_LBUTTONDBLCLK = &H203
  81. Const WM_LBUTTONDOWN = &H201
  82. Const WM_LBUTTONUP = &H202
  83. Const WM_KEYDOWN = &H100
  84. Const WM_KEYUP = &H101
  85. Const WM_RBUTTONDOWN = &H204
  86. Const WM_RBUTTONUP = &H205
  87. Const WM_NOTIFY = &H4E
  88. Const WM_COMMAND = &H111
  89.  
  90. Const TPM_CENTERALIGN = &H4&
  91. Const TPM_LEFTALIGN = &H0&
  92. Const TPM_LEFTBUTTON = &H0&
  93. Const TPM_RIGHTALIGN = &H8&
  94. Const TPM_RIGHTBUTTON = &H2&
  95.  
  96. Const EN_MSGFILTER = &H700
  97. Const EN_SELCHANGE = &H702
  98.  
  99. Type NMHDR
  100.     hwndFrom As Long
  101.     idfrom As Long
  102.     code As Long
  103. End Type
  104.  
  105. Type CHARRANGE
  106.     cpMin As Long
  107.     cpMax As Long
  108. End Type
  109.  
  110. Type SELCHANGE
  111.     nmhdrx As NMHDR
  112.     chrg As CHARRANGE
  113.     seltype As Integer
  114. End Type
  115.     
  116. Type MSGFILTER
  117.     nmhdrx As NMHDR
  118.     Msg As Integer
  119.     pad1 As Integer
  120.     wParam As Integer
  121.     pad2 As Integer
  122.     lParam As Long
  123. End Type
  124.  
  125. Const MF_BYPOSITION = &H400&
  126.  
  127.  
  128. ' this is the structure used to send formatting information
  129. ' to a Rich Text Control
  130. Private Type CHARFORMAT
  131.     cbSize As Integer
  132.     wPad1 As Integer
  133.     dwMask As Long
  134.     dwEffects As Long
  135.     yHeight As Long
  136.     yOffset As Long
  137.     crTextColor As Long
  138.     bCharSet As Byte
  139.     bPitchAndFamily As Byte
  140.     szFaceName(LF_FACESIZE) As Byte
  141.     wPad2 As Integer
  142. End Type
  143.  
  144. Const CFM_BOLD = 1
  145. Const CFM_FACE = &H20000000
  146. Const CFM_COLOR = &H40000000
  147. Const CFM_SIZE = &H80000000
  148. Const CFM_ITALIC = 2
  149. Const CFE_BOLD = 1
  150. Const CFE_ITALIC = 2
  151. Const SCF_SELECTION = 1
  152. Const WM_USER = &H400
  153. Const EM_SETCHARFORMAT = WM_USER + 68
  154.  
  155.  
  156. Private oldproc As Long
  157. Public faceName As String
  158. Public rtehwnd As Long
  159. Public yDpi As Integer
  160. Public Sub zap(h As Long)
  161.  
  162. oldproc = SetWindowLong(h, GWL_WNDPROC, AddressOf MyWndProc)
  163.  
  164. End Sub
  165. Public Sub unzap(h As Long)
  166. Dim r As Long
  167.  
  168. r = SetWindowLong(h, GWL_WNDPROC, oldproc)
  169.  
  170. End Sub
  171. Private Function MyWndProc(ByVal hwnd As Long, _
  172. ByVal iMsg As Long, _
  173. ByVal wParam As Long, _
  174. ByVal lParam As Long) As Long
  175. Dim nh As NMHDR, n As SELCHANGE, m As MSGFILTER
  176. Dim r As Boolean
  177. r = True
  178.  
  179. Select Case iMsg
  180. Case WM_NOTIFY
  181.     CopyMemory nh, ByVal lParam, 12
  182.     Select Case nh.code
  183.     Case EN_SELCHANGE
  184.         CopyMemory n, ByVal lParam, 22
  185.     Case EN_MSGFILTER
  186.         CopyMemory m, ByVal lParam, 24
  187.         If m.Msg = WM_RBUTTONDOWN Then
  188.             Call MyFormat(rtehwnd, SCF_SELECTION)
  189.             r = False
  190.         End If
  191.     End Select
  192. End Select
  193.  
  194. If r Then
  195. MyWndProc = CallWindowProc(oldproc, hwnd, iMsg, wParam, lParam)
  196. End If
  197. End Function
  198.  
  199. Public Function MyFormat(hwnd As Long, seltype As Long) As String
  200. Dim a As CHOOSEFONTX, b As LOGFONT, X As CHARFORMAT
  201. Dim r As Long, i As Integer, s As String
  202.  
  203. a.lStructSize = 60
  204. a.flags = cdlCFScreenFonts
  205. a.lpLogFont = VarPtr(b)
  206. If ChooseFont(a) <> 0 Then
  207.     X.cbSize = 60
  208.     X.dwMask = CFM_FACE Or CFM_SIZE Or CFM_BOLD Or CFM_COLOR
  209.     For i = 0 To LF_FACESIZE
  210.         X.szFaceName(i) = b.lfFaceName(i)
  211.         s = s + Chr(b.lfFaceName(i))
  212.     Next
  213.     X.yHeight = -1440 * b.lfHeight / yDpi
  214.     r = SendMessage(hwnd, EM_SETCHARFORMAT, seltype, X)
  215.     faceName = s
  216. Else
  217.     s = faceName
  218. End If
  219.  
  220. MyFormat = s
  221. End Function
  222.