My employer has recently upgraded from Office 2010 to 2016, and I need to update some VBA code to accommodate 64 bit MS Access. The code checks the user's Active Directory memberships to confirm what modules they are allowed access to. I've made some progress, but am stumbling on the section below:
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
Specifically, the problem appears to be the "ReDim abytStr(0 To lngLen - 1)" instruction. This has been resulting in a Type Mismatch error. I've made several attempts to change the abytStr variable type, but the results are always the same.
This code has been working for several years without a problem on the 32 bit version. Can anyone see a reason why this wouldn't work under 64 bit?
Thanks in advance for any suggestions.
UPDATE:
As suggested, here's the full code set I'm working with.
First off, here's the code that works under 32 bit 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
This code does not compile under 64 bit Access 2016, and the problem appears to stem from the Variant types I've declared. Here's what I've currently changed the code to:
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
As indicated, the getLoginName function is returning the expected result. The Type Mismatch error currently appears in the fStringFromPtr function, and seems to be triggered by the ReDim statement.
