I have a an Access App that requires the user to enter their Windows domain user and password to enter. I have used the following VBA code to accomplish this:
Function WindowsLogin(ByVal strUserName As String, ByVal strpassword As String, ByVal strDomain As String) As Boolean
'Authenticates user and password entered with Active Directory.
On Error GoTo IncorrectPassword
Dim oADsObject, oADsNamespace As Object
Dim strADsPath As String
strADsPath = "WinNT://" & strDomain
Set oADsObject = GetObject(strADsPath)
Set oADsNamespace = GetObject("WinNT:")
Set oADsObject = oADsNamespace.OpenDSObject(strADsPath, strDomain & "\" & strUserName, strpassword, 0)
WindowsLogin = True 'ACCESS GRANTED
ExitSub:
Exit Function
IncorrectPassword:
WindowsLogin = False 'ACCESS DENIED
Resume ExitSub
End Function
I notice that sometimes when the information is entered correctly, access is denied. I tried to debug once and it gave the error: "The network path was not found.
" on the Set oADsObject = oADsNamespace.OpenDSObject) line.
Not sure why this occurs sometimes. Is it better to convert to LDAP instead? I have tried but can't construct the LDAP URL correctly.
If the user is already authenticated via their Windows login, why make them enter the details again?
If you need to know which user is logged in, you can get the username very easily by the following function:
Declare Function IGetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal sBuffer As String, lSize As Long) As Long
Function GetUserName() As String
On Error Resume Next
Dim sBuffer As String
Dim lSize As Long
Dim x As Long
sBuffer = Space$(32)
lSize = Len(sBuffer)
x = IGetUserName(sBuffer, lSize)
GetUserName = left$(sBuffer, lSize - 1)
End Function
In GxP environment it is additionally needed to enter at least password. It doesn't matter if You are logged to Windows, You need to confirm it again.
Related
I had a file (Theme file) that is stored on Sharepoint and first needed to be downloaded into the temp directory before being loaded applied to word. This worked for a while, but recently I am getting an "access denied error".
I looked around and tested other libraries CreateObject("MSXML2.ServerXMLHTTP.6.0") instead of CreateObject("Microsoft.XMLHTTP").
Interestingly, I don't get the access error message with CreateObject("MSXML2.ServerXMLHTTP.6.0"), but instead it dowloads a page with this error:
[![Screenshot of error message][1]][1]
We can't sign you in
Your browser is currently set to block cookies. You need to allow cookies to use this service.
Cookies are small text files stored on your computer that tell us when you're signed in. To learn how to allow cookies, check the online help in your web browser.
I hope someone has an idea about why this error occurs and how to solve it
Here is the code I use.
Public Sub Download(ByVal URL As String, ByVal FilePath As String, Optional ByVal Overwrite As Boolean = True)
Dim iOverwrite, oStrm
If (IsNull(Overwrite) Or Overwrite) Then
iOverwrite = 2
Else
iOverwrite = 1
End If
Dim HttpReq As Object
'NOTE: There are some issues downloading if not properly logged in! May need to loggin sharepoint again
' https://www.codeproject.com/Questions/1101499/Download-files-from-API-using-vbscript-cmd-prompt
' Based on https://stackoverflow.com/questions/22938194/xmlhttp-request-is-raising-an-access-denied-error
'Set HttpReq = CreateObject("MSXML2.ServerXMLHTTP.6.0")
Set HttpReq = CreateObject("Microsoft.XMLHTTP")
'Set HttpReq = CreateObject("MSXML2.ServerXMLHTTP.3.0")
HttpReq.Open "GET", URL, False, "username", "password"
On Error GoTo ErrorHandler
HttpReq.send
On Error GoTo 0
If HttpReq.Status = 200 Then
Set oStrm = CreateObject("ADODB.Stream")
oStrm.Open
oStrm.Type = 1
oStrm.Write HttpReq.responseBody
oStrm.SaveToFile FilePath, iOverwrite ' 1 = no overwrite, 2 = overwrite
oStrm.Close
End If
Exit Sub
ErrorHandler:
MsgBox "The file could not be downloaded. Verify that you are logged in SharePoint with word and browser.", vbCritical, "Download error"
Debug.Print "Download - Error Downloading file will not be downloaded - Error #: '" & Err.Number & "'. Error description: " & Err.description
End Sub```
[1]: https://i.stack.imgur.com/pdH6v.png
I use import function specifically designed for this. I use Sharepoint Teams site (no user/password can be sent for auth).
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
Function downloadSP(ByVal url As String, ByVal nm As String) As Long
DownloadFileFromWeb = URLDownloadToFile(0, url, nm, 0, 0) ' nm includes filename
End Function
In addition. I have to first use an ADO query to the sharepoint library directly before. This ADO connection handles authentication and allows subsequent downloads to location. There probably is another method for sending Teams authentication, but this works just fine. (it's also a great way to get data from SP List/Libraries or even within Excel files)
If testConnected Then downloadSP url, nm
Function testConnected() As Boolean
Dim cn As Object
Dim rs As Object
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.RecordSet")
listGUID = "B3657D15-5F5C-468E-B1C2-784B930FE2E6"
siteURL = "https://azuresite.sharepoint.com/sites/test/"
spSql = "Select * from ['https://azuresite.sharepoint.com/sites/test/SL%20Template/Forms/AllItems.aspx']"
cnStr = "Provider=Microsoft.ACE.OLEDB.16.0;WSS;IMEX=2;RetrieveIds=No;DATABASE=" & siteURL & "; LIST=" & listGUID & ";"
cn.ConnectionString = cnStr
On Error GoTo NotConnected
cn.Open
rs.Open spSql, cn, 1, 2
testConnected = True
cn.Close
Exit Function
NotConnected:
testConnected = False
Exit Function
End Function
So I managed to solve this issue after:
enabling accepting cookies from: https://login.microsoftonline.com/ and our SharePoint sites (also added them in trusted websites)
Clearing the cookies from the history
Use the "Microsoft.XMLHTTP" library which works (other libraries do not seem to work properly still)
I'm working on adding a document upload function to an application I've written. I want the user to be able to upload, open, and delete a document on a network drive that they cannot access normally. With this in mind, I stumbled upon Impersonation, where the user can impersonate a user account that has full rights to the drive, then dispose of that after the code has been executed.
I've never used impersonation before, so during my research I found this thread:
Impersonate a Windows or Active Directory user from a different, untrusted domain
I created and copied the class that user Max Vernon had posted as follows:
Option Explicit On
Option Infer Off
Imports System
Imports System.Runtime.InteropServices ' DLL Import
Imports System.Security.Principal ' WindowsImpersonationContext
Imports System.ComponentModel
Public Class Impersonation
'Group Type Enum
Enum SECURITY_IMPERSONATION_LEVEL As Int32
SecurityAnonymous = 0
SecurityIdentification = 1
SecurityImpersonation = 2
SecurityDelegation = 3
End Enum
Public Enum LogonType As Integer
'This logon type is intended for users who will be interactively using the computer, such as a user being logged on
'by a terminal server, remote shell, or similar process.
'This logon type has the additional expense of caching logon information for disconnected operations,
'therefore, it is inappropriate for some client/server applications, such as a mail server.
LOGON32_LOGON_INTERACTIVE = 2
'This logon type is intended for high performance servers to authenticate plaintext passwords.
'The LogonUser function does not cache credentials for this logon type.
LOGON32_LOGON_NETWORK = 3
'This logon type is intended for batch servers, where processes may be executing on behalf of a user without
'their direct intervention. This type is also for higher performance servers that process many plaintext
'authentication attempts at a time, such as mail or Web servers.
'The LogonUser function does not cache credentials for this logon type.
LOGON32_LOGON_BATCH = 4
'Indicates a service-type logon. The account provided must have the service privilege enabled.
LOGON32_LOGON_SERVICE = 5
'This logon type is for GINA DLLs that log on users who will be interactively using the computer.
'This logon type can generate a unique audit record that shows when the workstation was unlocked.
LOGON32_LOGON_UNLOCK = 7
'This logon type preserves the name and password in the authentication package, which allows the server to make
'connections to other network servers while impersonating the client. A server can accept plaintext credentials
'from a client, call LogonUser, verify that the user can access the system across the network, and still
'communicate with other servers.
'NOTE: Windows NT: This value is not supported.
LOGON32_LOGON_NETWORK_CLEARTEXT = 8
'This logon type allows the caller to clone its current token and specify new credentials for outbound connections.
'The new logon session has the same local identifier but uses different credentials for other network connections.
'NOTE: This logon type is supported only by the LOGON32_PROVIDER_WINNT50 logon provider.
'NOTE: Windows NT: This value is not supported.
LOGON32_LOGON_NEW_CREDENTIALS = 9
End Enum
Public Enum LogonProvider As Integer
'Use the standard logon provider for the system.
'The default security provider is negotiate, unless you pass NULL for the domain name and the user name
'is not in UPN format. In this case, the default provider is NTLM.
'NOTE: Windows 2000/NT: The default security provider is NTLM.
LOGON32_PROVIDER_DEFAULT = 0
LOGON32_PROVIDER_WINNT35 = 1
LOGON32_PROVIDER_WINNT40 = 2
LOGON32_PROVIDER_WINNT50 = 3
End Enum
'Obtains user token.
Declare Auto Function LogonUser Lib "advapi32.dll" (ByVal lpszUsername As String, ByVal lpszDomain As String, ByVal lpszPassword As String, ByVal dwLogonType As LogonType, ByVal dwLogonProvider As LogonProvider, ByRef phToken As IntPtr) As Integer
'Closes open handles returned by LogonUser.
Declare Function CloseHandle Lib "kernel32.dll" (ByVal handle As IntPtr) As Boolean
'Creates duplicate token handle.
Declare Auto Function DuplicateToken Lib "advapi32.dll" (ExistingTokenHandle As IntPtr, SECURITY_IMPERSONATION_LEVEL As Int16, ByRef DuplicateTokenHandle As IntPtr) As Boolean
'WindowsImpersonationContext newUser.
Private newUser As WindowsImpersonationContext
'Attempts to impersonate a user. If successful, returns
'a WindowsImpersonationContext of the new user's identity.
'
'Username that you want to impersonate.
'Logon domain.
'User's password to logon with.
Public Sub Impersonator(ByVal sDomain As String, ByVal sUsername As String, ByVal sPassword As String)
'Initialize tokens
Dim pExistingTokenHandle As New IntPtr(0)
Dim pDuplicateTokenHandle As New IntPtr(0)
If sDomain = "" Then
sDomain = System.Environment.MachineName
End If
Try
Const LOGON32_PROVIDER_DEFAULT As Int32 = 0
Const LOGON32_LOGON_NEW_CREDENTIALS = 9
Dim bImpersonated As Boolean = LogonUser(sUsername, sDomain, sPassword, LOGON32_LOGON_NEW_CREDENTIALS, LOGON32_PROVIDER_DEFAULT, pExistingTokenHandle)
If bImpersonated = False Then
Dim nErrorCode As Int32 = Marshal.GetLastWin32Error()
Throw New ApplicationException("LogonUser() failed with error code: " & nErrorCode.ToString)
End If
Dim bRetVal As Boolean = DuplicateToken(pExistingTokenHandle, SECURITY_IMPERSONATION_LEVEL.SecurityImpersonation, pDuplicateTokenHandle)
If bRetVal = False Then
Dim nErrorCode As Int32 = Marshal.GetLastWin32Error
CloseHandle(pExistingTokenHandle)
Throw New ApplicationException("DuplicateToken() failed with error code: " & nErrorCode)
Else
Dim newId As New WindowsIdentity(pDuplicateTokenHandle)
Dim impersonatedUser As WindowsImpersonationContext = newId.Impersonate
newUser = impersonatedUser
End If
Catch ex As Exception
MessageBox.Show("An error has occurred. Please contact Technical Support. " & vbCrLf & ex.Message, "Application Title", MessageBoxButtons.OK, MessageBoxIcon.Error)
Finally
If pExistingTokenHandle <> IntPtr.Zero Then
CloseHandle(pExistingTokenHandle)
End If
If pDuplicateTokenHandle <> IntPtr.Zero Then
CloseHandle(pDuplicateTokenHandle)
End If
End Try
End Sub
Public Sub Undo()
newUser.Undo()
End Sub
End Class
The impersonation works great for "uploading" (actually just copying a file over from the users local files to the network drive, creating a specific file path if it doesn't exist) but doesn't seem to work when trying to open the file back up, or delete said file.
I get an access denied error like this:
Error Message When Trying to Open File
The Open File Click Event and Class Call Looks Like This:
Private Sub btnOpenDoc_Click(sender As Object, e As EventArgs) Handles btnOpenDoc.Click
Dim Impersonator As New Impersonation
Dim sUser As String = "UserNameGoesHere"
Dim sPass As String = "PasswordGoesHere"
Dim sDomain As String = "DomainGoesHere"
Try
If sActionID <> "" And iDocument = 1 Then
'Starts impersonation
Impersonator.Impersonator(sDomain, sUser, sPass)
Process.Start(RetrieveFilePath())
'Ends Impersonation
Impersonator.Undo()
End If
Catch ex As Exception
MessageBox.Show("An error has occurred. Please contact Technical Support. " & vbCrLf & ex.Message, "Application Title", MessageBoxButtons.OK, MessageBoxIcon.Error)
modGlobal.WriteToErrorLog(ex.Message, "frmActionEntry", modGlobal.GetExceptionInfo(ex), "frmActionEntry->btnOpenDoc_Click", currentUser.getEmployeeName())
End Try
End Sub
Here's Document Delete Function:
Private Function DeleteFile() As Boolean
Dim Impersonator As New Impersonation
Dim sUser As String = "UsernameGoesHere"
Dim sPass As String = "PasswordGoesHere"
Dim sDomain As String = "DomainGoesHere"
Try
'Starts impersonation
Impersonator.Impersonator(sDomain, sUser, sPass)
File.Delete(RetrieveFilePath())
Return True
'Ends Impersonation
Impersonator.Undo()
Catch ex As Exception
MessageBox.Show("An error has occurred. Please contact Technical Support. " & vbCrLf & ex.Message, "Application Title", MessageBoxButtons.OK, MessageBoxIcon.Error)
modGlobal.WriteToErrorLog(ex.Message, "frmActionEntry", modGlobal.GetExceptionInfo(ex), "frmActionEntry->DeleteFile", currentUser.getEmployeeName())
Return False
End Try
End Function
It's used in basically the same way in the FileSave function. Like I said I'm new to impersonation, and feel like I've hit a wall, having researched and tried various things all morning. Any advice is much appreciated!
-Levi
So after much research and trial and error I have an answer to this.
The short answer:
There is not a clean, elegant way to use impersonation to open a file on a network drive because you either butt heads with Windows Security or run into problems with Windows Shell. I decided to go another route.
The long answer:
I believe I was correct in that the Access was Denied error was due to trying to open a file as the impersonated user on the local user's computer. To get around this I decided to try and use ProcessStartInfo() to pass in the correct credentials (while also using impersonation to access the drive) like this:
'Opens the document associated with this action
Private Sub btnOpenDoc_Click(sender As Object, e As EventArgs) Handles btnOpenDoc.Click
'Initializes an impersonation object
Dim Impersonator As New Impersonation
'Strings with login credentials
Dim sUser As String = "UsernameGoesHere"
Dim sPass As String = "PasswordGoesHere"
Dim sDomain As String = "DomainGoesHere"
'Used to load file path in from RetrieveFilePath()
Dim sPath As String = ""
Try
If sActionID <> "" And iDocument = 1 Then
'Starts impersonation
Impersonator.Impersonator(sDomain, sUser, sPass)
'Initializes a ProcessStartInfo Object to use with impersonation
'as Process.Start class always inherits the security context of
'the parent process i.e. the local user
Dim startInfo As New ProcessStartInfo()
'Creates a secure string as the startInfo.Password parameter only accepts SecureStrings
Dim securePass As New Security.SecureString()
'You can't put a full string into a SecureString, so appending char by char
For Each c As Char In sPass
securePass.AppendChar(c)
Next
'Grab the file path
sPath = RetrieveFilePath()
'Load in the parameters for startInfo
startInfo.FileName = sPath
startInfo.UserName = sUser
startInfo.Password = securePass
startInfo.Domain = sDomain
startInfo.UseShellExecute = False
startInfo.WorkingDirectory = "\\Directory\Goes Here"
If File.Exists(sPath) Then
'Execute the process using startInfo
Process.Start(startInfo)
Else
MsgBox("File Not Found!")
End If
'Dispose of securePass
securePass.Dispose()
'Ends Impersonation
Impersonator.Undo()
End If
Catch ex As Exception
MessageBox.Show("An error has occurred. Please contact Technical Support. " & vbCrLf & ex.Message, "Application Title", MessageBoxButtons.OK, MessageBoxIcon.Error)
modGlobal.WriteToErrorLog(ex.Message, "frmActionEntry", modGlobal.GetExceptionInfo(ex), "frmActionEntry->btnOpenDoc_Click", currentUser.getEmployeeName())
End Try
End Sub
There are some interesting aspects to note here. You have to use a SecureString for the password when using ProcessStartInfo, and can only be assigned per character, and more importantly, I had to set UseShellExecute property to False.
I was hopeful that this would work, but after some iterations I got stuck on this error message:
Error Message Example
I figured out that this was due to being unable to access Windows Shell to find the default program to open the corresponding file type with, so it just expected an executable. After more research I was unable to find a clean way to get around this so I've decided to go about addressing this file upload a different way.
I know this is an old question, but maybe it can help someone else, I had the same problem and finally, realized that it's not enough to grant access to the impersonate user to read and write on the folder but also modify, if you don't, the user can not delete the file.
I am working on converting parts of a VB6 Project to VB.Net and there are some code segments I am having issues with because I can't seem to find alternatives for the VB6 code in VB.Net. Here is the code block in question right now:
Public Sub ProcessError(ByVal strModule As String, ByVal strProcedure As String, _
ByVal strDescription As String, ByVal bLogError As Boolean, _
ByVal bShowError As Boolean, Optional ByVal strMsg As String)
On Error GoTo 100
Dim intFile As Integer: Dim strPathName As String
strPathName = AddBackSlash(gsLogPath) & gsErrLogName
If bLogError = True Then
If GetFileSize(strPathName) > gcuMaxLogFileSize Then
Call CopyFile(strPathName, strPathName & ".bak")
Call DeleteFile(strPathName)
End If
intFile = FreeFile
Open strPathName For Append As #intFile
Write #intFile, Format(Now, "MMM-DD-YYYY HH:MM:SS AMPM"), strModule, strProcedure, strDescription)
Close #intFile
End If
If bShowError Then
Call Prompt("Error occurred in " & strModule & vbCrLf & "Error Description :" & strDescription, 1, vbRed)
End If
Exit Sub
100:
Close #intFile
End Sub
So the lines I am having issue with are:
Open strPathName For Append As #intFile
Write #intFile
Close #intFile
I understand I should probably be using the StreamWriter object in place of these, but what throws me off is the Error section. If an error is thrown and it goes to the 100 mark, how would Close #intFile work if it hasn't been opened or created yet?
For most of the other conversion annoyances I've had with porting this over this one has been confusing me the most, so any help is appreciated. Thanks for your time.
This fixes the errors, and also updates a lot of the code to use styles and APIs more typical for modern VB.Net. For this to work as-is, make sure there is an Imports System.IO directive at the top of the file.
Public Sub ProcessError(ByVal ModuleName As String, ByVal ProcedureName As String, _
ByVal Description As String, ByVal LogError As Boolean, _
ByVal ShowError As Boolean, Optional ByVal Message As String)
If LogError Then
Dim logFile As New FileInfo(Path.Combine(gsLogPath, gsErrLogName))
If logFile.Length > gcuMaxLogFileSize Then
logFile.MoveTo(logFile.FullName & ".bak")
End If
Try
File.AppendAllText(PathName, String.Format("{0:d},""{1}"",""{2}"",""{3}""", DateTime.Now, ModuleName, ProcedureName, Description))
Catch
End Try
End If
If ShowError Then
MsgBox(String.Format("Error occurred in {0}{1}Error Description:{2}", ModuleName, vbCrLf, Description))
End If
End Sub
One thing worth pointing out here is the style guidelines published by Microsoft for VB.Net now explicitly recommend against hungarian type-prefixes.
If you just have one line to write to, you can use the build-in method that does all the work for you.
Dim inputString As String = "This is a test string."
My.Computer.FileSystem.WriteAllText(
"C://testfile.txt", inputString, True)
More help here: https://learn.microsoft.com/en-us/dotnet/visual-basic/developing-apps/programming/drives-directories-files/how-to-append-to-text-files?view=netframework-4.7.2
I have successfully coded some VBA macros for work which basically create a data file, feed it to a program and post-treat the output from this program.
My issue is that the program installation path is hard coded in the macro and the installation may vary accross my colleagues computers.
The first thing I thought is that I can gather from everyone the different installation directories and test for all of them in the code. Hopefully, one of them will work. But it doesn't feel that clean.
So my other idea was to somehow get the installation directory in the code. I thought it would be possible as in Windows, if I right click on a shortcut, I can ask to open the file's directory. What I'm basically looking for is an equivalent in VBA of this right click action in Windows. And that's where I'm stuck.
From what I found, Windows API may get the job done but that's really out of what I know about VBA.
The API FindExecutable seemed not too far from what I wanted but I still can't manage to use it right. So far, I can only get the program running if I already know its directory.
Could you give me some pointers ? Thanks.
Here's another method for you to try. Note that you might see a black box pop up for a moment, that's normal.
Function GetInstallDirectory(appName As String) As String
Dim retVal As String
retVal = Split(CreateObject("WScript.Shell").Exec("CMD /C FOR /r ""C:\"" %i IN (*" & appName & ") DO (ECHO %i)").StdOut.ReadAll, vbCrLf)(2)
GetInstallDirectory = Left$(retVal, InStrRev(retVal, "\"))
End Function
It's not as clean as using API but should get the trick done.
Summary:
retVal = Split(CreateObject("WScript.Shell").Exec("CMD /C FOR /r ""C:\"" %i IN (*" & appName & ") DO (ECHO %i)").StdOut.ReadAll, vbCrLf)(1)
"CMD /C FOR /r ""C:\"" %i IN (*" & appName & ") DO (ECHO %i)" is a command that works in CMD to loop through files rooted at a defined path. We use the wildcard with the appName variable to test for the program we want. (more info on FOR /R here) Here, we have created the CMD application using a Shell object (WScript.Shell) and Executed the command prompt CMD passing arguments to it directly after. The /C switch means that we want to pass a command to CMD and then close the window immediately after it's processed.
We then use .StdOut.ReadAll to read all of the output from that command via the Standard Output stream.
Next, we wrap that in a Split() method and split the output on vbCrLf (Carriage return & Line feed) so that we have a single dimension array with each line of the output. Because the command outputs each hit on a new line in CMD this is ideal.
The output looks something like this:
C:\Users\MM\Documents>(ECHO C:\Program Files\Microsoft
Office\Office14\EXCEL.EXE ) C:\Program Files\Microsoft
Office\Office14\EXCEL.EXE
C:\Users\MM\Documents>(ECHO
C:\Windows\Installer\$PatchCache$\Managed\00004109110000000000000000F01FEC\14.0.4763\EXCEL.EXE
)
C:\Windows\Installer\$PatchCache$\Managed\00004109110000000000000000F01FEC\14.0.4763\EXCEL.EXE
C:\Users\olearysa\Documents>(ECHO
C:\Windows\Installer\$PatchCache$\Managed\00004109110000000000000000F01FEC\14.0.7015\EXCEL.EXE
)
C:\Windows\Installer\$PatchCache$\Managed\00004109110000000000000000F01FEC\14.0.7015\EXCEL.EXE
We're only interested in the third line of the output (the first line is actually blank), so we can access that index of the array directly by using (2) after it (because arrays are zero-indexed by default)
Finally, we only want the path so we use a combination of Left$() (which will return n amount of characters from the left of a string) and InStrRev() (which returns the position of a substring starting from the end and moving backwards). This means we can specify everything from the left until the first occurrence of \ when searching backwards through the string.
Give this a try, assuming you know the name of the .exe:
#If Win64 Then
Declare PtrSafe Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _
(ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
#Else
Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _
(ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
#End If
Const SYS_OUT_OF_MEM As Long = &H0
Const ERROR_FILE_NOT_FOUND As Long = &H2
Const ERROR_PATH_NOT_FOUND As Long = &H3
Const ERROR_BAD_FORMAT As Long = &HB
Const NO_ASSOC_FILE As Long = &H1F
Const MIN_SUCCESS_LNG As Long = &H20
Const MAX_PATH As Long = &H104
Const USR_NULL As String = "NULL"
Const S_DIR As String = "C:\" '// Change as required (drive that .exe will be on)
Function GetInstallDirectory(ByVal usProgName As String) As String
Dim fRetPath As String * MAX_PATH
Dim fRetLng As Long
fRetLng = FindExecutable(usProgName, S_DIR, fRetPath)
If fRetLng >= MIN_SUCCESS_LNG Then
GetInstallDirectory = Left$(Trim$(fRetPath), InStrRev(Trim$(fRetPath), "\"))
End If
End Function
Example of how to use, let's try looking for Excel:
Sub ExampleUse()
Dim x As String
x = "EXCEL.EXE"
Debug.Print GetInstallDirectory(x)
End Sub
Output (on my machine anyway) is
C:\Program Files\Microsoft Office\Office14\
Assuming you are working on PC only and the people are working with their own copies and not a shared network copy. I would recommend the following.
Create a Sheet called 'Config', place the path with the exe in there, and then hide it.
Use use FileScriptingObject ('Tools' > 'References' > 'Microsoft Scripting Runtime') to see if the path in 'Config' exists
If it does not, ask the user for the location using a 'open file dialog box' and remember that in the 'Config' Sheet for next time.
The below code may help as a pointer.
Dim FSO As New FileSystemObject
Private Function GetFilePath() As String
Dim FlDlg As FileDialog
Dim StrPath As String
Set FlDlg = Application.FileDialog(msoFileDialogOpen)
With FlDlg
.Filters.Clear
.Filters.Add "Executable Files", "*.exe"
.AllowMultiSelect = False
.ButtonName = "Select"
.Title = "Select the executable"
.Show
If .SelectedItems.Count <> 0 Then GetFilePath = .SelectedItems(1)
End With
Set FlDlg = Nothing
End Function
Private Function FileExists(ByVal StrPath As String) As Boolean
FileExists = FSO.FileExists(StrPath)
End Function
I need to authenticate against a remote SQL Server using Windows Authentication. The remote SQL Server is running in another domain that does not have a trust relationship with the domain I'm currently logged into via Windows. I cannot use SQL Server authentication since the SQL Server is configured to only trust domain authentication.
Windows itself allows this type of impersonation through the user interface:
I've used WindowsImpersonationContext class from System.Security.Principal before, but that appears to rely upon the desired username belonging to a trusted domain.
I'm using Visual Studio 2012, and can use up to Microsoft.Net 4.5, with preferably VB, but I can easily convert code from C# if necessary.
For the benefit of future visitors, I'm posting some VB.Net code that allows a process to use NETONLY impersonation to authenticate against a remote server that resides in an untrusted domain:
Option Explicit On
Option Infer Off
Imports System
Imports System.Runtime.InteropServices ' DllImport
Imports System.Security.Principal ' WindowsImpersonationContext
Public Class clsAuthenticator
' group type enum
Enum SECURITY_IMPERSONATION_LEVEL As Int32
SecurityAnonymous = 0
SecurityIdentification = 1
SecurityImpersonation = 2
SecurityDelegation = 3
End Enum
Public Enum LogonType As Integer
'This logon type is intended for users who will be interactively using the computer, such as a user being logged on
'by a terminal server, remote shell, or similar process.
'This logon type has the additional expense of caching logon information for disconnected operations;
'therefore, it is inappropriate for some client/server applications,
'such as a mail server.
LOGON32_LOGON_INTERACTIVE = 2
'This logon type is intended for high performance servers to authenticate plaintext passwords.
'The LogonUser function does not cache credentials for this logon type.
LOGON32_LOGON_NETWORK = 3
'This logon type is intended for batch servers, where processes may be executing on behalf of a user without
'their direct intervention. This type is also for higher performance servers that process many plaintext
'authentication attempts at a time, such as mail or Web servers.
'The LogonUser function does not cache credentials for this logon type.
LOGON32_LOGON_BATCH = 4
'Indicates a service-type logon. The account provided must have the service privilege enabled.
LOGON32_LOGON_SERVICE = 5
'This logon type is for GINA DLLs that log on users who will be interactively using the computer.
'This logon type can generate a unique audit record that shows when the workstation was unlocked.
LOGON32_LOGON_UNLOCK = 7
'This logon type preserves the name and password in the authentication package, which allows the server to make
'connections to other network servers while impersonating the client. A server can accept plaintext credentials
'from a client, call LogonUser, verify that the user can access the system across the network, and still
'communicate with other servers.
'NOTE: Windows NT: This value is not supported.
LOGON32_LOGON_NETWORK_CLEARTEXT = 8
'This logon type allows the caller to clone its current token and specify new credentials for outbound connections.
'The new logon session has the same local identifier but uses different credentials for other network connections.
'NOTE: This logon type is supported only by the LOGON32_PROVIDER_WINNT50 logon provider.
'NOTE: Windows NT: This value is not supported.
LOGON32_LOGON_NEW_CREDENTIALS = 9
End Enum
Public Enum LogonProvider As Integer
'Use the standard logon provider for the system.
'The default security provider is negotiate, unless you pass NULL for the domain name and the user name
'is not in UPN format. In this case, the default provider is NTLM.
'NOTE: Windows 2000/NT: The default security provider is NTLM.
LOGON32_PROVIDER_DEFAULT = 0
LOGON32_PROVIDER_WINNT35 = 1
LOGON32_PROVIDER_WINNT40 = 2
LOGON32_PROVIDER_WINNT50 = 3
End Enum
' obtains user token
Declare Auto Function LogonUser Lib "advapi32.dll" (ByVal lpszUsername As String, ByVal lpszDomain As String, ByVal lpszPassword As String, ByVal dwLogonType As LogonType, ByVal dwLogonProvider As LogonProvider, ByRef phToken As IntPtr) As Integer
' closes open handles returned by LogonUser
Declare Function CloseHandle Lib "kernel32.dll" (ByVal handle As IntPtr) As Boolean
' creates duplicate token handle
Declare Auto Function DuplicateToken Lib "advapi32.dll" (ExistingTokenHandle As IntPtr, SECURITY_IMPERSONATION_LEVEL As Int16, ByRef DuplicateTokenHandle As IntPtr) As Boolean
'WindowsImpersonationContext newUser;
Private newUser As WindowsImpersonationContext
'
' Attempts to impersonate a user. If successful, returns
' a WindowsImpersonationContext of the new user's identity.
'
' Username you want to impersonate
' Logon domain
' User's password to logon with
'
Public Sub Impersonator(ByVal sDomain As String, ByVal sUsername As String, ByVal sPassword As String)
' initialize tokens
Dim pExistingTokenHandle As New IntPtr(0)
Dim pDuplicateTokenHandle As New IntPtr(0)
If sDomain = "" Then
sDomain = System.Environment.MachineName
End If
Try
Const LOGON32_PROVIDER_DEFAULT As Int32 = 0
Const LOGON32_LOGON_NEW_CREDENTIALS = 9
Dim bImpersonated As Boolean = LogonUser(sUsername, sDomain, sPassword, LOGON32_LOGON_NEW_CREDENTIALS, LOGON32_PROVIDER_DEFAULT, pExistingTokenHandle)
If bImpersonated = False Then
Dim nErrorCode As Int32 = Marshal.GetLastWin32Error()
Throw New ApplicationException("LogonUser() failed with error code: " & nErrorCode.ToString)
End If
Dim bRetVal As Boolean = DuplicateToken(pExistingTokenHandle, SECURITY_IMPERSONATION_LEVEL.SecurityImpersonation, pDuplicateTokenHandle)
If bRetVal = False Then
Dim nErrorCode As Int32 = Marshal.GetLastWin32Error
CloseHandle(pExistingTokenHandle)
Throw New ApplicationException("DuplicateToken() failed with error code: " & nErrorCode)
Else
Dim newId As New WindowsIdentity(pDuplicateTokenHandle)
Dim impersonatedUser As WindowsImpersonationContext = newId.Impersonate
newUser = impersonatedUser
End If
Catch ex As Exception
Finally
If pExistingTokenHandle <> IntPtr.Zero Then
CloseHandle(pExistingTokenHandle)
End If
If pDuplicateTokenHandle <> IntPtr.Zero Then
CloseHandle(pDuplicateTokenHandle)
End If
End Try
End Sub
Public Sub Undo()
newUser.Undo()
End Sub
End Class
This can be called from another piece of code like so:
Dim Impersonator As New clsAuthenticator
Dim sDomain as string = "SomeDomain"
Dim sUser as string = "SomeUserName"
Dim sPass as string = "SomePassword"
Impersonator.Impersonator(sDomain, sUser, sPass)
' Run whatever code needs to run against the remote server
Impersonator.Undo
The standard warning of not actually embedding passwords in code certainly applies here. In the real world my app obtains the password from an encrypted column in a database.