Rich Text Spell Check

P

PC User

Please help.

I found code to spell check rich text by using the MS Word spell
checker; however, it does not return the resulting text as rich text,
only as plain text. Can someone help me code this so it returns the
text as rich text. I placed this code in a module named
"basRTF2WordSpellCheck" My prototype DB is located at:
http://www.dbforums.com/showthread.php?p=3674830#post3674830

Code:
=======================================================================
Option Compare Database

'Spell Check using Richtextbox to Word then back Method
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As
Long) As Long
Private Declare Function RegisterClipboardFormat Lib "User32" Alias _
"RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function SetClipboardData Lib "User32" ( _
ByVal wformat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "User32" (ByVal wformat
As _
Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wflags As
Long, _
ByVal dwbytes As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (
_
ByVal destination As Long, source As Any, ByVal length As Long)
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As
Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As
Long) As Long
Private Declare Function GlobalFree Lib "kernel32" ( _
ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" (ByVal lstring1 As
Any, _
ByVal lstring2 As Any) As Long

Private Const GHND = &O42
Private Const CF_TEXT = 1
'Private Const CF_RTFTEXT = &HFFFFBF01
Private Const MAXSIZE = 4096
Private Const GMEM_DDESHARE = &H2000
Private Const GMEM_MOVEABLE = &H2

'=======================================================================
'Spell Check using Richtextbox to Word then back Method
'To use this function, place "=SpellCheck()" in the
'OnClick event for a command button on your form.
'=======================================================================
Public Function SpellCheck()

On Error GoTo SmartFormError

Dim sRTF As String
sRTF = Forms![frmRTFEditor]![RichText]
Dim Wrtf As String
Dim lSuccess As Long
Dim lRtf As Long
Dim hGlobal As Long
Dim lpString As Long
Dim lOrgTop As Long
lSuccess = OpenClipboard(Forms![frmRTFEditor]![RichText].hwnd)
lRtf = RegisterClipboardFormat("Rich Text Format")
lSuccess = EmptyClipboard
hGlobal = GlobalAlloc(GMEM_MOVEABLE Or GMEM_DDESHARE, Len(sRTF))
lpString = GlobalLock(hGlobal)
CopyMemory lpString, ByVal sRTF, Len(sRTF)
GlobalUnlock hGlobal
SetClipboardData lRtf, hGlobal
CloseClipboard
GlobalFree hGlobal
Dim oWord As Object
Dim oDoc As Object
Set oWord = CreateObject("Word.Application")
Set oDoc = oWord.Documents.Add
oWord.Visible = True
lOrgTop = oWord.Top
oWord.WindowState = 0
oWord.Top = -3000
oWord.Selection.Paste
oDoc.Activate
oDoc.CheckSpelling

oWord.Selection.WholeStory
oWord.Selection.Copy

Dim hClipMemory As Long
Dim lpClipMemory As Long
Dim mystring As String
Dim Retval As Long

If OpenClipboard(0&) = 0 Then
MsgBox "cannot open Clipboard. Another app. may have it open"
GoTo OutofHere
End If
hClipMemory = GetClipboardData(CF_TEXT)
'hClipMemory = GetClipboardData(CF_RTFTEXT)
If IsNull(hClipMemory) Then
MsgBox "Could not allocate memory"
GoTo OutofHere
End If
lpClipMemory = GlobalLock(hClipMemory)

If Not IsNull(lpClipMemory) Then
mystring = Space$(MAXSIZE)
Retval = lstrcpy(mystring, lpClipMemory)
Retval = GlobalUnlock(hClipMemory)
mystring = Mid(mystring, 1, InStr(1, mystring, Chr$(0), 0) - 1)
Else
MsgBox "could not look to copy string from."
End If

OutofHere:
Retval = CloseClipboard()
Forms![frmRTFEditor]![RichText] = mystring
With oWord
.ActiveDocument.Close savechanges:=False
.Quit
End With

Exit_SmartFormError:
Exit Function

SmartFormError:

If Err = 2046 Or Err = 2501 Then
Resume Next
ElseIf Err = 440 Then
MsgBox "Error In Spell Check Function."
Resume Exit_SmartFormError
Else
MsgBox Err.Description
Resume Exit_SmartFormError
End If

End Function
=======================================================================
 
S

Stephen Lebans

With a quick glance at your code I would say that you have to use the
value returned by your call to RegisterClipboardFormat as the param for
your GetClipboardData call. There's code on my site showing you how to
Copy/Paste RTF encoded text.

You might consider another approach that would not require any API
calls.
1) Setfocus to the RTF control on the Access form
2) Use the Selxx props to select the desired RTF data
3) Invoke the COPY method of the RTF control
4) SetFocus to your WOrd app
5) Invoke the Paste method of the Word Doc
6) Invoke the Word Spell Checker
7) Select all of the Documents Text
8) Invoke the Word Doc's Copy method
9) Setfocus back to the Access application
10) Setfocus back to Rich Text Control on your form
11) Invoke the Paste method the Rich Text control

