Save Copy File as Read Only (VBA)

ybr_15

Board Regular
Joined
May 24, 2016
Messages
204
Office Version
  1. 2019
  2. 2013
Platform
  1. Windows
Hi dear,

I am still learning about vba. I have a code to create copy/duplicate file to other directory, like this:
Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim FSO As Object
    Dim strTargetPath As String
    Dim strFileName As String
    Dim strFilestrFileExtensionension As String
    Dim strFolderName As String
    
    Application.EnableEvents = False
    strTargetPath = "\\192.168.0.6\Production"
    strFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".") - 1))
    strFileExtension = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, "."))
    strFolderName = strFileName

    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If FSO.FolderExists(strTargetPath) Then
        If Not FSO.FolderExists(strTargetPath & "/" & strFolderName) Then
            FSO.CreateFolder (strTargetPath & "/" & strFolderName)
        End If
        wb.SaveCopyAs strTargetPath & "\" & strFolderName & "\" & strFileName & "." & strFileExtension
    Else
        MsgBox "ERROR:  Source File does not exist or is not accessible."
    End If
    Application.EnableEvents = True
End Sub
But, now I want to add or change the code so that the file copy on the server (\\ 192.168.0.6 \ Production) becomes a read only file so it can be opened but it cannot be modified by others. Can you help me? Thank you (Note: Sorry for my bad English)
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Hello.

Add the line shown in red:
Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim FSO As Object
    Dim strTargetPath As String
    Dim strFileName As String
    Dim strFilestrFileExtensionension As String
    Dim strFolderName As String
    
    Application.EnableEvents = False
    strTargetPath = "\\192.168.0.6\Production"
    strFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".") - 1))
    strFileExtension = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, "."))
    strFolderName = strFileName

    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If FSO.FolderExists(strTargetPath) Then
        If Not FSO.FolderExists(strTargetPath & "/" & strFolderName) Then
            FSO.CreateFolder (strTargetPath & "/" & strFolderName)
        End If
        wb.SaveCopyAs strTargetPath & "\" & strFolderName & "\" & strFileName & "." & strFileExtension
[COLOR=#ff0000]        SetAttr strTargetPath & "\" & strFolderName & "\" & strFileName & "." & strFileExtension, vbReadOnly[/COLOR]
    Else
        MsgBox "ERROR:  Source File does not exist or is not accessible."
    End If
    Application.EnableEvents = True
End Sub
 
Upvote 0
Hi jmacleary,

Sorry, I tried your code but I got error (Run-time error '1004' : Microsoft Excel cannot acess file...) in this line every time I click SAVE:
Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim wb As Workbook: Set wb = ThisWorkbook
Dim FSO As Object
Dim strTargetPath As String
Dim strFileName As String
Dim strFilestrFileExtensionension As String
Dim strFolderName As String

Application.EnableEvents = False
strTargetPath = "\\192.168.0.6\Production"
strFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".") - 1))
strFileExtension = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, "."))
strFolderName = strFileName

Set FSO = CreateObject("Scripting.FileSystemObject")

If FSO.FolderExists(strTargetPath) Then
If Not FSO.FolderExists(strTargetPath & "/" & strFolderName) Then
FSO.CreateFolder (strTargetPath & "/" & strFolderName)
End If
[COLOR=#ffa500]wb.SaveCopyAs strTargetPath & "" & strFolderName & "" & strFileName & "." & strFileExtension[/COLOR]
SetAttr strTargetPath & "" & strFolderName & "" & strFileName & "." & strFileExtension, vbReadOnly
Else
MsgBox "ERROR: Source File does not exist or is not accessible."
End If
Application.EnableEvents = True
End Sub
 
Upvote 0
Ah yes. As written, it will only work the first time the file is saved. Try this modified version:
Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim wb As Workbook: Set wb = ThisWorkbook
Dim FSO As Object
Dim strTargetPath As String
Dim strFileName As String
Dim strFilestrFileExtensionension As String
Dim strFolderName As String
[COLOR=#ff0000]Dim strFullPath As String[/COLOR]

Application.EnableEvents = False
strTargetPath = "\\192.168.0.6\Production"
strFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".") - 1))
strFileExtension = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, "."))
strFolderName = strFileName

Set FSO = CreateObject("Scripting.FileSystemObject")

If FSO.FolderExists(strTargetPath) Then
If Not FSO.FolderExists(strTargetPath & "/" & strFolderName) Then
FSO.CreateFolder (strTargetPath & "/" & strFolderName)
End If
[COLOR=#ff0000]strFullPath= strTargetPath & "" & strFolderName & "" & strFileName & "." & strFileExtension
If Dir(strFullPath) > "" Then   ' look to see if file exists
     SetAttr strFullPath, vbNormal
End If
wb.SaveCopyAs strFullPath
SetAttr strFullPath, vbReadOnly[/COLOR]
Else
MsgBox "ERROR: Source File does not exist or is not accessible."
End If
Application.EnableEvents = True
End Sub
 
Upvote 0
Hi again jmacleary,

I got error in this line (Run-time error '52': Bad file name or number)
Code:
If Dir(strFullPath) = "" Then
Thanks
 
Upvote 0
Somehow the line setting the full path has been modified. Replace it with this:

strFullPath = strTargetPath & "" & strFolderName & "" & strFileName & "." & strFileExtension
 
Upvote 0
Hi jmacleary,

I tried to modified your code and work properly, here the code:

Rich (BB code):
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim FSO As Object
    Dim strTargetPath As String
    Dim strFileName As String
    Dim strFilestrFileExtensionension As String
    Dim strFolderName As String
    Dim strFullPath As String
   
    Application.EnableEvents = False
    strTargetPath = "\\192.168.0.6\Production"
    strFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".") - 1))
    strFileExtension = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, "."))
    strFolderName = strFileName


    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    If FSO.FolderExists(strTargetPath) Then
        If Not FSO.FolderExists(strTargetPath & "/" & strFolderName) Then
            FSO.CreateFolder (strTargetPath & "/" & strFolderName)
        End If
        strFullPath = strTargetPath & "\" & strFolderName & "\" & strFileName & "." & strFileExtension
        If FSO.FileExists(strFullPath) Then
            SetAttr strFullPath, vbNormal
        End If
        wb.SaveCopyAs strFullPath
        SetAttr strFullPath, vbReadOnly
    Else
        MsgBox "ERROR:  Target Folder does not exist or is not accessible."
    End If
    Application.EnableEvents = True



End Sub
Thank you
 
Last edited by a moderator:
Upvote 0
Hi,

This code works perfectly for me, thanks for that.
Could you help me how to use this for saving the copy as macro disabled file? .xlsx
 
Upvote 0

Forum statistics

Threads
1,213,495
Messages
6,113,992
Members
448,538
Latest member
alex78

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top