'说明：表单一个；命令按钮一个为CmdInsertObject；RichTextBox控件一个为RichTextBox1
Option Explicit
Private Declare Function OleUIInsertObject Lib "oledlg.dll" Alias "OleUIInsertObjectA" (inParam As Any) As Long
Private Declare Function ProgIDFromCLSID Lib "ole32.dll" (clsid As Any, strAddess As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pvoid As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type OleUIInsertObjectType
cbStruct As Long
dwFlags As Long
hWndOwner As Long
lpszCaption As String
lpfnHook As Long
lCustData As Long
hInstance As Long
lpszTemplate As String
hResource As Long
clsid As GUID
lpszFile As String
cchFile As Long
cClsidExclude As Long
lpClsidExclude As Long
IID As GUID
oleRender As Long
lpFormatEtc As Long
lpIOleClientSite As Long
lpIStorage As Long
ppvObj As Long
sc As Long
hMetaPict As Long
End Type
Private Const IOF_SHOWHELP = &H1
Private Const IOF_SELECTCREATENEW = &H2
Private Const IOF_SELECTCREATEFROMFILE = &H4
Private Const IOF_CHECKLINK = &H8
Private Const IOF_CHECKDISPLAYASICON = &H10
Private Const IOF_CREATENEWOBJECT = &H20
Private Const IOF_CREATEFILEOBJECT = &H40
Private Const IOF_CREATELINKOBJECT = &H80
Private Const IOF_DISABLELINK = &H100
Private Const IOF_VERIFYSERVERSEXIST = &H200
Private Const IOF_DISABLEDISPLAYASICON = &H400
Private Const IOF_HIDECHANGEICON = &H800
Private Const IOF_SHOWINSERTCONTROL = &H1000
Private Const IOF_SELECTCREATECONTROL = &H2000
Private Const OLEUI_FALSE = 0
Private Const OLEUI_OK = 1
Private Const OLEUI_CANCEL = 2
Private Sub CmdInsertObject_Click()
Dim lu_InsertObject As OleUIInsertObjectType
Dim ll_ReturnValue As Long
Dim ll_StringPointer As Long
Dim ll_TextLength As Long
Dim ls_ProgID As String
' 初始化插入对象
With lu_InsertObject
.cbStruct = LenB(lu_InsertObject)
.dwFlags = IOF_SELECTCREATENEW
.hWndOwner = Me.hWnd
.lpszFile = Space(255)
.cchFile = 255
End With
'显示插入对象对话框
ll_ReturnValue = OleUIInsertObject(lu_InsertObject)
If ll_ReturnValue = OLEUI_OK Then
If (lu_InsertObject.dwFlags And IOF_SELECTCREATENEW) = IOF_SELECTCREATENEW Then
'选择"新建"按钮时
'给出进程ID与类ID
ll_ReturnValue = ProgIDFromCLSID(lu_InsertObject.clsid, ll_StringPointer)
'进程ID长度，是Unicode字符串
ll_TextLength = lstrlenW(ll_StringPointer) + 1
'初始化字符串
ls_ProgID = Space(ll_TextLength)
'拷贝ll_StringPointer指针到字符串ls_ProgID
CopyMemory ByVal StrPtr(ls_ProgID), ByVal ll_StringPointer, ll_TextLength * 2
'清除内存
CoTaskMemFree ll_StringPointer
'添加对象到RichTextBox中
RichTextBox1.OLEObjects.Add , , "", ls_ProgID
Else
'选择："从文件创建"时
RichTextBox1.OLEObjects.Add , , lu_InsertObject.lpszFile
End If
End If
End Sub
|
