Launching an elevated process using a windows service - vb.net

I'm trying to run a software update from a Windows Service. My service runs under LocalSystem.
I think all works fine up to the CreateProcessAsUser line which fails with API error 3 (ERR_FILE_NOT_FOUND).
I'm unsure how to go on debugging my code. I used ProcMon to see if it really can't find the path, but it does, so I think I might have missed something else.
Does anybody see a possible mistake?
I am using WTSEnumerateSessions to get the active session. For some reason, its MachineName member is empty, but the SessionID is not 0, so I guess that is still ok.
Public Function StartAppInSessionAsAdmin(ByVal uSessionID As String, ByVal uWinstationNameStrPtr As Long, ByVal uAppName As String) As Integer
'get SessionID token
Dim hToken&
Dim bRet As Boolean
bRet = WTSQueryUserToken(uSessionID, hToken)
WriteLog "wtsqueryusertoken: " & bRet & ", htoken: " & hToken
'we need to get the TokenLinked Token
Dim TLT As TOKEN_LINKED_TOKEN
Dim TLTSize&
TLTSize = Len(TLT.LinkedToken)
Dim hLinkedToken&
Dim iRetSize&
bRet = GetTokenInformation(hToken, TOKEN_INFORMATION_CLASS.TokenLinkedToken, hLinkedToken, TLTSize, iRetSize)
WriteLog "gettokeninformation: " & bRet & " linkedtoken: " & TOKEN_INFORMATION_CLASS.TokenLinkedToken & " linked2: " & hLinkedToken
'Use CreateEnvironment Block with the original token to create an environment for the new program with the USER Environment
Dim lpEB&
bRet = CreateEnvironmentBlock(lpEB, hToken, False)
WriteLog "Createenvblock: " & bRet
If bRet Then
Dim pi As PROCESS_INFORMATION
Dim si As STARTUPINFO
si.lpDesktop = uWinstationNameStrPtr ' '”Winsta0\default”
si.cb = Len(si)
Dim lRet&
lRet = CreateProcessAsUser( _
hLinkedToken, _
"", _
uAppName, _
0&, _
0&, _
0&, _
NORMAL_PRIORITY_CLASS, _
0&, _
0&, _
si, _
pi)
'Give user a feedback
If lRet <> 0 Then
WriteLog ":-) createprocessasuser succeeded!"
Else
WriteLog ":-( failed createprocessasuser! error: " & Err.LastDllError
End If
End If
WriteLog "pstartappinsessions}"
End Function

ERROR_FILE_NOT_FOUND strongly suggests that the executable cannot be found. In other words, the problem is with lpApplicationName or lpCommandLine. From the documentation:
The lpApplicationName parameter can be NULL. In that case, the module name must be the first white space–delimited token in the lpCommandLine string. If you are using a long file name that contains a space, use quoted strings to indicate where the file name ends and the arguments begin; otherwise, the file name is ambiguous. [...] If the file name does not contain an extension, .exe is appended.
If lpApplicationName is null, then lpCommandLine must start with the program you want to run. If the path to the program contains a space, then the path must be enclosed in quotes.
If lpApplicationName is null, then you can test whether lpCommandLine is valid by pasting its value into a command prompt.

Related

VBA and GetRawInputDeviceList

