对象的前期绑定与后期绑定使用方法(CLSID-ProgID对照)

yangyangzhifeng · 发表于 2016-12-27 12:34

本帖最后由 yangyangzhifeng 于 2016-12-27 18:31 编辑

在学习字典，正则表达式等对象时，我们都知道有后绑定及前绑定的方法，
那么我们怎么知道要引用什么？又要怎样写后绑定代码呢？其实这些信息
都在注册表里面。前期绑定可以引用类型库别名或者类型库文件，字典为例
类库名称引用（A列第二行） Microsoft Scripting Runtime
类库文件引用（A列第一行） C:\WINDOWS\system32\scrrun.dll
后期绑定也有两种形式,一种是用ProgID,一种是直接使用CLSID，
以字典为例：
set d=createobject("Scripting.Dictionary") 'C列
set d=CreateObject("new:{EE09B103-97E0-11CF-978F-00A02463E06F}")'B列
其中第2种实用性更强，因为类型库必须有CLSID，但不一定有ProgID,但用ProgID
会比较好理解。
本程序可以搜索本机注册表中的所有TypeLib，将文件路径和需要的引用项目列出
在A列，将个类型库的子类列出到B,C,D列，其中B列是CLSID，C列是对应的ProgID
（可能为空），D列是对应的默认名称（可能为空）

