2000的系统,计算机管理中的用户管理显示红×,并提示:无法访问计算机xxx.错误是:库没有注册.
---------------------------------------------------------------
regsvr32 只能注册dll,ocx等有DllRegiesterServer输入点的类库
通过昨晚的思考、分析和对比,总算发现问题原因.
运行用户管理(usrmgr.msc)时会加载activeds.dll
文件共享权限管理时会加载activeds.tlb
尝试将activeds.tlb删除就会出现同样问题，所以估计就是activeds.tlb没注册。
早上到网上找了段代码，然后在问题机上把activeds.tlb注册后，问题得到解决。
Option Explicit
'
' Brad Martinez, http://www.mvps.org
'
Declare Function LoadTypeLib Lib "oleaut32" _
(ByVal szFileName As String, _
lplptlib As Any) As Long ' lplptlib As Long
Declare Function RegisterTypeLib Lib "oleaut32" _
(ByVal ptlib As Any, _
ByVal szFullPath As String, _
ByVal szHelpDir As String) As Long
Declare Function UnRegisterTypeLib Lib "oleaut32" _
(GUID As GUID, _
ByVal wVerMajor As Long, _
ByVal wVerMinor As Long, _
ByVal lcid As Long, _
ByVal SYSKIND As SYSKIND) As Long
Public Const S_OK = 0 ' indicates successful HRESULT
' "Error accessing the OLE registry." Typically means that
' the GUID passed to UnRegisterTypeLib wasn't found in
' the registry (i.e the typelib was already unregistered)
Public Const TYPE_E_REGISTRYACCESS = &H8002801C
Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Declare Function LocalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
' LocalAlloc uFlags values
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _
(ByVal dwFlags As FM_dwFlags, _
lpSource As Any, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, _
ByVal nSize As Long, _
Arguments As Any) As Long
Public Enum FM_dwFlags
' FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
' FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
' FORMAT_MESSAGE_FROM_HMODULE = &H800
' FORMAT_MESSAGE_FROM_STRING = &H400
FORMAT_MESSAGE_FROM_SYSTEM = &H1000
FORMAT_MESSAGE_IGNORE_INSERTS = &H200
FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
End Enum
' FormatMessage dwLanguageId value
Public Const LANG_USER_DEFAULT = &H400&
'
' Registers the specified typelib.
' sTypelibPath - typelib's path, either explicit, or relative if the system can find it
' sHelpPath - typelib's help file path, should be explicit
' fSilent - specifies that a messagebox will not be shown indicating the result of the function
' Returns True on success, False otherwise.
Public Function RegTypelib(sTypelibPath As String, _
Optional sHelpPath As String = vbNullChar, _
Optional fSilent As Boolean = False) As Boolean
Dim hr As Long
' Dim lptlb As Long
Dim itlb As ITypeLib
hr = LoadTypeLib(StrConv(sTypelibPath, vbUnicode), itlb)
If (hr = S_OK) Then
hr = RegisterTypeLib(itlb, StrConv(sTypelibPath, vbUnicode), _
StrConv(sHelpPath, vbUnicode))
End If
If (fSilent = False) Then
If (hr = S_OK) Then
MsgBox "Successfully registered " & sTypelibPath
RegTypelib = True
Else
MsgBox "Failed to register " & sTypelibPath & _
vbCrLf & vbCrLf & GetAPIErrStr(hr), vbExclamation
End If
End If
End Function
' Unregisters the specified typelib.
' sTypelibPath - typelib's path, either explicit, or relative if the system can find it
' fSilent - specifies that a messagebox will not be shown indicating the result of the function
' Returns True on success, False otherwise.
Public Function UnregTypelib(sTypelibPath As String, _
Optional fSilent As Boolean = False) As Boolean
Dim hr As Long
Dim itlb As ITypeLib
Dim lptlba As Long
Dim tlba As TLIBATTR
hr = LoadTypeLib(StrConv(sTypelibPath, vbUnicode), itlb)
If (hr = S_OK) Then
' can't do this since VB DWORD aligns the struct !!! (it has 3 WORD members)
' If itlb.GetLibAttr(tlba) = S_OK Then
' allocate memory for the TLIBATTR struct
lptlba = LocalAlloc(LPTR, Len(tlba))
hr = Err.LastDllError
If lptlba Then
' Fill the struct's pointer
hr = itlb.GetLibAttr(lptlba)
If (hr = S_OK) Then
' Fill the struct from its pointer
' VB doesn't DWORD align the struct on this call... (?)
MoveMemory tlba, ByVal lptlba, Len(tlba)
' Unregister the typelib using the info from the TLIBATTR struct
With tlba
hr = UnRegisterTypeLib(.GUID, .wMajorVerNum, .wMinorVerNum, .lcid, .SYSKIND)
End With
' Don't do this since we're de-allocating
' below what we allocated above
' Call itlb.ReleaseTLibAttr(tlba)
' Set itlb = Nothing
End If
Call LocalFree(lptlba)
End If ' lptlba
End If ' LoadTypeLib
If (fSilent = False) Then
If (hr = S_OK) Then
MsgBox "Successfully unregistered " & sTypelibPath
UnregTypelib = True
ElseIf (hr = TYPE_E_REGISTRYACCESS) Then
MsgBox "Type library is not registered: " & sTypelibPath
Else
MsgBox "Failed to unregister " & sTypelibPath & _
vbCrLf & vbCrLf & GetAPIErrStr(hr), vbExclamation
End If
End If
UnregTypelib = (hr = S_OK)
End Function
' Returns the system-defined description of an API error code
Public Function GetAPIErrStr(dwErrCode As Long) As String
Dim sErrDesc As String * 256 ' max string resource len
If FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or _
FORMAT_MESSAGE_IGNORE_INSERTS Or _
FORMAT_MESSAGE_MAX_WIDTH_MASK, _
ByVal 0&, dwErrCode, LANG_USER_DEFAULT, _
ByVal sErrDesc, 256, 0) Then
GetAPIErrStr = Left$(sErrDesc, InStr(sErrDesc, vbNullChar) - 1)
End If
End Function