VB:如何允许/禁止RICHTEXTBOX中的OLE对象拉伸

        原理是先获得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