dkkirk2000
Registered User.
- Local time
- Today, 14:43
- Joined
- Jan 27, 2017
- Messages
- 16
Hello everyone,
The company decided to "upgrade" to windows 10/64 bit and now the below code gets stuck at the
line. Can you help me?
thank you!
Option Compare Database
Option Explicit
Private Type WKSTA_USER_INFO_1
wkui1_username As LongPtr 'name of the user currently logged on to the workstation.
wkui1_logon_domain As LongPtr 'the domain name of the user account of the user currently logged on
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 sapiCopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As LongPtr)
Public Function fNTUsername() As String
'*******************************************
'** NT ONLY Function **
'Purpose: Find NT Username or Domain name of current user
'Calls: NetWkstaUserGetInfo, RTLMoveMemory
'Inputs: None
'Returns: NT Username or Domain Name of Current User
'*******************************************
On Error GoTo ErrHandler
Dim lngRet As LongPtr
Dim lngPtr As LongPtr
Dim tNTInfo As WKSTA_USER_INFO_1
lngRet = apiWkStationUser(0&, 1&, lngPtr)
If lngRet = 0 Then
Call sapiCopyMemory(tNTInfo, ByVal lngPtr, LenB(tNTInfo))
If Not lngPtr = 0 Then
With tNTInfo
fNTUsername = fStringFromPtr(.wkui1_username)
End With
End If
End If
ExitHere:
Exit Function
ErrHandler:
fNTUsername = vbNullString
Resume ExitHere
End Function
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 sapiCopyMemory(abytStr(0), ByVal lngPtr, lngLen)
fStringFromPtr = abytStr()
End If
End Function ' End of modified code originally written by Dev Ashish
The company decided to "upgrade" to windows 10/64 bit and now the below code gets stuck at the

thank you!
Option Compare Database
Option Explicit
Private Type WKSTA_USER_INFO_1
wkui1_username As LongPtr 'name of the user currently logged on to the workstation.
wkui1_logon_domain As LongPtr 'the domain name of the user account of the user currently logged on
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 sapiCopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As LongPtr)
Public Function fNTUsername() As String
'*******************************************
'** NT ONLY Function **
'Purpose: Find NT Username or Domain name of current user
'Calls: NetWkstaUserGetInfo, RTLMoveMemory
'Inputs: None
'Returns: NT Username or Domain Name of Current User
'*******************************************
On Error GoTo ErrHandler
Dim lngRet As LongPtr
Dim lngPtr As LongPtr
Dim tNTInfo As WKSTA_USER_INFO_1
lngRet = apiWkStationUser(0&, 1&, lngPtr)
If lngRet = 0 Then
Call sapiCopyMemory(tNTInfo, ByVal lngPtr, LenB(tNTInfo))
If Not lngPtr = 0 Then
With tNTInfo
fNTUsername = fStringFromPtr(.wkui1_username)
End With
End If
End If
ExitHere:
Exit Function
ErrHandler:
fNTUsername = vbNullString
Resume ExitHere
End Function
Private Function fStringFromPtr(lngPtr As LongPtr) As String
Dim lngLen As LongPtr
Dim abytStr() As Byte
lngLen = apiStrLenFromPtr(lngPtr) * 2
If lngLen > 0 Then


Call sapiCopyMemory(abytStr(0), ByVal lngPtr, lngLen)
fStringFromPtr = abytStr()
End If
End Function ' End of modified code originally written by Dev Ashish