Мой работодатель недавно обновил Office 2010 до 2016 года, и мне нужно обновить некоторый код VBA для поддержки 64-битного MS Access. Код проверяет членство пользователя в Active Directory, чтобы подтвердить, к каким модулям ему разрешен доступ. Я добился определенного прогресса, но спотыкаюсь о следующем разделе:
Private Function fStringFromPtr(lngPtr As LongPtr) As String
Dim lngLen As LongPtr
Dim abytStr() As Byte
lngLen = apiStrLenFromPtr(lngPtr) * 2
If lngLen > 0 Then
ReDim abytStr(0 To lngLen - 1)
Call apiCopyMemory(abytStr(0), ByVal lngPtr, lngLen)
fStringFromPtr = abytStr()
End If
End Function
В частности, проблема, похоже, заключается в инструкции "ReDim abytStr (0 To lngLen - 1)". Это привело к ошибке несоответствия типов. Я сделал несколько попыток изменить тип переменной abytStr, но результаты всегда одинаковы.
Этот код работал в течение нескольких лет без проблем на 32-битной версии. Может кто-нибудь увидеть причину, почему это не будет работать под 64 бит?
Заранее спасибо за любые предложения.
ОБНОВЛЕНИЕ:
Как и предлагалось , вот полный набор кодов, с которым я работаю.
Прежде всего, вот код, который работает под 32-битным Access 2010:
Option Compare Database
Option Explicit
Dim m_strGroups() As String 'Cache with all security groups this user is a member of.
Private Type WKSTA_USER_INFO_1
wkui1_username As Long 'current user name
wkui1_logon_domain As Long 'current user domain
wkui1_oth_domains As Long 'list of other LAN Manager domains browsed by the workstation
wkui1_logon_server As Long 'name of the computer that authenticated the server
End Type
Private Declare Function apiWkStationUser Lib "Netapi32" Alias "NetWkstaUserGetInfo" (ByVal reserved As Long, ByVal Level As Long, bufptr As Long) As Long
Private Declare Function apiStrLenFromPtr Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Sub apiCopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Function getLoginName() As String
Dim ret As Long
Dim lpBuff As String * 255
ret = GetUserName(lpBuff, 255)
If ret > 0 Then
getLoginName = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1)
Else
getLoginName = vbNullString
End If
End Function
Public Function getUserDomain() As String
On Error GoTo Error_Handler
Dim lngRet As Long
Dim lngPtr As Long
Dim tNTInfo As WKSTA_USER_INFO_1
Dim strNTDomain As String
lngRet = apiWkStationUser(0&, 1&, lngPtr)
If lngRet = 0 Then
Call apiCopyMemory(tNTInfo, ByVal lngPtr, LenB(tNTInfo))
If Not lngPtr = 0 Then
strNTDomain = fStringFromPtr(tNTInfo.wkui1_logon_domain)
End If
End If
Exit_Handler:
getUserDomain = strNTDomain
Exit Function
Error_Handler:
strNTDomain = vbNullString
Resume Exit_Handler
End Function
Public Function GetSecurityGroups() As String()
On Error GoTo Error_Handler
CacheSecurityGroups
Exit_Handler:
GetSecurityGroups = m_strGroups
Exit Function
Error_Handler:
MsgBox Err.Description, vbCritical
Resume Exit_Handler
End Function
' Fills array with all Active Directory security groups the user is a member of.
' Call this function from your application startup code (in this sample: InitApplication.
'RETURNS:
' True for success; False otherwise. If False we may not be on a domain.
Public Function CacheSecurityGroups() As Boolean
On Error GoTo Error_Handler
Dim objRoot As ActiveDs.IADs 'Requires reference to "Active DS Type Library" (activeds.tlb)
Dim objGroup As ActiveDs.IADsGroup
Dim objUser As ActiveDs.IADsUser
Dim blnResult As Boolean
Dim i As Integer
Dim strDNC As String 'DNC = Default Naming Context
Dim strDomainName As String
'The RootDse is a special LDAP object that exists on all LDAP v3 servers. With it you can write scripts that are independent of the domain or enterprise on which they are run.
Set objRoot = GetObject("LDAP://RootDSE")
strDNC = objRoot.Get("DefaultNamingContext")
strDomainName = getUserDomain()
Set objUser = GetObject("WinNT://" & strDomainName & "/" & getLoginName() & ",user")
'Count number of groups
i = 0
For Each objGroup In objUser.Groups
i = i + 1
Next
Debug.Assert i > 0 'If user is in an Active Directory domain, (s)he should be a member of at least one group.
ReDim m_strGroups(i - 1) 'Resize array so it can hold all groups.
'Fill the array with group names
i = 0
For Each objGroup In objUser.Groups
m_strGroups(i) = objGroup.Name
Debug.Print objGroup.Name
i = i + 1
Next
blnResult = True
Exit_Handler:
CacheSecurityGroups = blnResult
Exit Function
Error_Handler:
blnResult = False
If Err.Number = -2147023541 Then '-2147023541 = Automation error. The specified domain either does not exist or could not be contacted.
Err.Description = Err.Description & vbCrLf & "Found domain name: '" & strDomainName & "'. An empty domain name is indicative of the machine not being on a domain."
End If
MsgBox Err.Description, vbCritical
Resume Exit_Handler
End Function
'PURPOSE:
' Helper function to perform some fancy byte copying.
Private Function fStringFromPtr(lngPtr As Long) As String
Dim lngLen As Long
Dim abytStr() As Byte
lngLen = apiStrLenFromPtr(lngPtr) * 2
If lngLen > 0 Then
ReDim abytStr(0 To lngLen - 1)
Call apiCopyMemory(abytStr(0), ByVal lngPtr, lngLen)
fStringFromPtr = abytStr()
End If
End Function
Этот код не компилируется под 64-битным Access 2016, и проблема, кажется, проистекает из типов Вариантов, которые я объявил. Вот что я в настоящее время изменил код:
Option Compare Database
Option Explicit
Dim m_strGroups() As String 'Cache with all security groups this user is a member of.
Private Type WKSTA_USER_INFO_1
wkui1_username As LongPtr 'current user name
wkui1_logon_domain As LongPtr 'current user domain
wkui1_oth_domains As LongPtr 'list of other LAN Manager domains browsed by the workstation
wkui1_logon_server As LongPtr 'name of the computer that authenticated the server
End Type
Private Declare PtrSafe Function apiWkStationUser Lib "Netapi32" Alias "NetWkstaUserGetInfo" (ByVal reserved As LongPtr, ByVal Level As LongPtr, bufptr As LongPtr) As LongPtr
Private Declare PtrSafe Function apiStrLenFromPtr Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As LongPtr
Private Declare PtrSafe Sub apiCopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As LongPtr)
Private Declare PtrSafe Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As LongPtr) As LongPtr
Public Function getLoginName() As String
Dim ret As LongPtr
Dim lpBuff As String * 255
ret = GetUserName(lpBuff, 255)
If ret > 0 Then
getLoginName = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1)
Else
getLoginName = vbNullString
End If
End Function
Public Function getUserDomain() As String
On Error GoTo Error_Handler
Dim lngRet As LongPtr
Dim lngPtr As LongPtr
Dim tNTInfo As WKSTA_USER_INFO_1
Dim strNTDomain As String
lngRet = apiWkStationUser(0&, 1&, lngPtr)
If lngRet = 0 Then
Call apiCopyMemory(tNTInfo, ByVal lngPtr, LenB(tNTInfo))
If Not lngPtr = 0 Then
strNTDomain = fStringFromPtr(tNTInfo.wkui1_logon_domain)
End If
End If
Exit_Handler:
getUserDomain = strNTDomain
Exit Function
Error_Handler:
strNTDomain = vbNullString
Resume Exit_Handler
End Function
Public Function GetSecurityGroups() As String()
On Error GoTo Error_Handler
CacheSecurityGroups
Exit_Handler:
GetSecurityGroups = m_strGroups
Exit Function
Error_Handler:
MsgBox Err.Description, vbCritical
Resume Exit_Handler
End Function
' Fills array with all Active Directory security groups the user is a member of.
' Call this function from your application startup code (in this sample: InitApplication.
'RETURNS:
' True for success; False otherwise. If False we may not be on a domain.
Public Function CacheSecurityGroups() As Boolean
On Error GoTo Error_Handler
Dim objRoot As ActiveDs.IADs 'Requires reference to "Active DS Type Library" (activeds.tlb)
Dim objGroup As ActiveDs.IADsGroup
Dim objUser As ActiveDs.IADsUser
Dim blnResult As Boolean
Dim i As Integer
Dim strDNC As String 'DNC = Default Naming Context
Dim strDomainName As String
'The RootDse is a special LDAP object that exists on all LDAP v3 servers. With it you can write scripts that are independent of the domain or enterprise on which they are run.
Set objRoot = GetObject("LDAP://RootDSE")
strDNC = objRoot.Get("DefaultNamingContext")
strDomainName = getUserDomain()
Set objUser = GetObject("WinNT://" & strDomainName & "/" & getLoginName() & ",user")
'Count number of groups
i = 0
For Each objGroup In objUser.Groups
i = i + 1
Next
Debug.Assert i > 0 'If user is in an Active Directory domain, (s)he should be a member of at least one group.
ReDim m_strGroups(i - 1) 'Resize array so it can hold all groups.
'Fill the array with group names
i = 0
For Each objGroup In objUser.Groups
m_strGroups(i) = objGroup.Name
Debug.Print objGroup.Name
i = i + 1
Next
blnResult = True
Exit_Handler:
CacheSecurityGroups = blnResult
Exit Function
Error_Handler:
blnResult = False
If Err.Number = -2147023541 Then '-2147023541 = Automation error. The specified domain either does not exist or could not be contacted.
Err.Description = Err.Description & vbCrLf & "Found domain name: '" & strDomainName & "'. An empty domain name is indicative of the machine not being on a domain."
End If
MsgBox Err.Description, vbCritical
Resume Exit_Handler
End Function
'PURPOSE:
' Helper function to perform some fancy byte copying.
Private Function fStringFromPtr(lngPtr As LongPtr) As String
Dim lngLen As Long
Dim abytStr() As Byte
lngLen = apiStrLenFromPtr(lngPtr) * 2
If lngLen > 0 Then
ReDim abytStr(0 To lngLen - 1)
Call apiCopyMemory(abytStr(0), ByVal lngPtr, lngLen)
fStringFromPtr = abytStr()
End If
End Function
Как указано, функция getLoginName возвращает ожидаемый результат. Ошибка несоответствия типов в настоящее время появляется в функции fStringFromPtr и, по-видимому, вызывается оператором ReDim.