If an open workbook (located on a server) is in read only mode, how can I display the active username using VBA?
I've looked into .WriteReservedBy but this only shows the name of the person that last saved the file with a password.
This should probably be a comment but my reputation is too low
I've seen this but never needed the info...
Things to try:
ThisWorkbook.UserStatus - array with all current users for the file open as exclusive or shared
Environ("USERNAME")
CreateObject("WScript.NetWork").UserName
API calls:
.
Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA"
( _
ByVal lpName As String, _
ByVal lpUserName As String, _
lpnLength As Long
) As Long
Declare Function GetUserName& Lib "advapi32.dll" Alias "GetUserNameA" _
(ByVal lpBuffer As String, nSize As Long)
.
more details about these APIs:
https://support.microsoft.com/en-us/kb/161394
http://www.vbaexpress.com/kb/getarticle.php?kb_id=768
WMI Win32_NetworkConnection:
Public Function GetActiveUser(Optional ByVal computer As String = ".") As String
Dim wmi As Object, itm As String
On Error Resume Next
Set wmi = GetObject("winmgmts:\\" & computer & "\Root\CIMv2")
itm = wmi.ExecQuery("Select UserName from Win32_NetworkConnection", , 48)
GetNetActiveUser = itm
End Function
Related
I need to print selected pages of *.pdf file using excel VBA.
I need to do this not by providing scope "from - to" but giving scoope of pages like "1-3,4,8, 17-25"
I can only print whole file using below code:
Public 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
Public Function PrintThisDoc(formname As Long, FileName As String)
On Error Resume Next
Dim X As Long
X = ShellExecute(formname, "Print", FileName, 0&, 0&, 3)
End Function
Sub testPrint()
Dim printThis
Dim strDir As String
Dim strFile As String
strDir = "C:\Users\any\Desktop"
strFile = "somefile.pdf"
printThis = PrintThisDoc(0, strDir & "\" & strFile)
End Sub ```
Judging from this post, it is not possible using ShellExecute alone. What you would need is to write a script which will open the file in whatever PDF reader you have installed, find a "Print" button there and provide all the options. This will take a huge amount of work and will depend on the version of Windows and the PDF reader, so basically it will work only for you, and not for other users.
If you want to go this path though, take a look at FindWindow and SendMessage WinAPI functions.
Cell A3 contains folder path. Cells below contain file names with extensions. Upon selecting a cell below, my Excel macro opens that file's location in File Explorer and out of multiple files in that folder selects this particular one, which can be seen in Preview. When next cell containing another file name is selected on the spreadsheet, another File Explorer window opens, even though it's the same path from A3. Looking for a line of code to add which will first close the first File Explorer window, before opening a new one. The code needs to be closing that specific File Explorer window from cell A3, out of multiple open File Explorer windows. Code I have so far
UPDATE: Running below codes, but it does not close the existing opened folder, just opens yet another:
If Target.Column = 1 And Target.Row > 5 Then
Call CloseWindow
Shell "C:\Windows\explorer.exe /select," & Range("A3") & ActiveCell(1, 1).Value, vbNormalFocus 'this works, but opens NEW folder every time
and in separate Module:
'BELOW GOES WITH Public Sub CloseWindow() FROM: https://stackoverflow.com/questions/49649663/close-folder-opened-through-explorer-exe
Option Explicit
''for 64-bit Excel use
'Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
' (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Long) As LongPtr
''for 32-bit Excel use
'Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
' (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
'To make it compatible with both 64 and 32 bit Excel you can use
#If VBA7 Then
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Long) As LongPtr
#Else
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
#End If
'Note that one of these will be marked in red as compile error but the code will still run.
Const WM_SYSCOMMAND = &H112
Const SC_CLOSE = &HF060
Public Sub CloseWindow()
Dim sh As Object
Set sh = CreateObject("shell.application")
Dim w As Variant
For Each w In sh.Windows
'print all locations in the intermediate window
Debug.Print w.LocationURL
' select correct shell window by LocationURL
' If w.LocationURL = "file://sharepoint.com#SSL/DavWWWRoot/sites/folder" Then
'If w.LocationURL = "Range("M1").value" Then
If w.LocationURL = "file://K:/ppp/xx/yy/1 - zzz" Then
SendMessage w.hWnd, WM_SYSCOMMAND, SC_CLOSE, 0
End If
Next w
End Sub
UPDATE 2:
I am now thinking however, that probably the best solution would actually be not to close the file explorer and then open it, but rather for the code to identify that there is already an open file explorer window with path from cell A3 and neither close it nor open a new one, but rather just select the new file corresponding to the new cell being clicked on in already opened file explorer window with path from cell A3. Can anybody think of a way to do that?
I found an solution (not my own) that implements a WMI query against a 'Win32_Process' Class. The code here closes any explorer.exe instances. While I don't fully understand it, I did test and found it works.
Sub CloseWindow()
Dim objWMIcimv2 As Object, objProcess As Object, objList As Object
Dim intError As Integer
Set objWMIcimv2 = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objList = objWMIcimv2.ExecQuery("select * from win32_process where name='explorer.exe'")
For Each objProcess In objList
intError = objProcess.Terminate
If intError <> 0 Then Exit For
Next
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
End Sub
This will do the job for you. If the folder is not open it will open it, otherwise it will activate it and will bring it to the front.
In case you want to select a file in the folder, you should modify this a bit and use oWinOpen.Quit to close the window and then re-open it. Shell's behavior when opening a folder simply is different from when selecting a file in the folder too.
Sub OpenFolder(strPath As String)
Dim bFolderIsOpen As Boolean
Dim oShell As Object
Dim oWinOpen As Object
Dim Wnd As Object
Set oShell = CreateObject("Shell.Application")
bFolderIsOpen = FALSE
For Each Wnd In oShell.Windows
If Wnd.Document.Folder.Self.Path = strPath Then
Set oWinOpen = Wnd
bFolderIsOpen = TRUE
End If
Next Wnd
If bFolderIsOpen = FALSE Then 'open it for the first time
Call Shell("explorer.exe" & " " & """" & strPath & """", vbNormalFocus)
Else
oWinOpen.Visible = FALSE
oWinOpen.Visible = TRUE
End If
So I have been trying to add a level of security to a tool, and I came upon this post. The code works when on the network/domain, but I need to use this somehow for people who are remote and not on the network, nor vpn'ed into the network. Is this possible? I am learning as I go here, so this may not even be feasible in the first place. Just looking for every avenue possible.
Example Code:
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
EDIT: So #user2140261 told me about trying the LogonUser function from Advapi32.dll which looks like below:
Private Declare Function LogonUser Lib "advapi32.dll" Alias "LogonUserA" (ByVal lpszUsername As String, ByVal lpszDomain As String, ByVal lpszPassword As String, ByVal dwLogonType As UInteger, ByVal dwLogonProvider As UInteger, ByRef phToken As IntPtr) As Boolean
Sub LoginTest()
Dim logname As String
Dim logpass As String
Dim domainstring As String
logname = "username"
logpass = "password"
domainstring = "domain.com"
Call WindowsLogin(logname, logpass, domainstring)
End Sub
For some reason, this crashes Excel all together. Any reason why?
Not sure what the sub WindowsLogin is dong in your orininal code but try the below:
Private Declare Function LogonUser Lib "Advapi32" Alias "LogonUserA" _
(ByVal lpszUsername As String, ByVal lpszDomain As String, ByVal lpszPassword As String, _
ByVal dwLogonType As Long, ByVal dwLogonProvider As Long, phToken As Long) As Long
Public Sub LogUserOn()
Dim strUserName As String
Dim strPassword As String
Dim strDomain As String
Dim bResult As Boolean
strUserName = "UserName"
strPassword = "Password"
strDomain = "Domain"
bResult = LogonUser(strUserName, strDomain, strPassword, 2, 0, 0)
If bResult Then
MsgBox "Successfully Logged User In"
Else: MsgBox "And Error Occured While Trying To Log User In " & vbCrLf _
& "Error Code:" & Err.LastDllError
End If
End Sub
As the answer in the post you referenced said, if you just need to know who is using the app, and apply security based on that, then you can just get the logged-in user's name from the OS. The user can log into their laptop when disconnected using their cached credentials, and your app will be able to lock down whatever is needed based on the identity asserted by the OS.
Update
There are a couple of ways to get the User's identity from the OS. One is the environment variables %USERDOMAIN% and %USERNAME%. Another is the WScript.Network object:
Set WshNetwork = WScript.CreateObject("WScript.Network")
WScript.Echo "Domain = " & WshNetwork.UserDomain
WScript.Echo "User Name = " & WshNetwork.UserName
You can validate that the user is logged into the correct domain, and then provide access to the secured features.
I was using environ("username"), then moved to:
Private Declare PtrSafe Function apiGetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Function fOSUserName() As String
' Returns the network login name
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = apiGetUserName(strUserName, lngLen)
If (lngX > 0) Then
fOSUserName = Left$(strUserName, lngLen - 1)
Else
fOSUserName = vbNullString
End If
End Function
But I want to be able to check what the domain is, and if it is an actual domain or just a local machine name etc... Is this possible?
I've already had discussions regarding setting up domain groups/security groups etc, so do not need input regarding these thank you.
well, Environ("USERDOMAIN") should get the domain name, but if you want to use api declarations, then you would need:
Private Declare Function LookupAccountName Lib "advapi32" Alias "LookupAccountNameA" (ByVal lpSystemName As String, _
ByVal lpAccountName As String, Sid As Byte, cbSid As Long, ByVal DomainName As String, _
cbDomainName As Long, peUse As Long) As Long
an example can be found here
I would like to save an Excel file as a .pdf file to a specific location and then send the file in a mail.
I'm using Office 2000 :|
This is my code so far:
Application.ActivePrinter = "PDF995 on Ne00:"
ActiveSheet.PageSetup.PrintArea = Range("A68").Value
ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
"PDF995 on Ne00:", Collate:=True
Set WB = ActiveWorkbook
Set oApp = CreateObject("Outlook.Application")
Set omail = oApp.Createitem(0)
With omail
.To = Range("B61").Value
.Subject = "Approved"
.Body
.Display
Rows("81:134").Select
Selection.EntireRow.Hidden = True
End With
I can easily save the file and mail it, but I can't save it to a specific location.
I need to be able to specificy a path like "C:\path\file.pdf".
If you have the file saved to fixed location but you're unable to choose where, as a last resort you could always use fso's MoveFile to move it to your specified location
eg. If the file is always saved as "C:\temp\file1.pdf", and you want it on desktop
'Initialise first'
set fso = CreateObject("Scripting.FileSystemObject")
...
'After procedure'
desired_destination = "c:\windows\desktop\"
target_file = "C:\temp\file1.pdf"
fso.MoveFile target_file, desired_destination
If you want to check for an existing file conflict (I believe fso's Move doesn't allow for overwrite), use CopyFile with over-write switched on then Delete the source file if necessary
If you'd like to use a file dialog to choose the destination, you can use the UserAccounts.CommonDialog object (although that doesn't work with Vista) or SAFRCFileDlg.FileOpen (pretty much only works on XP) or borrow an IE prompted box. (Unfortunately the options aren't all that great with VBS to my knowledge)
Check them out here: http://www.robvanderwoude.com/vbstech_ui_fileopen.php
It's a little complicated, as you have to set registry keys.
Assuming that you have a full version of Adobe Acrobat that has installed the initial registry keys:
First, you have the registry accessing functions, which you put in a non-sheet module:
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const KEY_SET_VALUE = &H2&
Private Const REG_SZ = 1
Private Declare Function RegOpenKeyEx Lib "advapi32" _
Alias "RegOpenKeyExA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) As Long
Private Declare Function RegSetValueExA Lib "ADVAPI32.DLL" _
(ByVal hKey As Long, _
ByVal sValueName As String, _
ByVal dwReserved As Long, _
ByVal dwType As Long, _
ByVal sValue As String, _
ByVal dwSize As Long) As Long
Private Declare Function RegCloseKey Lib "ADVAPI32.DLL" ( _
ByVal hKey As Long) As Long
Then, you use the following code to set the registry key that tells Adobe where to save the file. Note, it has to be set everytime you print.
Dim RegResult As Long, Result As Long
RegResult = RegOpenKeyEx(HKCU, "Software\Adobe\Acrobat Distiller\PrinterJobControl", _
0&, KEY_SET_VALUE, Result)
RegResult = RegSetValueExA(Result, "C:\Windows\splwow64.exe", 0&, REG_SZ, _
FileName, Len(FileName))
RegResult = RegCloseKey(Result)
Also Note, the "C:\Windows\splwow64.exe" is what I needed for my Excel 2010 32-bit, and it may be different for you. To determine it (which won't change) first print manually to PDF, then go to the registry key and see what application is used in the HKCU\Software\Adobe\Acrobat Distiller\PrinterJobControl LastPDFPortFolder key. Then use the name of the full application path for that executable.
Try this:
sName = "C:\path\file.pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sName