原理是先获得richtextbox的 IRichEditOle接口，由于IRichEditOle接口没有提供setobject方法，所以我们需要变通实现，大致步骤是：
1.利用 IRichEditOle接口的getobject方法获得richtextbox指定的ole对象的信息，对象的信息包含在REOBJECT结构体中
2.删除指定的ole对象
3.修改结构体中的dwFlags成员(当然你也可以修改其它的成员)后，调用IRichEditOle接口的InsertObject
方法重新插入对象
需要指出的是，我在获得REOBJECT结构体之后曾经想只改变dwFlags成员，其它的成员原样不变的插入到richtextbox中，但是，很明显的我的懒惰使我遇到了一个严重的错误，在退出程序时，VB崩溃了，我想到这是对象生存周期的问题，于是想通过序列化和反序列化IOleClientSite及 IStorage来实现，应该说，用VB这么做是一件很费力气的事情，所以变通了一下，具体的看代码吧：
'窗体上一个按钮，一个richtextbox：
Option Explicit
'rainstormmaster写于2006年2月19日凌晨
'转载请保留上述信息
Private Const WM_USER = &H400
Private Const EM_GETOLEINTERFACE = WM_USER + 60
Private Const EM_POSFROMCHAR = (WM_USER + 38)
Private Const EM_EXGETSEL = (WM_USER + 52)
Private Const EM_EXSETSEL = (WM_USER + 55)
Private Type CharRange
cpMin As Long
cpMax As Long
End Type
Private Declare Function PutFocus Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
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
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long)
'改变richtextbox中索引(从0开始)为index的oleobject的dwFlags，如果index小于等于-1，则应用于全部对象
Private Sub changeReobjectsFlag(ByVal mHwnd As Long, ByVal newFlag As REO_FLAGS, Optional index As Long = -1)
Dim mIRichEditOle As IRichEditOle
Dim mReObject As REOBJECT
Dim mILockBytes As ILockBytes
Dim OldCharRange As CharRange
Dim NewCharRange As CharRange
Dim objCount As Long
Dim mIStorage As IStorage
Dim mIOleClientSite As IOleClientSite
Dim mIOleObject As IOleObject
Dim mUUID As UUID
SendMessage mHwnd, EM_GETOLEINTERFACE, 0, mIRichEditOle
If ObjPtr(mIRichEditOle) = 0 Then
MsgBox "Error to get IRichEditOle"
Exit Sub
End If
'获得richtextbox中oleobject的数量
objCount = mIRichEditOle.GetObjectCount
If objCount = 0 Then
MsgBox "richtextbox中没有包含oleobject"
Set mIRichEditOle = Nothing
Exit Sub
End If
If index <= -1 Then '全部改变
'记录下richtextbox当前选定的内容
SendMessage mHwnd, EM_EXGETSEL, 0, OldCharRange
Dim i As Long
For i = 0 To objCount - 1
' '获得oleobject的信息
mReObject.cbStruct = LenB(mReObject)
mIRichEditOle.GetObject i, mReObject, REO_GETOBJ_ALL_INTERFACES
Set mIOleObject = mReObject.poleobj
With NewCharRange
.cpMin = mReObject.cp
.cpMax = mReObject.cp
End With
'删除当前的oleobject
'只所以不用selstart之类的属性控制，是因为ReObject.cp是基于字节的
PutFocus mHwnd
SendMessage mHwnd, EM_EXSETSEL, 0, NewCharRange
SendKeys "{DEL}", True
'改变dwflags后重新插入oleobject
Set mILockBytes = CreateILockBytesOnHGlobal(0&, True)
If ObjPtr(mILockBytes) = 0 Then
MsgBox "Error to create Global Heap"
Exit Sub
End If
'创建storage，实例化mIStorage
Set mIStorage = StgCreateDocfileOnILockBytes(mILockBytes, STGM_SHARE_EXCLUSIVE _
Or STGM_CREATE Or STGM_READWRITE, 0)
If ObjPtr(mIStorage) = 0 Then
MsgBox "Error to create storage"
Exit Sub
End If
'调用GetClientSite函数，实例化mIOleClientSite
Set mIOleClientSite = mIRichEditOle.GetClientSite
If ObjPtr(mIOleClientSite) = 0 Then
MsgBox "Error to get ClientSite"
Exit Sub
End If
OleSetContainedObject mIOleObject, True
mIOleObject.GetUserClassID mUUID
With mReObject
.cbStruct = LenB(mReObject)
.clsid = mUUID
.cp = REO_CP_SELECTION
.dwFlags = newFlag
Set .poleobj = mIOleObject
Set .polesite = mIOleClientSite
Set .pStg = mIStorage
End With
'恢复richtextbox原来选定的内容
mIRichEditOle.InsertObject mReObject
Next
SendMessage mHwnd, EM_EXSETSEL, 0, OldCharRange
Else
If index > objCount - 1 Then
MsgBox "无效的索引，请检查index属性值"
Set mIRichEditOle = Nothing
Exit Sub
Else
'记录下richtextbox当前选定的内容
SendMessage mHwnd, EM_EXGETSEL, 0, OldCharRange
'获得oleobject的信息
mReObject.cbStruct = LenB(mReObject)
mIRichEditOle.GetObject index, mReObject, REO_GETOBJ_ALL_INTERFACES
Set mIOleObject = mReObject.poleobj
'获得当前对象在richtextbox中的位置
With NewCharRange
.cpMin = mReObject.cp
.cpMax = mReObject.cp
End With
'删除当前的oleobject
'只所以不用selstart之类的属性控制，是因为ReObject.cp是基于字节的
PutFocus mHwnd
SendMessage mHwnd, EM_EXSETSEL, 0, NewCharRange
SendKeys "{DEL}", True
'改变dwflags后重新插入oleobject
Set mILockBytes = CreateILockBytesOnHGlobal(0&, True)
If ObjPtr(mILockBytes) = 0 Then
MsgBox "Error to create Global Heap"
Exit Sub
End If
'创建storage，实例化mIStorage
Set mIStorage = StgCreateDocfileOnILockBytes(mILockBytes, STGM_SHARE_EXCLUSIVE _
Or STGM_CREATE Or STGM_READWRITE, 0)
If ObjPtr(mIStorage) = 0 Then
MsgBox "Error to create storage"
Exit Sub
End If
'调用GetClientSite函数，实例化mIOleClientSite
Set mIOleClientSite = mIRichEditOle.GetClientSite
If ObjPtr(mIOleClientSite) = 0 Then
MsgBox "Error to get ClientSite"
Exit Sub
End If
OleSetContainedObject mIOleObject, True
mIOleObject.GetUserClassID mUUID
With mReObject
.cbStruct = LenB(mReObject)
.clsid = mUUID
.cp = REO_CP_SELECTION
.dwFlags = newFlag
Set .poleobj = mIOleObject
Set .polesite = mIOleClientSite
Set .pStg = mIStorage
End With
mIRichEditOle.InsertObject mReObject
'恢复richtextbox原来选定的内容
SendMessage mHwnd, EM_EXSETSEL, 0, OldCharRange
End If
End If
'释放资源
Set mIRichEditOle = Nothing
Set mILockBytes = Nothing
Set mIStorage = Nothing
Set mIOleClientSite = Nothing
Set mIOleObject = Nothing
End Sub
Private Sub Command1_Click()
changeReobjectsFlag Me.RichTextBox1.hwnd, REO_BELOWBASELINE, 0
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
RichTextBox1.TextRTF = ""
End Sub