I am working in Access 2013 and try to get GetRawInputDeviceList, GetRawInputDeviceInfo, RegisterRawInputDevices and GetRawInputData equivalents for VBA with no success. I have also searched in vain for a procedure, function or module to get a list of connected HID devices to a computer to pick out a barcode scanner. This is the beginning of the third week so I am on my knees begging for assistance. Do any of you all have a module you're willing to share, a link to a website where this is dealt with? Any help is greatly appreciated.
Using the GetRawInputDeviceList API from VBA would be pretty tricky because of the pRawInputDeviceList parameter. Unless you're willing to jump through a ton of hoops to manage your own memory and manually handle the resulting array of RAWINPUTDEVICELIST in raw memory, you'll be better off coming at this from another direction.
Most barcode scanners I've dealt with present themselves to Windows as a keyboard. One possible solution would be to use a WMI query to enumerate attached Win32_Keyboard devices:
Private Sub ShowKeyboardInfo()
Dim WmiServer As Object
Dim ResultSet As Object
Dim Keyboard As Object
Dim Query As String
Query = "SELECT * From Win32_Keyboard"
Set WmiServer = GetObject("winmgmts:root/CIMV2")
Set ResultSet = WmiServer.ExecQuery(Query)
For Each Keyboard In ResultSet
Debug.Print Keyboard.Name & vbTab & _
Keyboard.Description & vbTab & _
Keyboard.DeviceID & vbTab & _
Keyboard.Status
Next Keyboard
End Sub
Note: If it doesn't turn up there, you can enumerate all of the USB devices by querying CIM_USBDevice: Query = "SELECT * From Win32_Keyboard"
EDIT: Per the comments, the above code won't return the handle needed to register to receive raw input events. This should get you started though - the RegisterRawInputDevices and GetRawInputData aspects are beyond the scope of what will easily go in an answer. Take a hack at it, and if you run into any problems post your code in another question.
Declarations:
Private Type RawInputDeviceList
hDevice As Long
dwType As Long
End Type
Private Type RidKeyboardInfo
cbSize As Long
dwType As Long
dwKeyboardMode As Long
dwNumberOfFunctionKeys As Long
dwNumberOfIndicators As Long
dwNumberOfKeysTotal As Long
End Type
Private Enum DeviceType
TypeMouse = 0
TypeKeyboard = 1
TypeHID = 2
End Enum
Private Enum DeviceCommand
DeviceName = &H20000007
DeviceInfo = &H2000000B
PreParseData = &H20000005
End Enum
Private Declare Function GetRawInputDeviceList Lib "user32" ( _
ByVal pRawInputDeviceList As Long, _
ByRef puiNumDevices As Long, _
ByVal cbSize As Long) As Long
Private Declare Function GetRawInputDeviceInfo Lib "user32" Alias "GetRawInputDeviceInfoW" ( _
ByVal hDevice As Long, _
ByVal uiCommand As Long, _
ByVal pData As Long, _
ByRef pcbSize As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Sample of retrieving device names with GetRawInputDeviceInfo:
Private Sub SampleCode()
Dim devices() As RawInputDeviceList
devices = GetRawInputDevices
Dim i As Long
For i = 0 To UBound(devices)
'Inspect the type - only looking for a keyboard.
If devices(i).dwType = TypeKeyboard Then
Dim buffer As String
Dim size As Long
'First call with a null pointer returns the string length in size.
If GetRawInputDeviceInfo(devices(i).hDevice, DeviceName, 0&, size) = -1 Then
Debug.Print "GetRawInputDeviceInfo error " & GetLastError()
Else
'Size the string buffer.
buffer = String(size, Chr$(0))
'The second call copies the name into the passed buffer.
If GetRawInputDeviceInfo(devices(i).hDevice, DeviceName, StrPtr(buffer), size) = -1 Then
Debug.Print "GetRawInputDeviceInfo error " & GetLastError()
Else
Debug.Print buffer
End If
End If
End If
Next i
End Sub
Private Function GetRawInputDevices() As RawInputDeviceList()
Dim devs As Long
Dim output() As RawInputDeviceList
'First call with a null pointer returns the number of devices in devs
If GetRawInputDeviceList(0&, devs, LenB(output(0))) = -1 Then
Debug.Print "GetRawInputDeviceList error " & GetLastError()
Else
'Size the output array.
ReDim output(devs - 1)
'Second call actually fills the array.
If GetRawInputDeviceList(VarPtr(output(0)), devs, LenB(output(0))) = -1 Then
Debug.Print "GetRawInputDeviceList error " & GetLastError()
Else
GetRawInputDevices = output
End If
End If
End Function
Sorry about the side scrolling.

Writing a macro that passes commands to Windows Shell

I have an Excel file containing metadata information for 20k+ images. I'm trying to write a macro that executes commands with exiftool.exe (a tool used to batch edit metadata) on Windows Shell with variables relative to each row.
For instance, I want to iterate through exiftool commands that take information from column B ("Author") such as:
C:\exiftool\exiftool.exe -Author="CELL B1 CONTENT"
C:\exiftool\exiftool.exe -Author="CELL B2 CONTENT"
...repeats ad infinitum.
This is what I've tried so far:
Sub EnterMetadata()
For Each Cell In Range("C1:C20000")
Shell("c:\Exiftool\exiftool.exe -o I:/Photos/ & ActiveCell.Offset(0, -2).Value) & " -Author=" & ActiveCell.Offset(0, -1).Value)
Next
End Sub
Notice that column A contains the path for the original files. And column B contains author names. I'm trying to retrieve information from columns A and B to use in the macro.
Untested:
Sub EnterMetadata()
Const CMD As String = "c:\Exiftool\exiftool.exe -o ""I:/Photos/{fn}"" -Author=""{auth}"""
Dim Cell as Range, s as String
For Each Cell In Range("C1:C20000")
s = Replace(CMD, "{fn}", Cell.Offset(0, -2).Value)
s = Replace(s, "{auth}", Cell.Offset(0, -1).Value)
Debug.Print s
Shell s
Next
End Sub
If any of your command line parameters might contain spaces then you should quote them (quotes are escaped in VBA strings by doubling them up)
What about using ShellExecute?
This is what you need to declare in your macro so you can use it:
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
You can pass parameters to it as String (lpParameters), get a return value tohelp understand what happened if something went wrong and is generally more versatile than using Shell.
You can do something similar to this (this is not tested, as I don't have exiftool.):
ShellExecute 0, vbNullString, "C:\exiftool\exiftool.exe", "-Author=""CELL B1 CONTENT""", vbNullString, 10 ' 10=SW_SHOWDEFAULT
I'll let you populate the author according to your requirements.
For full information about ShellExecute, click here to have a look on MSDN.

VBA: Opening a text file from URL to read

I have a text file on my website that contains only the string "1.15" (for the version of the application I am writing). Upon initialization of the user form, I would like to read that file from its URL and have the string "1.15" returned so that I can check it against the application's version (stored as a const string).
Here is the format I'd like to have...
Const version As String = "1.14"
Const currentVersionURL As String = "http://mywebsite.com/currentversion.txt"
Sub UserForm_Initialize()
If version <> GetCurrentVersionNumber() Then
MsgBox "Please update the application."
End If
End Sub
Function GetCurrentVersionNumber() As String
' What do I put here? :(
End Function
I am aware of the Workbooks.OpenText method, but I don't want to write the string into a workbook. I have tried using the ADODB.LoadFromFile and WinHttp.WinHttpRequest.Open methods, but both are unable to read the file.
Any suggestions for what to fill GetCurrentVersionNumber() with would be greatly appreciated. :)
While it doesn't directly answer your question, a simpler approach would be to make it an XML file instead of a text file. There are more built-in tools to easily open an XML file from a URL. The secondary advantage is that it also makes it more flexible, so you can more easily add new data elements to the XML file later on.
For instance, if you made a http://mywebsite.com/currentversion.xml file that looked like this:
<?xml version="1.0" encoding="utf-8" ?>
<AppData>
<Version>1.14</Version>
</AppData>
Then, in VB.NET you could easily read it like this:
Function GetCurrentVersionNumber() As String
Dim doc As New XmlDocument()
doc.Load("http://mywebsite.com/currentversion.xml")
Return doc.SelectSingleNode("/AppData/Version").InnerText
End Function
Or, in VBA, you could read it like this:
Function GetCurrentVersionNumber() As String
Dim doc As MSXML2.DOMDocument?? ' Where ?? is the version number, such as 30 or 60
Set doc = New MSXML2.DOMDocument??
doc.async = False
doc.Load("http://mywebsite.com/currentversion.xml")
GetCurrentVersionNumber = doc.SelectSingleNode("/AppData/Version").Text
End Function
You will need to add a reference to the Microsoft XML, v?.? library, though.
Try this (UNTESTED)
Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Long = 260
Const currentVersionURL As String = "http://mywebsite.com/currentversion.txt"
Const version As String = "1.14"
Dim Ret As Long
Sub UserForm_Initialize()
If version <> GetCurrentVersionNumber() Then
MsgBox "Please update the application."
End If
End Sub
Function GetCurrentVersionNumber() As String
Dim strPath As String
'~~> Destination for the file
strPath = TempPath & "currentversion.txt"
'~~> Download the file
Ret = URLDownloadToFile(0, currentVersionURL, strPath, 0, 0)
'~~> If downloaded
If Ret = 0 Then
Dim MyData As String, strData() As String
Open "C:\MyFile.Txt" For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
GetCurrentVersionNumber = MyData
Else
MsgBox "Unable to download the file"
GetCurrentVersionNumber = ""
End If
End Function
'~~> Get Users Temp Path
Function TempPath() As String
TempPath = String$(MAX_PATH, Chr$(0))
GetTempPath MAX_PATH, TempPath
TempPath = Replace(TempPath, Chr$(0), "")
End Function

VBA Retrieve the name of the user associated with logged username

I want to get the full name of the user (logged in already) in VBA. This code I found online would do getting the username:
UserName = Environ("USERNAME")
but I want the user's real name. I found some hint about NetUserGetInfo but not sure what to think or do. Any hints will be appreciated
Regards,
Even if this thread is rather old, other users might be still googling around (like me).
I found an excellent short solution that worked for me out-of-the-box (thanks to Mr.Excel.com).
I changed it because I needed it to return a string with the user's full name.
The original post is here.
EDIT:
Well, I fixed a mistake, "End Sub" instead of "End Function" and added a variable declaration statement, just in case. I tested it in Excel 2010 and 2013 versions. Worked fine on my home pc too (no domain, just in a workgroup).
' This function returns the full name of the currently logged-in user
Function GetUserFullName() as String
Dim WSHnet, UserName, UserDomain, objUser
Set WSHnet = CreateObject("WScript.Network")
UserName = WSHnet.UserName
UserDomain = WSHnet.UserDomain
Set objUser = GetObject("WinNT://" & UserDomain & "/" & UserName & ",user")
GetUserFullName = objUser.FullName
End Function
I found the API answer complex as well in addition to needing recoding from a form to module
The function below comes courtesy of Rob Sampson from this Experts-Exchange post. It is a flexible function, see code comments for details. Please note it was a vbscript so the variables are not dimensioned
Sub Test()
strUser = InputBox("Please enter a username:")
struserdn = Get_LDAP_User_Properties("user", "samAccountName", strUser, "displayName")
If Len(struserdn) <> 0 Then
MsgBox struserdn
Else
MsgBox "No record of " & strUser
End If
End Sub
Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
' This is a custom function that connects to the Active Directory, and returns the specific
' Active Directory attribute value, of a specific Object.
' strObjectType: usually "User" or "Computer"
' strSearchField: the field by which to seach the AD by. This acts like an SQL Query's WHERE clause.
' It filters the results by the value of strObjectToGet
' strObjectToGet: the value by which the results are filtered by, according the strSearchField.
' For example, if you are searching based on the user account name, strSearchField
' would be "samAccountName", and strObjectToGet would be that speicific account name,
' such as "jsmith". This equates to "WHERE 'samAccountName' = 'jsmith'"
' strCommaDelimProps: the field from the object to actually return. For example, if you wanted
' the home folder path, as defined by the AD, for a specific user, this would be
' "homeDirectory". If you want to return the ADsPath so that you can bind to that
' user and get your own parameters from them, then use "ADsPath" as a return string,
' then bind to the user: Set objUser = GetObject("LDAP://" & strReturnADsPath)
' Now we're checking if the user account passed may have a domain already specified,
' in which case we connect to that domain in AD, instead of the default one.
If InStr(strObjectToGet, "\") > 0 Then
arrGroupBits = Split(strObjectToGet, "\")
strDC = arrGroupBits(0)
strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
strObjectToGet = arrGroupBits(1)
Else
' Otherwise we just connect to the default domain
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
End If
strBase = "<LDAP://" & strDNSDomain & ">"
' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Command")
Set ADOConnection = CreateObject("ADODB.Connection")
ADOConnection.Provider = "ADsDSOObject"
ADOConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = ADOConnection
' Filter on user objects.
'strFilter = "(&(objectCategory=person)(objectClass=user))"
strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"
' Comma delimited list of attribute values to retrieve.
strAttributes = strCommaDelimProps
arrProperties = Split(strCommaDelimProps, ",")
' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
' Define the maximum records to return
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False
' Run the query.
Set adoRecordset = adoCommand.Execute
' Enumerate the resulting recordset.
strReturnVal = ""
Do Until adoRecordset.EOF
' Retrieve values and display.
For intCount = LBound(arrProperties) To UBound(arrProperties)
If strReturnVal = "" Then
strReturnVal = adoRecordset.Fields(intCount).Value
Else
strReturnVal = strReturnVal & vbCrLf & adoRecordset.Fields(intCount).Value
End If
Next
' Move to the next record in the recordset.
adoRecordset.MoveNext
Loop
' Clean up.
adoRecordset.Close
ADOConnection.Close
Get_LDAP_User_Properties = strReturnVal
End Function
This works for me. It might need some adjustments - I get several items returned and only one has .Flags > 0
Function GetUserFullName() As String
Dim objWin32NLP As Object
On Error Resume Next
' Win32_NetworkLoginProfile class https://msdn.microsoft.com/en-us/library/aa394221%28v=vs.85%29.aspx
Set objWin32NLP = GetObject("WinMgmts:").InstancesOf("Win32_NetworkLoginProfile")
If Err.Number <> 0 Then
MsgBox "WMI is not installed", vbExclamation, "Windows Management Instrumentation"
Exit Function
End If
For Each objItem In objWin32NLP
If objItem.Flags > 0 Then GetUserFullName = objItem.FullName
Next
End Function
Try this:
How To Call NetUserGetInfo from Visual Basic
(From Microsoft Knowledge Base, article ID 151774)
The NetUserGetInfo function is a Unicode-only Windows NT API. The last parameter of this function is a pointer to a pointer to a structure whose members contain DWORD data and pointers to Unicode strings. In order to call this function correctly from a Visual Basic application, you need to de-reference the pointer returned by the function and then you need to convert the Visual Basic string to a Unicode string and vice versa. This article illustrates these techniques in an example that calls NetUserGetInfo to retrieve a USER_INFO_3 structure from a Visual Basic application.
The example below uses the Win32 RtlMoveMemory function to de-reference the pointer returned by the NetUserGetInfo call.
Step-by-Step Example
Start Visual Basic. If Visual Basic is already running, from the File menu, choose New Project. Form1 is created by default.
Add a Command button, Command1, to Form1.
Add the following code to the General Declarations section of Form1:
' definitions not specifically declared in the article:
' the servername and username params can also be declared as Longs,
' and passed Unicode memory addresses with the StrPtr function.
Private Declare Function NetUserGetInfo Lib "netapi32" _
(ByVal servername As String, _
ByVal username As String, _
ByVal level As Long, _
bufptr As Long) As Long
Const NERR_Success = 0
Private Declare Sub MoveMemory Lib "kernel32" Alias _
"RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Function lstrlenW Lib "kernel32" (lpString As Any) As Long
' Converts a Unicode string to an ANSI string
' Specify -1 for cchWideChar and 0 for cchMultiByte to return string length.
Private Declare Function WideCharToMultiByte Lib "kernel32" _
(ByVal codepage As Long, _
ByVal dwFlags As Long, _
lpWideCharStr As Any, _
ByVal cchWideChar As Long, _
lpMultiByteStr As Any, _
ByVal cchMultiByte As Long, _
ByVal lpDefaultChar As String, _
ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function NetApiBufferFree Lib "netapi32" _
(ByVal Buffer As Long) As Long
' CodePage
Const CP_ACP = 0 ' ANSI code page
Private Type USER_INFO_3
usri3_name As Long 'LPWSTR in SDK
usri3_password As Long 'LPWSTR in SDK
usri3_password_age As Long 'DWORD in SDK
usri3_priv As Long 'DWORD in SDK
usri3_home_dir As Long 'LPWSTR in SDK
usri3_comment As Long 'LPWSTR in SDK
usri3_flags As Long 'DWORD in SDK
usri3_script_path As Long 'LPWSTR in SDK
usri3_auth_flags As Long 'DWORD in SDK
usri3_full_name As Long 'LPWSTR in SDK
usri3_usr_comment As Long 'LPWSTR in SDK
usri3_parms As Long 'LPWSTR in SDK
usri3_workstations As Long 'LPWSTR in SDK
usri3_last_logon As Long 'DWORD in SDK
usri3_last_logoff As Long 'DWORD in SDK
usri3_acct_expires As Long 'DWORD in SDK
usri3_max_storage As Long 'DWORD in SDK
usri3_units_per_week As Long 'DWORD in SDK
usri3_logon_hours As Long 'PBYTE in SDK
usri3_bad_pw_count As Long 'DWORD in SDK
usri3_num_logons As Long 'DWORD in SDK
usri3_logon_server As Long 'LPWSTR in SDK
usri3_country_code As Long 'DWORD in SDK
usri3_code_page As Long 'DWORD in SDK
usri3_user_id As Long 'DWORD in SDK
usri3_primary_group_id As Long 'DWORD in SDK
usri3_profile As Long 'LPWSTR in SDK
usri3_home_dir_drive As Long 'LPWSTR in SDK
usri3_password_expired As Long 'DWORD in SDK
End Type
Private Sub Command1_Click()
Dim lpBuf As Long
Dim ui3 As USER_INFO_3
' Replace "Administrator" with a valid Windows NT user name.
If (NetUserGetInfo("", StrConv("Administrator", vbUnicode), 3, _
uf) = NERR_Success) Then
Call MoveMemory(ui3, ByVal lpBuf, Len(ui3))
MsgBox GetStrFromPtrW(ui3.usri3_name)
Call NetApiBufferFree(ByVal lpBuf)
End If
End Sub
' Returns an ANSI string from a pointer to a Unicode string.
Public Function GetStrFromPtrW(lpszW As Long) As String
Dim sRtn As String
sRtn = String$(lstrlenW(ByVal lpszW) * 2, 0) ' 2 bytes/char
' WideCharToMultiByte also returns Unicode string length
' sRtn = String$(WideCharToMultiByte(CP_ACP, 0, ByVal lpszW, -1, 0, 0, 0, 0), 0)
Call WideCharToMultiByte(CP_ACP, 0, ByVal lpszW, -1, ByVal sRtn, Len(sRtn), 0, 0)
GetStrFromPtrW = GetStrFromBufferA(sRtn)
End Function
' Returns the string before first null char encountered (if any) from an ANSI string.
Public Function GetStrFromBufferA(sz As String) As String
If InStr(sz, vbNullChar) Then
GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
Else
' If sz had no null char, the Left$ function
' above would return a zero length string ("").
GetStrFromBufferA = sz
End If
End Function
I would recommend re-factoring this into a module rather than embedding it in the form itself. I've used this successfully in Access in the past.
I've tried so many things, but I suppose my organization does not allow me to query Active Directory (or I got the structure wrong). I could only get my account name (not full name) or the error "No mapping between account names and security IDs was done"
But after 2 weeks searching, I finally have a working solution that I wanted to share. My final hint can be found here: https://www.mrexcel.com/board/threads/application-username-equivalent-in-ms-access.1143798/page-2#post-5545265
The value does appear in the registry i.e.
"HKEY_CURRENT_USER\Software\Microsoft\Office\Common\UserInfo\UserName"
Once I realized that, it was easy to access with VBA:
UserName = CreateObject("wscript.shell").RegRead("HKEY_CURRENT_USER\Software\Microsoft\Office\Common\UserInfo\UserName")
I assume (did not test though) that this is what Application.Username from Excel uses as well. Might not be perfect, but I finally have a solution that works.

How to register a type library in VBA

I am trying to register a type library programatically from VBA code, using two variants of a technique found using Google (Subs RegisterTypeLibrary and RegisterTypeLibrary2 below).
The code below crashes with an access violation on the call to LoadTypeLib / LoadTypeLibEx. What am I doing wrong? In case it's relevant, the type library is a TLB file generated from a .NET assembly using tlbexp.
Private Enum RegKind
RegKind_Default = 0
RegKind_Register = 1
RegKind_None = 2
End Enum
Private Declare Function LoadTypeLibEx Lib "oleaut32.dll" ( _
pFileName As Byte, ByVal RegKind As RegKind, pptlib As Object) As Long
Private Declare Function LoadTypeLib Lib "oleaut32.dll" ( _
pFileName As Byte, pptlib As Object) As Long
Private Declare Function RegisterTypeLib Lib "oleaut32.dll" ( _
ByVal ptlib As Object, szFullPath As Byte, _
szHelpFile As Byte) As Long
Private Sub RegisterTypeLibrary(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As Object
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLib(abNullTerminatedFileName(0), objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLib", "Error registering type library " & FileName
End If
lHResult = RegisterTypeLib(objTypeLib, abNullTerminatedFileName(0), 0)
If lHResult <> 0 Then
Err.Raise lHResult, "RegisterTypeLib", "Error registering type library " & FileName
End If
Exit Sub
End Sub
Private Sub RegisterTypeLibrary2(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As Object
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLibEx(abNullTerminatedFileName(0), ByVal RegKind_Register, objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLibEx", "Error registering type library " & FileName
End If
End Sub
EDIT
I suspect it is something specific about my type library. I've found a solution which I've posted as an answer below.
I've found a solution, using the code below. Basically, the third parameter to LoadTypeLibEx (ITypeLib** in C/C++) is declared as stdole.IUnknown instead of as Object.
To do so, I needed to add a reference to stdole32.tlb to the VBA project.
I suspect there is something about my type library that means it can't be declared as a VB (late-bound) Object.
I could also have declared the third parameter as Long, but I'm not sure that wouldn't lead to problems with reference counting.
Private Enum RegKind
RegKind_Default = 0
RegKind_Register = 1
RegKind_None = 2
End Enum
Private Declare Function LoadTypeLibEx Lib "oleaut32.dll" ( _
pFileName As Byte, ByVal RegKind As RegKind, pptlib As stdole.IUnknown) As Long
Public Sub RegisterTypeLibrary(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As stdole.IUnknown
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLibEx(abNullTerminatedFileName(0), ByVal RegKind_Register, objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLibEx", "Error registering type library " & FileName
End If
End Sub
I suspect your type library (TLB) has errors because the code you provided works when I tested against a third-party TLB.
I am assuming you are going to use your .NET Assembly from VBA. Therefore, I suggest you make sure you can reference your TLB from VBA without errors.
Note, that all objects exposed by your .NET library must have public constructors that accept no arguments. This may be causing the problem.