VB中实现GIF嵌入到RichTextBox

原帖：http://blog.csdn.net/Modest/archive/2006/04/12/660890.aspx

 

实际上还可以嵌入其他组件，比如Windows Media Player等，下面以比较成熟的QQ的ImageOle为例。

需要组件：
ImageOle.dll   在QQ的目录下找，如果非XP系统则还需要GdiPlus.dll。
OleLib.tlb         下载地址：http://www.mvps.org/emorcillo/download/vb6/tl_ole.zip 引用两个组件后，在窗体添加一个RichTextBox1，然后将下面代码放在.bas中

Option Explicit Private Declare Sub ZeroMemory Lib "KERNEL32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long) Private Declare Function InvalidateRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT, ByVal bErase As Long) As Long Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long Public Declare Function UpdateWindow Lib "user32.dll" (ByVal hwnd As Long) As Long Public 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 Const WM_USER = &H400 Private Const EM_GETOLEINTERFACE = (WM_USER + 60) Private Const EM_POSFROMCHAR = (WM_USER + 38) Public Enum reCharPos reSelection = -1 End Enum Public Enum reObjectAspect reObjectAspectContent = DVASPECT_CONTENT reObjectAspectIcon = DVASPECT_ICON End Enum Public Function AddClass(hwnd As Long, ObjIUnknown As stdole.IUnknown, _ Optional ByVal CharPos As Long = reSelection, _ Optional ByVal InitialAspect As reObjectAspect = reObjectAspectContent) As IRichEditOle Dim OleObject As olelib.IOleObject Dim Storage As olelib.IStorage Dim ClientSite As olelib.IOleClientSite Dim tOUIIO As olelib.OLEUIINSERTOBJECT Dim REOBJ As olelib.REOBJECT Dim CLSID As olelib.UUID Dim hMFPict As Long Dim mILockBytes As ILockBytes '创建Global Heap，实例化mILockBytes Set mILockBytes = CreateILockBytesOnHGlobal(0&, True) '创建storage，实例化mIStorage Set Storage = StgCreateDocfileOnILockBytes(mILockBytes, STGM_SHARE_EXCLUSIVE _ Or STGM_CREATE Or STGM_READWRITE, 0) Dim RichEditOle As IRichEditOle SendMessage hwnd, EM_GETOLEINTERFACE, 0&, RichEditOle Set ClientSite = RichEditOle.GetClientSite ' Set Storage = StgCreateDocfile(vbNullString, STGM_CREATE Or STGM_READWRITE Or STGM_DELETEONRELEASE Or STGM_SHARE_EXCLUSIVE) Set OleObject = ObjIUnknown OleObject.GetUserClassID CLSID On Error Resume Next If hMFPict = 0 Then hMFPict = OleGetIconOfClass(CLSID, vbNullString, 1) If Err.Number <> 0 Then InitialAspect = reObjectAspectContent On Error GoTo 0 OleSetContainedObject ObjIUnknown, 1 With REOBJ .cbStruct = Len(REOBJ) LSet .CLSID = CLSID .DVASPECT = DVASPECT_CONTENT .cp = REO_CP_SELECTION .dwFlags = REO_DYNAMICSIZE .sizel.cx = 0 .sizel.cy = 0 .dwUser = 0 Set .pStg = Storage Set .polesite = ClientSite Set .poleobj = ObjIUnknown End With RichEditOle.InsertObject REOBJ ZeroMemory REOBJ, LenB(REOBJ) ZeroMemory CLSID, LenB(CLSID) Set AddClass = RichEditOle Set OleObject = Nothing Set ClientSite = Nothing Set Storage = Nothing SendMessage hwnd, &HF, 0, 0 End Function

使用方法：
Dim g As New GifAnimator g.LoadFromFile "C:/xx.gif" AddClass RichTextBox1.hwnd, g