Option Explicit
Private Const HKEY_CLASSES_ROOT As Long = &H80000000
Private Const READ_CONTROL As Long = &H20000
Private Const STANDARD_RIGHTS_READ As Long = (READ_CONTROL)
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_NOTIFY As Long = &H10
Private Const SYNCHRONIZE As Long = &H100000
Private Const KEY_READ As Long = (( _
STANDARD_RIGHTS_READ _
Or KEY_QUERY_VALUE _
Or KEY_ENUMERATE_SUB_KEYS _
Or KEY_NOTIFY) _
And (Not SYNCHRONIZE))
Private Const ERROR_SUCCESS As Long = 0&
Private Const ERROR_NO_MORE_ITEMS As Long = 259&
Private Declare Function RegOpenKeyEx _
Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
ByRef phkResult As Long) As Long
Private Declare Function RegEnumKey _
Lib "advapi32.dll" Alias "RegEnumKeyA" ( _
ByVal hKey As Long, _
ByVal dwIndex As Long, _
ByVal lpName As String, _
ByVal cbName As Long) As Long
Private Declare Function RegQueryValue _
Lib "advapi32.dll" Alias "RegQueryValueA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal lpValue As String, _
ByRef lpcbValue As Long) As Long
Private Declare Function RegCloseKey _
Lib "advapi32.dll" ( _
ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As _
Long, lpData As Any, lpcbData As Long) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Declare Function ProgIDFromCLSID Lib "ole32.dll" (ByRef CLSID As Any, ByRef lplpszProgID As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByRef pclsid As Any) As Long
Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Dim R As Long
Sub TypeLibList()
Dim R1 As Long
Dim R2 As Long
Dim hHK1 As Long
Dim hHK2 As Long
Dim hHK3 As Long
Dim hHK4 As Long
Dim i As Long
Dim i2 As Long
Dim lpPath As String
Dim lpGUID As String
Dim lpName As String
Dim lpValue As String
Application.ScreenUpdating = False
Cells.Clear: R = 1: Cells(1, 1).Resize(1, 4) = Split("类型库文件路径\类型库引用名称|CLSID|ProgID|默认名称", "|")
lpPath = String$(128, vbNullChar)
lpValue = String$(128, vbNullChar)
lpName = String$(128, vbNullChar)
lpGUID = String$(128, vbNullChar)
R1 = RegOpenKeyEx(HKEY_CLASSES_ROOT, "TypeLib", ByVal 0&, KEY_READ, hHK1)
If R1 = ERROR_SUCCESS Then
i = 0:
Do While Not R1 = ERROR_NO_MORE_ITEMS
R1 = RegEnumKey(hHK1, i, lpGUID, Len(lpGUID))
If R1 = ERROR_SUCCESS Then
R2 = RegOpenKeyEx(hHK1, lpGUID, ByVal 0&, KEY_READ, hHK2)
If R2 = ERROR_SUCCESS Then
i2 = 0
Do While Not R2 = ERROR_NO_MORE_ITEMS
R2 = RegEnumKey(hHK2, i2, lpName, Len(lpName)) '1.0
If R2 = ERROR_SUCCESS Then
RegQueryValue hHK2, lpName, lpValue, Len(lpValue)
RegOpenKeyEx hHK2, lpName, ByVal 0&, KEY_READ, hHK3
RegOpenKeyEx hHK3, "0", ByVal 0&, KEY_READ, hHK4
RegQueryValue hHK4, "win32", lpPath, Len(lpPath)
i2 = i2 + 1
Cells(R + 1, 1) = IIf(InStr(lpPath, vbNullChar), Left(lpPath, InStr(lpPath, vbNullChar) - 1), lpPath) & Chr(10) _
& IIf(InStr(lpValue, vbNullChar), Left(lpValue, InStr(lpValue, vbNullChar) - 1), lpValue) & Chr(10)
ProgIDFromFile lpPath
End If
Loop
End If
End If
i = i + 1
Loop
RegCloseKey hHK1
RegCloseKey hHK2
RegCloseKey hHK3
RegCloseKey hHK4
End If
Application.ScreenUpdating = True
End Sub
Private Sub ProgIDFromFile(TypeLibFile$)
Dim CLSID As GUID, strProgID$, lpszProgID&
Dim TLIApp As Object
Dim TLBInfo As Object
Dim TypeInf As Object
Set TLIApp = New TLI.TLIApplication
Dim ProgID As String
Dim strCLSID As String
On Error GoTo Exitpoint
Set TLBInfo = TLIApp.TypeLibInfoFromFile(TypeLibFile)
For Each TypeInf In TLBInfo.CoClasses
ProgID = TypeInf.Name
strCLSID = TypeInf.GUID
If CLSIDFromString(StrPtr(strCLSID), CLSID) = 0 Then
R = R + 1: Cells(R, 2) = strCLSID
Cells(R, 4) = CLSIDDefaultValue(strCLSID)
If ProgIDFromCLSID(CLSID, lpszProgID) = 0 Then
SysReAllocString VarPtr(strProgID), lpszProgID
Cells(R, 3) = strProgID
End If
End If
Next
Exitpoint:
End Sub
Private Function CLSIDDefaultValue(strCLSID$) As String
Dim ret As Long
Dim key As Long
Dim length As Long
ret = RegOpenKey(HKEY_CLASSES_ROOT, "CLSID", key)
ret = RegOpenKey(key, strCLSID, key)
'先取数据区的长度
ret = RegQueryValueEx(key, "", 0, 1, ByVal 0, length)
'准备数据区
If length = 0 Then Exit Function
Dim buff() As Byte
ReDim buff(length - 1)
'读取数据
ret = RegQueryValueEx(key, "", 0, 1, buff(0), length)
Dim val As String
'去掉末尾的空字符,VB不需要这个
ReDim Preserve buff(length - 2)
'转化为VB中的字符串
CLSIDDefaultValue = StrConv(buff, vbUnicode)
RegCloseKey (key)
End Function

复制代码

引用.7z (16.59 KB, 下载次数: 114)

huang1314wei · 发表于 2016-12-27 12:56

把你的电脑上这个dll文件共享一下，我电脑win10没有这个dll文件

fxl447098457 · 发表于 2016-12-27 13:13

我也是win10，64位的1607版本可以正常运行的，安装个vb6吧。

fxl447098457 · 发表于 2016-12-27 13:22

huang1314wei 发表于 2016-12-27 12:56
把你的电脑上这个dll文件共享一下，我电脑win10没有这个dll文件

你的dll.

TLBINF32.rar (52 KB, 下载次数: 117)

huang1314wei · 发表于 2016-12-27 13:41

fxl447098457 发表于 2016-12-27 13:22
你的dll.

感谢热心帮助，注册成功

yangyangzhifeng · 发表于 2016-12-29 18:18