--

HTH
Stephen Lebans
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.


PC User said:
Please help.

I found code to spell check rich text by using the MS Word spell
checker; however, it does not return the resulting text as rich text,
only as plain text. Can someone help me code this so it returns the
text as rich text. I placed this code in a module named
"basRTF2WordSpellCheck" My prototype DB is located at:
http://www.dbforums.com/showthread.php?p=3674830#post3674830

Code:
=======================================================================
Option Compare Database

'Spell Check using Richtextbox to Word then back Method
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As
Long) As Long
Private Declare Function RegisterClipboardFormat Lib "User32" Alias _
"RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function SetClipboardData Lib "User32" ( _
ByVal wformat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "User32" (ByVal wformat
As _
Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wflags As
Long, _
ByVal dwbytes As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (
_
ByVal destination As Long, source As Any, ByVal length As Long)
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As
Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As
Long) As Long
Private Declare Function GlobalFree Lib "kernel32" ( _
ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" (ByVal lstring1 As
Any, _
ByVal lstring2 As Any) As Long

Private Const GHND = &O42
Private Const CF_TEXT = 1
'Private Const CF_RTFTEXT = &HFFFFBF01
Private Const MAXSIZE = 4096
Private Const GMEM_DDESHARE = &H2000
Private Const GMEM_MOVEABLE = &H2

'=======================================================================
'Spell Check using Richtextbox to Word then back Method
'To use this function, place "=SpellCheck()" in the
'OnClick event for a command button on your form.
'=======================================================================
Public Function SpellCheck()

On Error GoTo SmartFormError

Dim sRTF As String
sRTF = Forms![frmRTFEditor]![RichText]
Dim Wrtf As String
Dim lSuccess As Long
Dim lRtf As Long
Dim hGlobal As Long
Dim lpString As Long
Dim lOrgTop As Long
lSuccess = OpenClipboard(Forms![frmRTFEditor]![RichText].hwnd)
lRtf = RegisterClipboardFormat("Rich Text Format")
lSuccess = EmptyClipboard
hGlobal = GlobalAlloc(GMEM_MOVEABLE Or GMEM_DDESHARE, Len(sRTF))
lpString = GlobalLock(hGlobal)
CopyMemory lpString, ByVal sRTF, Len(sRTF)
GlobalUnlock hGlobal
SetClipboardData lRtf, hGlobal
CloseClipboard
GlobalFree hGlobal
Dim oWord As Object
Dim oDoc As Object
Set oWord = CreateObject("Word.Application")
Set oDoc = oWord.Documents.Add
oWord.Visible = True
lOrgTop = oWord.Top
oWord.WindowState = 0
oWord.Top = -3000
oWord.Selection.Paste
oDoc.Activate
oDoc.CheckSpelling

oWord.Selection.WholeStory
oWord.Selection.Copy

Dim hClipMemory As Long
Dim lpClipMemory As Long
Dim mystring As String
Dim Retval As Long

If OpenClipboard(0&) = 0 Then
MsgBox "cannot open Clipboard. Another app. may have it open"
GoTo OutofHere
End If
hClipMemory = GetClipboardData(CF_TEXT)
'hClipMemory = GetClipboardData(CF_RTFTEXT)
If IsNull(hClipMemory) Then
MsgBox "Could not allocate memory"
GoTo OutofHere
End If
lpClipMemory = GlobalLock(hClipMemory)

If Not IsNull(lpClipMemory) Then
mystring = Space$(MAXSIZE)
Retval = lstrcpy(mystring, lpClipMemory)
Retval = GlobalUnlock(hClipMemory)
mystring = Mid(mystring, 1, InStr(1, mystring, Chr$(0), 0) - 1)
Else
MsgBox "could not look to copy string from."
End If

OutofHere:
Retval = CloseClipboard()
Forms![frmRTFEditor]![RichText] = mystring
With oWord
.ActiveDocument.Close savechanges:=False
.Quit
End With

Exit_SmartFormError:
Exit Function

SmartFormError:

If Err = 2046 Or Err = 2501 Then
Resume Next
ElseIf Err = 440 Then
MsgBox "Error In Spell Check Function."
Resume Exit_SmartFormError
Else
MsgBox Err.Description
Resume Exit_SmartFormError
End If

End Function
Click to expand...
=======================================================================
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

clipboard image to image control via code 2
Custom icon with a Form 3
VBA: calling sdk function sendmessage from access fails for keyup, keydown, WM_SETTEXT 0
closing an opend application 9
access 2007 compact creates new database 1
Stephen Lebans clsToolTip for Access version 1.4 0
Need expert help 3
listbox align right 1

Top