惯性聚合 高效追踪和阅读你感兴趣的博客、新闻、科技资讯
阅读原文 在惯性聚合中打开

推荐订阅源

酷 壳 – CoolShell
酷 壳 – CoolShell
量子位
V2EX - 技术
V2EX - 技术
K
Kaspersky official blog
Know Your Adversary
Know Your Adversary
Hacker News - Newest:
Hacker News - Newest: "LLM"
cs.AI updates on arXiv.org
cs.AI updates on arXiv.org
I
Intezer
H
Heimdal Security Blog
奇客Solidot–传递最新科技情报
奇客Solidot–传递最新科技情报
S
SegmentFault 最新的问题
阮一峰的网络日志
阮一峰的网络日志
博客园_首页
博客园 - Franky
GbyAI
GbyAI
T
The Blog of Author Tim Ferriss
Recorded Future
Recorded Future
freeCodeCamp Programming Tutorials: Python, JavaScript, Git & More
Vercel News
Vercel News
Apple Machine Learning Research
Apple Machine Learning Research
The Hacker News
The Hacker News
T
Tenable Blog
Recent Commits to openclaw:main
Recent Commits to openclaw:main
雷峰网
雷峰网
WordPress大学
WordPress大学
Blog — PlanetScale
Blog — PlanetScale
Application and Cybersecurity Blog
Application and Cybersecurity Blog
Webroot Blog
Webroot Blog
L
LangChain Blog
C
Check Point Blog
N
News | PayPal Newsroom
L
LINUX DO - 热门话题
T
Tor Project blog
V
Visual Studio Blog
Microsoft Security Blog
Microsoft Security Blog
S
Security Affairs
Schneier on Security
Schneier on Security
Hacker News: Ask HN
Hacker News: Ask HN
Stack Overflow Blog
Stack Overflow Blog
Y
Y Combinator Blog
Cyber Security Advisories - MS-ISAC
Cyber Security Advisories - MS-ISAC
Security Latest
Security Latest
MyScale Blog
MyScale Blog
Cyberwarzone
Cyberwarzone
N
Netflix TechBlog - Medium
Scott Helme
Scott Helme
PCI Perspectives
PCI Perspectives
The Last Watchdog
The Last Watchdog
人人都是产品经理
人人都是产品经理
W
WeLiveSecurity

博客园 - 学剑学诗两不成

VB:如何实现在代码中弹出toolbar的ButtonMenu VB:如何发送WM_KEYDOWN和WM_KEYUP消息 利用IDocHostUIHandler接口屏蔽WebBrowser的弹出菜单 VB:如何改变ComboBox自身的高度 VB:如何设置Richtextbox的行间距 一个很有用的自定义函数 - 学剑学诗两不成 - 博客园 VB:如何隐藏/显示treeview的ToolTips - 学剑学诗两不成 - 博客园 VB:如何启用/禁用本地连接 VB:如何选定文件或文件夹 - 学剑学诗两不成 - 博客园 一个远程调用api函数的模块(转贴) VB:如何用需要身份验证的SMTP邮件服务器发信 - 学剑学诗两不成 - 博客园 VB:如何监听打开的窗口和程序 VB:如何隐藏ListView的某一列 vb:如何禁止鼠标指针进入某个区域 如何使frame控件的caption居中显示 - 学剑学诗两不成 - 博客园 怎样去掉窗体上的图标 - 学剑学诗两不成 - 博客园 VB中对string array快速插入、删除某个元素的办法 - 学剑学诗两不成 - 博客园 bug:在windows xp下用ImageList_GetImageCount返回值不正确(VB) - 学剑学诗两不成 - 博客园 VB中字符串数组快速复制的一种方法 - 学剑学诗两不成 - 博客园
VB:如何允许/禁止RICHTEXTBOX中的OLE对象拉伸
学剑学诗两不成 · 2006-02-19 · via 博客园 - 学剑学诗两不成

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