我写这一帖的目的是方便初学者学习的，在论坛大家学习别人的代码时，
大部分老师为了大家方便利用，一般都用的后期绑定，为了便于学习各
种对象的方法，属性，还是前期绑定方便，因为前期绑定写代码时IDE
会有提示，但是对于初学者来说要找到引用条目不容易，比喻以下项目：
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText strText
.PutInClipboard
End With
我们知道这个是利用CLSID创建对象，通过搜索CLSID我们知道知道需
要引用C:\WINDOWS\system32\FM20.DLL这个文件，但路径可能和我
的不一定一样.

今天整理代码发现类库下面的子类与CLSID是多对一，就是不同的类库
可能有相同的子类对应同一个CLSID，而在系统中一个CLSID只对应一个
默认的库文件，现在修正代码，默认的库文件放在E列

Option Explicit
Private Const HKEY_CLASSES_ROOT As Long = &H80000000
Private Const READ_CONTROL As Long = &H20000
Private Const STANDARD_RIGHTS_READ As Long = (READ_CONTROL)
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_NOTIFY As Long = &H10
Private Const SYNCHRONIZE As Long = &H100000
Private Const KEY_READ As Long = (( _
STANDARD_RIGHTS_READ _
Or KEY_QUERY_VALUE _
Or KEY_ENUMERATE_SUB_KEYS _
Or KEY_NOTIFY) _
And (Not SYNCHRONIZE))
Private Const ERROR_SUCCESS As Long = 0&
Private Const ERROR_NO_MORE_ITEMS As Long = 259&
Private Declare Function RegOpenKeyEx _
Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
ByRef phkResult As Long) As Long
Private Declare Function RegEnumKey _
Lib "advapi32.dll" Alias "RegEnumKeyA" ( _
ByVal hKey As Long, _
ByVal dwIndex As Long, _
ByVal lpName As String, _
ByVal cbName As Long) As Long
Private Declare Function RegQueryValue _
Lib "advapi32.dll" Alias "RegQueryValueA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal lpValue As String, _
ByRef lpcbValue As Long) As Long
Private Declare Function RegCloseKey _
Lib "advapi32.dll" ( _
ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As _
Long, lpData As Any, lpcbData As Long) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Declare Function ProgIDFromCLSID Lib "ole32.dll" (ByRef CLSID As Any, ByRef lplpszProgID As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByRef pclsid As Any) As Long
Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Dim R As Long
Sub TypeLibList()
Dim R1 As Long
Dim R2 As Long
Dim hHK1 As Long
Dim hHK2 As Long
Dim hHK3 As Long
Dim hHK4 As Long
Dim i As Long
Dim i2 As Long
Dim lpPath As String
Dim lpGUID As String
Dim lpName As String
Dim lpValue As String
Application.ScreenUpdating = False
Cells.Clear: R = 1: Cells(1, 1).Resize(1, 5) = Split("类型库文件路径\类型库引用名称|CLSID|ProgID|默认名称|CLSID对应的库文件", "|")
lpPath = String$(128, vbNullChar)
lpValue = String$(128, vbNullChar)
lpName = String$(128, vbNullChar)
lpGUID = String$(128, vbNullChar)
R1 = RegOpenKeyEx(HKEY_CLASSES_ROOT, "TypeLib", ByVal 0&, KEY_READ, hHK1)
If R1 = ERROR_SUCCESS Then
i = 0:
Do While Not R1 = ERROR_NO_MORE_ITEMS
R1 = RegEnumKey(hHK1, i, lpGUID, Len(lpGUID))
If R1 = ERROR_SUCCESS Then
R2 = RegOpenKeyEx(hHK1, lpGUID, ByVal 0&, KEY_READ, hHK2)
If R2 = ERROR_SUCCESS Then
i2 = 0
Do While Not R2 = ERROR_NO_MORE_ITEMS
R2 = RegEnumKey(hHK2, i2, lpName, Len(lpName)) '1.0
If R2 = ERROR_SUCCESS Then
RegQueryValue hHK2, lpName, lpValue, Len(lpValue)
RegOpenKeyEx hHK2, lpName, ByVal 0&, KEY_READ, hHK3
RegOpenKeyEx hHK3, "0", ByVal 0&, KEY_READ, hHK4
RegQueryValue hHK4, "win32", lpPath, Len(lpPath)
i2 = i2 + 1
Cells(R + 1, 1) = IIf(InStr(lpPath, vbNullChar), Left(lpPath, InStr(lpPath, vbNullChar) - 1), lpPath) & Chr(10) _
& IIf(InStr(lpValue, vbNullChar), Left(lpValue, InStr(lpValue, vbNullChar) - 1), lpValue) & Chr(10)
ProgIDFromFile lpPath
End If
Loop
End If
End If
i = i + 1
Loop
RegCloseKey hHK1
RegCloseKey hHK2
RegCloseKey hHK3
RegCloseKey hHK4
End If
Application.ScreenUpdating = True
End Sub
Private Sub ProgIDFromFile(TypeLibFile$)
Dim CLSID As GUID, strProgID$, lpszProgID&
Dim TLIApp As Object
Dim TLBInfo As Object
Dim TypeInf As Object
Set TLIApp = New TLI.TLIApplication
Dim ProgID As String
Dim strCLSID As String
On Error GoTo Exitpoint
Set TLBInfo = TLIApp.TypeLibInfoFromFile(TypeLibFile)
For Each TypeInf In TLBInfo.CoClasses
ProgID = TypeInf.Name
strCLSID = TypeInf.GUID
If CLSIDFromString(StrPtr(strCLSID), CLSID) = 0 Then
R = R + 1: Cells(R, 2) = strCLSID
Cells(R, 4) = CLSIDDefaultValue(strCLSID)(0)
Cells(R, 5) = CLSIDDefaultValue(strCLSID)(1)
If ProgIDFromCLSID(CLSID, lpszProgID) = 0 Then
SysReAllocString VarPtr(strProgID), lpszProgID
Cells(R, 3) = strProgID
End If
End If
Next
Exitpoint:
End Sub
Private Function CLSIDDefaultValue(strCLSID$)
Dim ret As Long
Dim key As Long
Dim length As Long
Dim temp$(0 To 1)
ret = RegOpenKey(HKEY_CLASSES_ROOT, "CLSID", key)
ret = RegOpenKey(key, strCLSID, key)
'先取数据区的长度
ret = RegQueryValueEx(key, "", 0, 1, ByVal 0, length)
'准备数据区
If length > 0 Then
Dim buff() As Byte
ReDim buff(length - 1)
'读取数据
ret = RegQueryValueEx(key, "", 0, 1, buff(0), length)
' Dim val As String
'去掉末尾的空字符,VB不需要这个
ReDim Preserve buff(length - 2)
'转化为VB中的字符串
temp(0) = StrConv(buff, vbUnicode)
End If
ret = RegOpenKey(key, "InprocServer32", key)
ret = RegQueryValueEx(key, "", 0, 1, ByVal 0, length)
If length > 0 Then
ReDim buff(length - 1)
'读取数据
ret = RegQueryValueEx(key, "", 0, 1, buff(0), length)
'去掉末尾的空字符,VB不需要这个
ReDim Preserve buff(length - 2)
'转化为VB中的字符串
temp(1) = StrConv(buff, vbUnicode)
End If
CLSIDDefaultValue = temp
RegCloseKey (key)
End Function

复制代码

引用.7z (17.57 KB, 下载次数: 98)

№▁▃风筝﹋ · 发表于 2017-2-25 10:33

这么好的帖子，非常有用

0031126 · 发表于 2017-2-25 11:41

运行出错了，请问是什么原因呢。

Allen2018 · 发表于 2017-3-16 15:20

0031126 发表于 2017-2-25 11:41
运行出错了，请问是什么原因呢。

遇到相同错误，楼主分享解答下呗

Allen2018 · 发表于 2017-3-16 15:24

yangyangzhifeng 发表于 2016-12-29 18:18
我写这一帖的目的是方便初学者学习的，在论坛大家学习别人的代码时，
大部分老师为了大家方便利用，一般都 ...

楼主真是个好心人啊，新人遇到这类问题每每放弃的节奏。

		自动登录	找回密码
密码			免费注册

[分享] 对象的前期绑定与后期绑定使用方法(CLSID-ProgID对照)

评分

评分