I Have created a user form that will open an excel file open & hide the excel. When closing the user form will save & close the excel file. However, there are two types of users of the excel file.
Editors - Those who are entering data into the file
Viewers - Those who are viewing a file.
The folder which has the excel file only allow "Editors" to save. (Others have no permission to write). Therefore, I have to avoid save part if the user has no wright permission to the folder. Any ideas? My code for the close event of user form is here.
Private Sub UserForm_QueryClose (Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
If ws.AutoFilterMode Then ws.AutoFilterMode = False
ws.Columns("F:H").Copy
ws.Activate
ws.Range("F1").Select
Application.DisplayAlerts = False
Selection.PasteSpecial Paste:=xlPasteValues
Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.Visible = True
ActiveWorkbook.CheckCompatibility = False
ThisWorkbook.Close savechanges:=True
ActiveWorkbook.CheckCompatibility = True
End If
End Sub
Ws Denoted the declared name for the worksheet.
Edit
I have tried & found an alternative method to overcome the situation. However, this is not the solution & is a dirty method to get the result. Please see below code.
Private Sub UserForm_QueryClose (Cancel As Integer, CloseMode As Integer)
On Error Resume Next
If CloseMode = vbFormControlMenu Then
If ws.AutoFilterMode Then ws.AutoFilterMode = False
ws.Columns("F:H").Copy
ws.Activate
ws.Range("F1").Select
Application.DisplayAlerts = False
Selection.PasteSpecial Paste:=xlPasteValues
Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.Visible = True
ActiveWorkbook.CheckCompatibility = False
ThisWorkbook.Save
ThisWorkbook.Close savechanges:=False
ActiveWorkbook.CheckCompatibility = True
End If
End Sub
On above code I have tracked error generated during the save process of viewers & jump to next line by using
on error resume next.
The answer above from Macro Man, while succinct and useful, will not work in an environment where folder access is managed by user groups instead of user names. As many corporate environments - including my own - use this method to manage folder access, I have posted below a solution that will assess a user's actual permissions to a folder. This will work whether the user has been granted individual or group access to a folder.
Private Function TestWriteAccess(ByVal StrPath As String) As Boolean
Dim StrName As String, iFile As Integer, iCount As Integer, BExists As Boolean
'Set the initial output to False
TestWriteAccess = False
'Ensure the file path has a trailing slash
If Right(StrPath, 1) <> "\" Then StrPath = StrPath & "\"
'Ensure the path exists and is a folder
On Error Resume Next
BExists = (GetAttr(StrPath) And vbDirectory) = vbDirectory
If Not BExists Then GoTo Exit_TestWriteAccess 'Folder does not exist
'Set error handling - return False if we encounter an error (folder does not exist or file cannot be created)
On Error GoTo Exit_TestWriteAccess
'Get the first available file name
Do
StrName = StrPath & "TestWriteAccess" & iCount & ".tmp"
iCount = iCount + 1
Loop Until Dir(StrName) = vbNullString
'Attempt to create a test file
iFile = FreeFile()
Open StrName For Output As #iFile
Write #iFile, "Testing folder access"
Close #iFile
TestWriteAccess = True
'Delete our test file
Kill StrName
Exit_TestWriteAccess:
End Function
In researching file access, I also stumbled upon Check Access Rights to File/Directory on NTFS Volume by Segey Merzlikin on FreeVBcode.com; this solution is overkill for my needs (and OP's) but will return the exact access rights that a user has to a particular file.
This checks the access list of the workbook's folder to see if the user's name appears in the list. If it does, then save the file.
If Instr(1, Environ("USERNAME"), CreateObject("WScript.Shell").Exec("CMD /C ICACLS """ & _
ThisWorkbook.Path & """").StdOut.ReadAll) > 0 Then ThisWorkbook.Save
It does this by opening a command prompt, running the ICACLS command through it and reading the output from that command. Then it uses the InStr() method to see if the username appears in that output.
Related
I have a folder with a few hundred-word documents. I want to be able to replace the words ORG NAME by clicking a macro, filling in an input box and letting it iterate. There are thousands of instances of ORG NAME across these documents and this process needs to happen a few dozen times a year.
We've got some challenges with trust centre policies in place that can't be changed so the macro needs to be done via excel.
The below was sort of working as word macro although it was crashing a lot, I moved it over to excel and now I'm getting the error: Named argument not found against macroname:
I can't find any similar questions that aren't solved by correcting spelling.
I'm also open to better solutions if they exist, this has been my first attempt so far.
Sub Button1_Click()
Dim xFileDialog As FileDialog, GetStr(1 To 300) As String '300 files is the maximum applying this code
Dim xFindStr As String
Dim xReplaceStr As String
Dim xDoc As Object
On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFilePicker)
With xFileDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.docx", 1
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
xFindStr = "ORG NAME"
xReplaceStr = InputBox("Enter the name of the organisation:", "Document Updater for Word", xReplaceStr)
For j = 1 To i Step 1
Set xDoc = Documents.Open(Filename:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = xFindStr 'Find What
.Replacement.Text = xReplaceStr 'Replace With
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Application.Run macroname:="NEWMACROS"
ActiveDocument.Save
ActiveWindow.Close
Next
Application.ScreenUpdating = True
End With
MsgBox "Operation end, please view", vbInformation
End Sub
See this page by Ibby on the Word MVP website.
How to Find & ReplaceAll on a batch of documents in the same folder
The following code, if stored in a Global template, will perform a
Find & ReplaceAll in all of the documents in a specified folder. The
FindReplace dialog is displayed for the first document only. The user
sets the parameters in the dialog and presses Replace All and then
Close. The user is then asked whether to process all of the files in
the specified directory – if Yes, the rest of the files are processed
with the settings as entered in the original FindReplace dialog.
Option Explicit
Public Sub BatchReplaceAll()
Dim FirstLoop As Boolean
Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim Response As Long
PathToUse = "C:\Test\"
'Error handler to handle error generated whenever
'the FindReplace dialog is closed
On Error Resume Next
'Close all open documents before beginning
Documents.Close SaveChanges:=wdPromptToSaveChanges
'Boolean expression to test whether first loop
'This is used so that the FindReplace dialog will
'only be displayed for the first document
FirstLoop = True
'Set the directory and type of file to batch process
myFile = Dir$(PathToUse & "*.doc")
While myFile <> ""
'Open document
Set myDoc = Documents.Open(PathToUse & myFile)
If FirstLoop Then
'Display dialog on first loop only
Dialogs(wdDialogEditReplace).Show
FirstLoop = False
Response = MsgBox("Do you want to process " & _
"the rest of the files in this folder", vbYesNo)
If Response = vbNo Then Exit Sub
Else
'On subsequent loops (files), a ReplaceAll is
'executed with the original settings and without
'displaying the dialog box again
With Dialogs(wdDialogEditReplace)
.ReplaceAll = 1
.Execute
End With
End If
'Close the modified document after saving changes
myDoc.Close SaveChanges:=wdSaveChanges
'Next file in folder
myFile = Dir$()
Wend
End Sub
That should get you started. The page has more on subfolders and password protected files.
If you need to do more than find and replace, see also utilities for batch processing documents by Greg Maxey and by Graham Mayor.
I have a script in Access that is supposed to loop through excel files in a shared network drive, open and save them.
When running the script on a local folder it works as intended, but when running it on the network drive a popup appears saying:'A file with this name already exists in this location, do you want to save it anyways? When I press yes the popup closes, but upon checking the timestamp of the files, non of them have been overwritten.
Here is the script:
Sub demo()
Dim directory As String, fileName As String
Dim Mywb As Workbook
Dim app As New Excel.Application
app.Visible = True
directory = "Y:\E. Data Hub\4. KPIs\C. Price Competitiveness\2018\07 July\DT\"
fileName = Dir(directory & "*.xls")
Do While fileName <> ""
Workbooks.Open (directory & fileName)
fileName = Dir()
ActiveWorkbook.CheckCompatibility = False
ActiveWorkbook.Save
ActiveWorkbook.Close
Loop
app.Quit
End Sub
Ideally I wouldnt even receive those popups that I have to confirm manually and of course the files should be saved/overwritten.
Edit: I think the issue seems to be that the files are opened in read only mode. I tried fixing that issue by adding 'ReadOnly:=False, Notify:=False' to my Workbooks.Open command, but this does not work and the files still get opened in read only mode.
Second edit: Check below for a solution I answered my own question.
I found a solution to my specific issue so for anyone having the same issue in the future:
For me the issue was a result of the files being opened in 'read only' mode in excel.
To solve this I included
ActiveWorkbook.LockServerFile
into my loop.
This is the equivalent of pressing the 'edit workbook' button on excel.
My full code now looks like this:
Sub demo()
Dim directory As String, fileName As String
Dim Mywb As Workbook
Dim app As New Excel.Application
app.Visible = True
directory = "Y:\E. Data Hub\4. KPIs\C. Price Competitiveness\2018\07 July\DT\"
fileName = Dir(directory & "*.xls")
Application.Echo False
DoCmd.SetWarnings False
Do While fileName <> ""
Workbooks.Open (directory & fileName)
fileName = Dir()
ActiveWorkbook.LockServerFile
ActiveWorkbook.CheckCompatibility = False
ActiveWorkbook.Save
ActiveWorkbook.Close
Loop
app.Quit
DoCmd.SetWarnings True
Application.Echo True
End Sub
You can stop most message that excel asks the user by switching this option:
Application.DisplayAlerts
so in your code it would look like:
Public Sub demo()
Dim directory As String, fileName As String
Dim Mywb As Workbook
Dim app As New Excel.Application
app.Visible = True
directory = "Y:\E. Data Hub\4. KPIs\C. Price Competitiveness\2018\07 July\DT\"
fileName = Dir(directory & "*.xls")
Application.DisplayAlerts = False
Do While fileName <> ""
Workbooks.Open directory & fileName
fileName = Dir()
ActiveWorkbook.CheckCompatibility = False
ActiveWorkbook.Save
ActiveWorkbook.Close
Loop
Application.DisplayAlerts = True
app.Quit
End Sub
I need some way to update an excel addin shared among my staffs so as everyone don't have to download & install it manually.
I have googled and see that we can write file to the OS file system so the task ends up with writing the new-version addin, i.e. the .xlam file, to overwrite itself.
I have no idea on how to do this. If you do have ones, please share! Thank you!
I don't know if there's a less crude way of doing it, but I have "hacked" a solution that involves SendKeys. Yuck, I know. Hopefully someone else will have a better solution.
As I recall, you need to uninstall an addin before you can overwrite the .xla(m) file and I couldn't find a way to do this purely using built-in objects.
The code below basically uninstalls the add-in, invokes the "Add-ins" dialog box and uses SendKeys to remove it from the list, before copying the new file and reinstalling the add-in.
Amend it for your circumstances - it will depend on your users having their security settings low enough to let it run, of course.
Sub UpdateAddIn()
Dim fs As Object
Dim Profile As String
If Workbooks.Count = 0 Then Workbooks.Add
Profile = Environ("userprofile")
Set fs = CreateObject("Scripting.FileSystemObject")
AddIns("MyAddIn").Installed = False
Call ClearAddinList
fs.CopyFile "\\SourceOfLatestAddIn\MyAddIn.xla", Profile & "\Application Data\Microsoft\AddIns\", True
AddIns.Add Profile & "\Application Data\Microsoft\AddIns\MyAddIn.xla"
AddIns("MyAddIn").Installed = True
End Sub
Sub ClearAddinList()
Dim MyCount As Long
Dim GoUpandDown As String
'Turn display alerts off so user is not prompted to remove Addin from list
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Do
'Get Count of all AddIns
MyCount = Application.AddIns.Count
'Create string for SendKeys that will move up & down AddIn Manager List
'Any invalid AddIn listed will be removed
GoUpandDown = "{Up " & MyCount & "}{DOWN " & MyCount & "}"
Application.SendKeys GoUpandDown & "~", False
Application.Dialogs(xlDialogAddinManager).Show
Loop While MyCount <> Application.AddIns.Count
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I use a reversioning addin-manager to do this: basically its a small xla/xlam that never changes thats installed on each users machine. It checks a network share for the latest version of the real addin(s) and opens it as if it was an ordinary workbook: this has the effect of loading the real Addin(s) for the user.
There is a downloadable working example which you can customise here
Another option, this is what I do.
Key points.
Addin version is "some number", file name is always the same.
Installation directory must be known
When asked, the current addin, looks to see if a new version is available. I do this via a system that has a version number in the file name of the "update" and a version number as a const in the code.
Having established I we can update, I go and get the update "package" - in my case I am using an installer and a small vb.net app. If you cant do this then you might want to spin up an insatnce of PPT or word, and use that complete the install.
Next close yourself, or ask the user to close Excel.
Now all we need to do is save the new addin over the old one, with the same file name.
Tell the user its updated, and they should re-open Excel, close the install program.
This works well for me - although you need to remember the numbering system , in the file name and how that code works.
The below is the main guts of the code bit messy, but might help you out.
Private Sub CommandButton1_Click()
Dim RetVal As Long
MsgBox "To install the update, follow the installer programes directions." & vbNewLine & vbNewLine & _
"You will need to then closed down and restart Excel.", vbInformation + vbOKOnly, "::::UPDATE TRS:::::"
RetVal = Shell(gsDataBase1 & "\" & gsUpdatefolder & "\" & GetUpdateFileName(), 1)
ThisWorkbook.Close
Unload Me
End Sub
Private Sub CommandButton2_Click()
gbInUpdate = False
Unload Me
End Sub
Private Sub UserForm_Initialize()
Me.lbNew = GetServerVersion2
Me.lbCurrent.Caption = gcVersionNumber
'CheckVersionNumbers
End Sub
'''This method might be better, but is quite slow.
Public Sub GetServerVersion()
Set objshell = CreateObject("Shell.Application")
Set objFolder = objshell.Namespace(gsDataBase1 & "\" & gsUpdatefolder)
For Each strFileName In objFolder.Items
Me.lbNew.Caption = objFolder.GetDetailsOf(strFileName, 11)
Next
Set objshell = Nothing
End Sub
Public Function IsNewer() As Boolean
Dim curVer As Long
Dim newVer As Long
On Error GoTo Catch
curVer = CLng(Left(Replace(Me.lbCurrent, ".", ""), 2))
newVer = CLng(Left(Replace(Me.lbNew, ".", ""), 2))
If curVer < newVer Then
IsNewer = True
Else
IsNewer = False
End If
Exit Function
Catch:
IsNewer = False
End Function
Private Function GetServerVersion2() As String
On Error GoTo LEH
Dim strDocPath As String
Dim strCurrentFile As String
strDocPath = gsDataBase1 & "\" & gsUpdatefolder & "\"
strCurrentFile = Dir(strDocPath & "*.*")
'gets last file - randomly? should onl;y be one anyway!
'Do While strCurrentFile <> ""
GetServerVersion2 = Right(strCurrentFile, 11)
GetServerVersion2 = Left(GetServerVersion2, 7)
'Loop
Exit Function
LEH:
GetServerVersion2 = "0.Error"
End Function
'Basiclly a coop of GetSeverVerion, but just get the file name so the exe can be called by the shell operation under the update button
''seems clumbys, but works!
Private Function GetUpdateFileName() As String
On Error GoTo LEH
Dim strDocPath As String
Dim strCurrentFile As String
strDocPath = gsDataBase1 & "\" & gsUpdatefolder & "\"
GetUpdateFileName = Dir(strDocPath & "*.*")
Exit Function
LEH:
GetUpdateFileName = "0.Error"
End Function
I have a project where I maintain a list of all my students and their information in an Excel file labeled "BigList.xlsx". Then, I have about 40-50 other separate ancillary excel files that link to BigList by using VLOOKUP.
For example, in cell A1 of an ancillary file you might see a formula that looks like this:
=Vlookup(B3,
'c:\documents and settings\user\desktop\[BigList.xlsx]Sheet1'!$a$1:$b$10000,
2,false).
The vlookup link above references BigList.xlsx. However, I just realized that I need to change that file name to something else, like MasterDatabase.xlsm (notice the different extension). Is there an easy way to do this without having to manually go through all 40-50 files and doing a find & replace?
I think the basic idea is to change a hardcoded link into a dynamic one where I can change the filename of BigList.xlsx anytime, and not have to go back through all 40-50 files to update their links.
This should do what you require - maybe not super fast but if you only need to do it once on 50 workbooks it should be good enough. Note that the replace line should make the replacement in all the sheets of the workbook.
Option Explicit
Public Sub replaceLinks()
Dim path As String
Dim file As String
Dim w As Workbook
Dim s As Worksheet
On Error GoTo error_handler
path = "C:\Users\xxxxxx\Documents\Test\"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
file = Dir$(path & "*.xlsx", vbNormal)
Do Until LenB(file) = 0
Set w = Workbooks.Open(path & file)
ActiveSheet.Cells.Replace What:="'THE_LINK_YOU_WANT_TO_CHANGE'!", _
Replacement:="'THE_NEW_LINK'!", LookAt:=xlPart
w.Save
w.Close
file = Dir$
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
error_handler:
MsgBox Err.Description
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You can do this in Excel 2010 without using any code. (If memory serves, it will also work in earlier versions of Excel.)
Open all 50 ancillary excel files in Excel at the same time.
Open BigList.xlsx. (You now have 51 files open in Excel.)
Click File - Save As and save BigList as MasterDatabase.xlsm
Close the new MasterDatabase.xlsm file.
Look at one of the ancillary files and verify that Excel has it pointed to the new file.
Close and save all files.
This code will automate the link change directly
Update your paths to BigList.xlsx and MasterDatabase.xlsm in the code
Update your path to the 40-50 files (I have used c:\temp\")
The code will then open both these files (for quicker relinking), then one by open the files in strFilePath, change the link from WB1 (strOldMasterFile ) to Wb2 (strOldMasterFile ), then close the saved file
Please note it assumes all these files are closed on code start, as the code will open these file
Sub ChangeLinks()
Dim strFilePath As String
Dim strFileName As String
Dim strOldMasterFile As String
Dim strNewMasterFile As String
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim WB3 As Workbook
Dim lngCalc As Long
strOldMasterFile = "c:\testFolder\bigList.xlsx"
strNewMasterFile = "c:\testFolder\newFile.xlsm"
On Error Resume Next
Set WB1 = Workbooks.Open(strOldMasterFile)
Set WB2 = Workbooks.Open(strNewMasterFile)
If WB1 Is Nothing Or WB2 Is Nothing Then
MsgBox "One (or both) of " & vbnerwline & strOldMasterFile & vbNewLine & strNewMasterFile & vbNewLine & "cannot be found"
WB1.Close False
WB2.Close False
Exit Sub
End If
On Error GoTo 0
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With
strFilePath = "c:\temp\"
strFileName = Dir(strFilePath & "*.xls*")
'Error handling as link may not exist in all files
On Error Resume Next
Do While Len(strFileName) > 0
Set WB2 = Workbooks.Open(strFilePath & strFileName, False)
WB2.ChangeLink strOldMasterFile, strNewMasterFile, xlExcelLinks
WB2.Save
WB2.Close False
strFileName = Dir
Loop
On Error GoTo 0
WB1.Close False
WB2.Close False
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With
End Sub
I need to rename a workbook to the name of a cell when the user clicks "Save" or "Save as". My guess is that I would need to do this in the Workbook_BeforeSave event. I have the following questions:
How do you set the ActiveWorkbook.FullName property with out calling Save, SaveAs, or SaveCopyAs?
Is what I am trying to do even possible without disabling the toolbar and adding custom save buttons?
I use the following code to get create the filename
Dim fName As String, sName As String
fName = ThisWorkbook.FullName
sName = ThisWorkbook.Name
fName = Left(fName, (Len(fName) - Len(sName))) & _
Thisworkbook.Worksheet("Cust").Range("FILE").Value & ".xls"
Thanks
You can't change the Name or Fullname properties except through a save operation. The Before_Save event has a Cancel argument that if you set to True will stop the save operation and let you do it yourself. Here's an example.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sOldName As String
'If SaveAsUI Then
Cancel = True 'cancel the save and do it yourself in code
sOldName = Me.FullName 'store the old name so you can delete it later
'Save using the value in the cell
Application.EnableEvents = False
Me.SaveAs Me.Path & Application.PathSeparator & _
Me.Worksheets("CUST").Range("FILE").Value & ".xls"
Application.EnableEvents = True
'If the name changed, delete the old file
If Me.FullName <> sOldName Then
On Error Resume Next
Kill sOldName
On Error GoTo 0
End If
'End If
End Sub