I have used the below code to a workbook (SaveAs) and then delete the original file.
The Windows OS put the new created file on the first left vacant space on My Desktop.
What I need after using SaveAs , is to move it’s icon to the same old position of the original file on my Desktop.
Meaning, If my file is initially placed on the upper right of my desktop , I want to keep it in that location after using SaveAs.
In advance, appreciate for your time to help.
Sub Rename_Me_Automatic()
Application.DisplayAlerts = False
Dim FilePath As String, wb As Workbook, FolderPath As String
Dim oldName As String, newName As String
Set wb = ThisWorkbook
FilePath = wb.FullName
FolderPath = wb.Path & Application.PathSeparator
oldName = wb.Name
newName = Left(oldName, Len(oldName) - 5) & WorksheetFunction.RandBetween(1, 20)
wb.SaveAs FolderPath & newName
Kill FilePath 'delete orginal file
Application.DisplayAlerts = True
End Sub
Please, also try this code. It uses classical Windows behavior. VBA writes a VBScript, creates the file and runs it. The script finds the open Excel session, the workbook in discussion, save, close it, quits Excel application in certaing circumstances and changes the workbook name only after that (keeping the same file icon position). Finally, the script kills itself:
Sub SaveAndChangeActiveWorkbookName_VBScript()
Dim vbsStr As String, fso As Object, vbsObj As Object, strVBSPath As String
Dim newName As String, wb As Workbook, ext As String, searchName As String
Set wb = ThisWorkbook
With wb
ext = Split(.Name, ".")(UBound(Split(.Name, ".")))
searchName = Left(.Name, Len(.Name) - (Len(ext) + 1))
End With
newName = searchName & WorksheetFunction.RandBetween(5, 20) & "." & ext
strVBSPath = ThisWorkbook.Path & "\Rename.vbs" 'the fullname of the VBScript to be created and run
vbsStr = "Dim objExcel, wb, objFile, FSO, fullName" & vbCrLf & _
"Set objExcel = GetObject(, ""Excel.Application"")" & vbCrLf & _
"Set FSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _
" Set wb = objExcel.Workbooks(""" & ThisWorkbook.Name & """)" & vbCrLf & _
"fullName = wb.FullName" & vbCrLf & _
"wb.Close True" & vbCrLf & _
"If objExcel.Workbooks.Count = 0 Then" & vbCrLf & _
" objExcel.Quit" & vbCrLf & _
"ElseIf objExcel.Workbooks.Count = 1 Then" & vbCrLf & _
" If not UCase(Workbooks(1).Name) = ""PERSONAL.XLSB"" Then" & vbCrLf & _
" objExcel.Quit" & vbCrLf & _
" End If" & vbCrLf & _
"End If" & vbCrLf & _
"Set objFile = FSO.GetFile(fullName)" & vbCrLf & _
"objFile.Name = """ & newName & """" & vbCrLf & _
"FSO.DeleteFile Wscript.ScriptFullName, True" 'kill itself...
Set fso = CreateObject("Scripting.FileSystemObject")
Set vbsObj = fso.OpenTextFile(strVBSPath, 2, True)
vbsObj.Write vbsStr 'write the above string in the VBScript file
vbsObj.Close
Shell "cmd.exe /c """ & strVBSPath & """", 0 'execute/run the VBScript
End Sub
The next version tries simplifying your code, not needing any API:
Sub SaveAndChangeActiveWorkbookName_ShellAppl()
Dim sh32 As Object, oFolder As Object, oFolderItem As Object, wb As Workbook
Dim newName As String, ext As String, searchName As String
Set sh32 = CreateObject("Shell.Application")
Set wb = ThisWorkbook
With wb
ext = Split(.Name, ".")(UBound(Split(.Name, "."))) 'extract extension
searchName = Left(.Name, Len(.Name) - (Len(ext) + 1)) 'extract the rest of its name
newName = searchName & WorksheetFunction.RandBetween(5, 20) & _
IIf(showExtension, "." & ext, "") 'it sets correct new name...
.Save
.ChangeFileAccess xlReadOnly '!
Set oFolder = sh32.Namespace(.Path & "\")
Set oFolderItem = oFolder.ParseName(.Name)
oFolderItem.Name = newName
If (UCase(Workbooks(1).Name) = "PERSONAL.XLSB" _
And Workbooks.Count = 2) Or Workbooks.Count = 1 Then
Application.Quit
Else
.Close False 'no need to save it again and it closes faster in this way...
End If
End With
End Sub
'Function to check how 'Hide extension for known file type' is set:
Function showExtension() As Boolean
Dim fileExt As String, Shl As Object, hideExt As Long
fileExt = "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\HideFileExt"
Set Shl = CreateObject("WScript.Shell")
hideExt = Shl.RegRead(fileExt)
If hideExt = 0 Then showExtension = True
End Function
I've been educated that Windows does not allow changing name of an open workbook. Which is true, you cannot do it manually. Windows does not let you do it, this is its philosophy to avoid data loss.
But setting ReadOnly file attribute looks to temporarily remove the file full name from the Windows File Allocation Table. If you try Debug.Print wb.FullFileName before and after changing its attribute, it will show the same (old) one. But it looks that there are ways to do it and letting the open workbook outside the Allocation Table, you can change its name. I did not even imagine this is possible and I consider that this is the most important issue I learned today.
Intro: Windows OS saves the positions of desktop icons somewhere in registry or another location.
When I post my question, I thought the answer will depend on extracting coordinates of (SavedAs workbook icon) on my desktop,
And then using an API method to place it on the old location of the original file.
But , It looks hard for VBA programmers.
So, I tried the idea of #Daniel Dušek :
(The idea was to SaveAs with the original file name which will just overwrite the old file and then rename it instead of deleting).
The idea itself is excellent, But using native VBA methods (Name and FileSystemObject. MoveFile) ,
have a possible behavior to move the file beside renaming and I need to imitate how Windows OS works when it rename a file (like when you use right-click and choose Rename),
and also, I cannot rename the open workbook by using (Name and FSO. MoveFile) even after set ChangeFileAccess to xlReadOnly.
But, with using native OS API , you can do much more than you can imagine.
I have got a sophisticated API to Rename Link by the professional #Siddharth Rout
The advantage of this API is you can rename a workbook while it is still open (sure after Change File Access to xlReadOnly) 😊.
Now, All works correctly as expected, and I can SaveAs a file keep it’s icon on desktop at the same old position of the original file.
Sub SaveAs_and_Rename_Me_Automatically()
Dim wb As Workbook, filePath As String, folderPath As String
Dim oldName As String, newName As String, ext As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
filePath = wb.FullName
folderPath = wb.Path & "\"
oldName = fso.GetBaseName(filePath)
ext = fso.GetExtensionName(filePath)
newName = oldName & WorksheetFunction.RandBetween(5, 20) & "." & ext
Application.DisplayAlerts = False
wb.SaveAs folderPath & oldName 'SaveAs with orginal name (just overwrite)
wb.ChangeFileAccess xlReadOnly 'change file access to Read_Only:
SHRenameFile filePath, folderPath & newName 'to rename the Workbook while it is still open!
Application.DisplayAlerts = True
If Workbooks.Count = 1 Then
Application.Quit
Else
ThisWorkbook.Close SaveChanges:=True
End If
End Sub
And this the great API to rename:
Private Declare PtrSafe Function SHFileOperation Lib "shell32.dll" _
Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As LongPtr
Private Const FOF_SIMPLEPROGRESS = &H100
Private Const FO_RENAME = &H4
Private Type SHFILEOPSTRUCT
hWnd As LongPtr
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As LongPtr
sProgress As String
End Type
Public Sub SHRenameFile(ByVal strSource As String, ByVal strTarget As String)
Dim op As SHFILEOPSTRUCT
With op
.wFunc = FO_RENAME
.pTo = strTarget
.pFrom = strSource
.fFlags = FOF_SIMPLEPROGRESS
End With
SHFileOperation op '~~> Perform operation
End Sub
a bit hacky setup but works, the idea is following:
save workbook with the suffix "to_del"
from that temp file we rename the original file
save the workbook as the renamed file
delete "to_del" file from the original file
the code:
Sub Rename_Me_Automatic()
Application.DisplayAlerts = False
Dim filePath As String
Dim folderPath As String
Dim oldName As String
Dim newName As String
Dim wb As Workbook
Set wb = ThisWorkbook
filePath = wb.FullName
folderPath = wb.path & Application.PathSeparator
oldName = wb.Name
newName = Left(oldName, Len(oldName) - 5) & WorksheetFunction.RandBetween(1, 20)
wb.SaveAs Filename:=folderPath & newName & "_to_del.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Name folderPath & oldName As folderPath & newName & ".xlsm"
wb.SaveAs Filename:=folderPath & newName & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Kill folderPath & newName & "_to_del.xlsm"
Application.DisplayAlerts = True
End Sub
You do not say anything...
I have something to do in the next time interval, so I prepared a workaround, but working code based on my comment to your answer assumption, respectively:
A workbook named as the one keeping the code, only having a different numeric suffix before its extension, must exist on Desktop, like reference for the place where the other workbook to be placed;
Your code creates a new workbook, with a random (new) suffix.
ThisWorkbook is saved overwriting the existing workbook on Desktop, but using SaveCopyAs, to let the original workbook open and the overwitted workbook to be renamed (not being open):
Private Sub testSaveCopyAsOverwrite()
'References:
'Microsoft Shell Controls And Automation '(C:\Windows\System32\Shell32.dll)
Dim oShell As Shell32.Shell, oFolder As Shell32.Folder, oFolderItem As Shell32.FolderItem
Dim filePath As String, initFileName As String, newFileName As String, wb As Workbook
Dim thisName As String, newName As String, ext As String, searchName As String
filePath = "C:\Users\Fane Branesti\OneDrive\Desktop\"
Set wb = ThisWorkbook
thisName = wb.name
ext = Split(thisName, ".")(UBound(Split(thisName, ".")))
searchName = left(thisName, Len(thisName) - (Len(ext) + 1))
RecreateName: 'for the case when RandBetween returns the same name suffix...
newName = searchName & WorksheetFunction.RandBetween(5, 20) & "." & ext
Set oShell = New Shell32.Shell
initFileName = Dir(filePath & searchName & "*." & ext) 'find the file to be overwriten
If initFileName <> "" Then
If newName = initFileName Then GoTo RecreateName 'if RandBetween returned the same suffix...
ThisWorkbook.SaveCopyAs fileName:=filePath & initFileName 'overwrite the existing workbook, but keeping the original wb open
Set oFolder = oShell.NameSpace(filePath)
Set oFolderItem = oFolder.ParseName(initFileName)
oFolderItem.name = newName 'change the initial file name with the necessary one, without moving it!
Else
MsgBox "No any workbook having the name pattern as: """ & filePath & searchName & """*." & ext & """"
End If
End Sub
Please, take care to add the required reference (from C:\Windows\System32\Shell32.dll) before running it...
In fact, you can run the next code to add it:
Sub addShellControlsAndAutomation()
'Add a reference to 'Microsoft Shell Controls And Automation':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
On Error Resume Next
Application.vbE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\Shell32.dll"
If err.number = 32813 Then
err.Clear: On Error GoTo 0
MsgBox "'Microsoft Shell Controls And Automation' reference already added...", vbInformation, _
"Reference already existing"
End If
On Error GoTo 0
End Sub
This code works perfectly it saves an excel file to CSV-UTF8 and adds a timestamp in front of the file named "Test".
However, when I assign this code to a button, I'm always getting an error 400 for some reason.
So what I did is put the same code inside a module and debug it, and it didn't give me any errors it executed the code without any problems.
Can someone help me get this to work while using a button?
Sub SaveWorkSheetAsCSV()
Dim wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim name As String, myPath As String
comp = Environ("username")
myPath = "C:\" & comp & "\Testing\" 'use here the path you need
Set wsSource = ThisWorkbook.Worksheets(1)
name = Format(Now, "yyyymmdd-hh.mm") & " Testing"
Application.DisplayAlerts = False 'will overwrite existing files without asking
Set wbNew = ActiveWorkbook
wbNew.SaveAs myPath & "\" & name & ".csv", xlCSVUTF8 'new way
wbNew.Close
Application.DisplayAlerts = True
End Sub
Error 1004
Recieving the following error on this part:
wbNew.SaveAs myPath & "\" & name & ".csv", xlCSVUTF8 'new way
Export to CSV
'Semicolon users' might want to add , Local:=True to the SaveAs line to get the result separated by the semicolon.
ThisWorkbook.FollowHyperlink FolderPath will open the folder in Windows File Explorer.
The Code
Option Explicit
Sub SaveWorkSheetAsCSV()
Dim FolderPath As String
FolderPath = Environ("USERPROFILE") & "\Testing"
' or:
'FolderPath = "C:\Users\" & Environ("USERNAME") & "\Testing"
' Print the path to the Immediate window (CTRL+G).
'Debug.Print FolderPath
Dim FileName As String: FileName = Format(Now, "yyyymmdd-hh.mm ") & " Test"
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets(2)
Application.ScreenUpdating = False
sws.Copy
Dim dwb As Workbook: Set dwb = ActiveWorkbook
Application.DisplayAlerts = False
dwb.SaveAs FolderPath & "\" & FileName & ".csv", xlCSVUTF8 ', Local:=True
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Application.ScreenUpdating = True
'ThisWorkbook.FollowHyperlink FolderPath
End Sub
I am trying to get the following done. When I open workbook in folder, it opens, runs code where new copy of this workbook is created in "TEMP" folder and the original is closed. The idea is to have multiple copies open at the same time and on closing, all user updates copy into the original.
Everything works well when when workbook is opened second time, however on first opening when in Protected view I get Run-time error '91' Object variable or With block variable not set.
I have read a good bit about this issue but can't seem to figure it out.
Any help is much appreciated.
Private Sub Workbook_Open()
Dim strFilename, strDirname, strDirname2, strPathname, strDefpath As String
'Count files in folder
Dim MyFolder As String
Dim MyFile As String
Dim j As Integer
Dim strDefpatheee As String
Dim strDirnameeee As String
strDirnameeee = "TEMP"
strDefpatheee = Application.ActiveWorkbook.Path
MyFolder = strDefpatheee & "\" & strDirnameeee
MyFile = Dir(MyFolder & "\" & "*.xlsm")
Do While MyFile <> ""
j = j + 1
MyFile = Dir
Loop
'Save as same name + count of files in folder TEMP
On Error Resume Next ' If directory exist goto next line
strDirname = "TEMP" ' New directory name
strFilename = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & " " & j + 1 'New file name
strDefpath = Application.ActiveWorkbook.Path 'Default path name
'If IsEmpty(strDirname) Then Exit Sub
'If IsEmpty(strFilename) Then Exit Sub
'MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename 'create total string
ActiveWorkbook.SaveAs Filename:=strPathname & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Sheets("ACTIONS").Range("BG2").ClearContents
Sheets("ACTIONS").Range("D6").Select
PasswordEntry.Show
End Sub
I have a spreadsheet that creates a CSV file and deposits the CSV file in a folder next to the original file. The spreadsheet seems to work fine. When you have your data entered, you click export, and a CSV file is put in a folder called "Uploads" that is next to the original file.
The issue is when I use the quick print button on my Excel quick access toolbar. When I click the quick print button, everything seems to print fine. However, as soon as I close the file, (EDIT: ALL Printing seems to be freezing the file. As soon as the file is closed) Excel then goes into a freeze where it looks like it is trying to run some code? I am a novice in VBA so I am not sure what is happening, all I know is that after my file is closed, Excel freezes up and I have to restart Excel. I do not even have any macros or VBA for an Excel close or Excel open trigger.
Can anyone recreate the issue and give me insight into how my code might be doing this?
Private Sub Export_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim MyPath As String
Dim MyFileName As String
'The path and file names:
MyPath = ActiveWorkbook.Path & "\Uploads"
MyFileName = "" & Range("a2") & "_Upload"
On Error GoTo Ending
'Makes sure the path name ends with "\":
If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
'Makes sure the filename ends with ".csv"
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
'Copies the sheet to a new workbook:
Sheets("UploadData").Copy
'The new workbook becomes Activeworkbook:
With ActiveWorkbook 'Saves the new workbook to given folder / filename:
.SaveAs FileName:= _
MyPath & MyFileName, _
FileFormat:=xlCSV, _
CreateBackup:=False 'Closes the file
.Close False
End With
ChDir MyPath
Workbooks.Open FileName:= _
MyPath & "\" & MyFileName & """"
ActiveWorkbook.Save
ActiveWorkbook.Close
GoTo Skip
Ending:
MsgBox ("ERROR! Please make sure you have a folder named Uploads next to the template file")
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Skip:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This actually shouldn't work at all, regardless of what you do before you run it. First, you ensure that MyPath ends with a \ here...
'Makes sure the path name ends with "\":
If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
...but then when you (re)build the same path below you're inserting a second \:
Workbooks.Open FileName:= _
MyPath & "\" & MyFileName & """"
This should always fail. You can avoid this entire problem with paths by using the Scripting.FileSystemObject's .BuildPath function:
'Requires a reference to Microsoft Scripting Runtime.
Dim filePath As String, fso As New Scripting.FileSystemObject
filePath = fso.BuildPath(ThisWorkbook.Path, MyFileName)
You can also use this for the file extension:
If LCase$(fso.GetExtensionName(MyFileName)) <> "csv" Then
MyFileName = MyFileName & ".csv"
End If
Note that this test will never be true...
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
...because MyFileName will always end with "load":
MyFileName = "" & Range("a2") & "_Upload"
Also, you should remove all the references to ActiveWorkbook. I have no idea why printing would effect this, but there isn't anything else I can identify that should be an issue. I'd structure it more like this (error handler removed for clarity - don't put it back until you're finished debugging it):
'Add a reference to Microsoft Scripting Runtime.
Private Sub Export_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With New Scripting.FileSystemObject
Dim filePath As String
Dim targetDir As String
targetDir = .BuildPath(ThisWorkbook.Path, "Uploads")
If Not .FolderExists(targetDir) Then
MsgBox ("ERROR! Please make sure you have a folder named Uploads next to the template file")
Exit Sub
End If
filePath = .BuildPath(targetDir, ActiveSheet.Range("A2").Value & "_Upload.csv")
End With
'Copies the sheet to a new workbook:
Dim csv As Workbook
Set csv = Application.Workbooks.Add
With csv
ThisWorkbook.Sheets("UploadData").Copy .Sheets(1)
.SaveAs Filename:=filePath, _
FileFormat:=xlCSV, _
CreateBackup:=False 'Closes the file
.Close xlDoNotSaveChanges
End With
'Reopen and re-save to fix formatting.
Set csv = Workbooks.Open(filePath)
csv.Close xlSaveChanges
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Dim savepath as String
Dim dfile as String
Dim wb as Workbook
'strings setting omitted
If Not Dir(savepath & dfile) <> "" Then
MsgBox "Cannot find the file."
End If
Set wb = Workbooks(savepath & dfile)
wb.Open
'Workbooks(savepath & dfile).Open also fails
I'm getting a run-time error 9 despite the Dir() not raising the messagebox. I can copy and paste the concatenated string into Windows Explorer bar and the excel file opens, so the file certainly exists.
Any ideas?
Workbooks only includes open workbooks. To open a workbook you use Workbooks.Open(pathToFile)
Dim savepath as String
Dim dfile as String
Dim wb as Workbook
'strings setting omitted
If Dir(savepath & dfile) = "" Then
MsgBox "Cannot find the file."
Else
Set wb = Workbooks.Open(savepath & dfile)
End If
i would suggest changing your code mainly in the if condition to:
Dim savepath as String
Dim dfile as String
Dim wb as Workbook
'strings setting omitted
strFilename = Dir(savepath & dfile)
If Len(strFilename) > 0 Then
Set wb = Workbooks.Open(savepath & dfile)
Else
MsgBox "Cannot find the file " & dfile & " in " & savepath & "."
End If
This way you also assure, that Open only happens when file actually exists and i think putting the positive case on top and the error on bottom is more readable.
you could also write
If Dir(savepath & dfile) <> "" Then
but for a quick brief review of code, something like NOT fn() <> "" is not as understandable